public
Created

Naive do-notation desugarer

  • Download Gist
DesugarDo.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
import Data.Generics
import Language.Haskell.Parser
import Language.Haskell.Pretty
import Language.Haskell.Syntax
 
main = do
input <- getContents
case parseModule input of
ParseOk mod -> putStrLn $ prettyPrint $ everywhere (mkT desugarExp) mod
ParseFailed loc msg -> failed loc msg
 
desugarExp (HsDo stmts) = desugarDo stmts
desugarExp other = other
 
desugarDo [HsQualifier exp] = exp
desugarDo (HsGenerator loc pat exp : stmts) = HsInfixApp exp bindOp body
where body | canFail pat = bindPattern loc pat exp stmts
| otherwise = HsLambda loc [pat] (desugarDo stmts)
desugarDo (HsQualifier exp : stmts) =
HsInfixApp exp thenOp $ desugarDo stmts
desugarDo (HsLetStmt decls : stmts) =
HsLet decls $ desugarDo stmts
desugarDo _ = error "invalid do-block"
 
canFail (HsPVar _) = False
canFail (HsPParen pat) = canFail pat
canFail (HsPAsPat _ pat) = canFail pat
canFail HsPWildCard = False
canFail other = True
 
bindPattern loc pat exp stmts =
HsLambda loc [HsPVar dummy] $
HsCase (HsVar $ UnQual dummy)
[ HsAlt loc pat (HsUnGuardedAlt $ desugarDo stmts) []
, HsAlt loc HsPWildCard (HsUnGuardedAlt noMatch) []]
where noMatch = HsApp (HsVar (UnQual $ HsIdent "fail"))
(HsLit (HsString "pattern match failure"))
 
dummy = HsIdent "dummy"
bindOp = HsQVarOp $ UnQual $ HsSymbol ">>="
thenOp = HsQVarOp $ UnQual $ HsSymbol ">>"
 
failed loc msg = do
print loc
putStrLn msg

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.