Skip to content
Create a gist now

Instantly share code, notes, and snippets.

Naive do-notation desugarer
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.