lhc-0.6.20081210: src/FrontEnd/Desugar.hs
{-------------------------------------------------------------------------------
Copyright: The Hatchet Team (see file Contributors)
Module: Desugar
Description: Desugaring of the abstract syntax.
The main tasks implemented by this module are:
- pattern bindings are converted
into "simple" pattern bindings
(x, y, z) = foo
becomes
newVal = foo
x = (\(a, _, _) -> a) newVal
y = (\(_, a, _) -> a) newVal
z = (\(_, _, a) -> a) newVal
- do notation is converted into
expression form, using (>>) and
(>>=)
- type synonyms are removed
Primary Authors: Bernie Pope
Notes: See the file License for license information
According to the Haskell report a pattern
binding is called "simple" if it consists only
of a single variable - thus we convert all
pattern bindings to simple bindings.
-------------------------------------------------------------------------------}
-- Type synonyms are no longer handled here. only 'local' desugaring is done.
-- Does this module need to exist?
module FrontEnd.Desugar (doToExp, desugarHsModule, desugarHsStmt) where
import Control.Monad.State
import FrontEnd.SrcLoc
import GenUtil
import FrontEnd.HsSyn
import Name.Name
import Name.Names
import Name.VConsts
import FrontEnd.Syn.Traverse
import FrontEnd.SrcLoc
removeSynonymsFromType _ t = t
removeSynsFromSig _ t = t
-- (unique int, list of type synoyms)
type PatState = (Int, [HsDecl])
getUnique = do
n <- readUnique
incUnique
return n
readUnique :: PatSM Int
readUnique = do
state <- readPatSM
return (fst state)
readSyns :: PatSM [HsDecl]
readSyns = do
state <- readPatSM
return (snd state)
incUnique :: PatSM ()
incUnique = updatePatSM (\(u, s) -> (u + 1, s))
type PatSM = State PatState
instance MonadSrcLoc PatSM where
instance MonadSetSrcLoc PatSM where
withSrcLoc _ a = a
{------------------------------------------------------------------------------}
readPatSM = get
updatePatSM = modify
runPatSM = flip runState
-- a new (unique) name introduced in pattern selector functions
newPatVarName :: HsName
newPatVarName = nameName $ toName Val "patvar@0"
remSynsSig :: HsDecl -> PatSM HsDecl
remSynsSig sig
= do
syns <- readSyns
let newSig = removeSynsFromSig syns sig
return newSig
remSynsType :: HsType -> PatSM HsType
remSynsType t
= do
syns <- readSyns
let newType = removeSynonymsFromType syns t
return newType
{-
this function replaces all constructor-pattern bindings in a module with
function calls
ie:
(x, y) = head $ zip "abc" [1,2,3]
becomes
x = (\(a, _) -> a) rhs1
y = (\(_, a) -> a) rhs1
rhs1 = head $ zip "abc" [1,2,3]
-}
-- first argument is imported synonyms
desugarHsModule :: HsModule -> HsModule
desugarHsModule m = hsModuleDecls_s ds' m where
(ds', _) = runPatSM (0::Int, undefined) $ dsm (hsModuleDecls m)
dsm ds = fmap concat $ mapM desugarDecl ds
desugarHsStmt :: Monad m => HsStmt -> m HsStmt
desugarHsStmt s = return $ fst $ runPatSM (0::Int, undefined) $ desugarStmt s
desugarHsExp :: Monad m => HsExp -> m HsExp
desugarHsExp s = return $ fst $ runPatSM (0::Int, undefined) $ desugarExp s
desugarDecl :: HsDecl -> PatSM [HsDecl]
desugarDecl (HsForeignDecl a b c qt) = do
qt <- remSynsQualType qt
return [HsForeignDecl a b c qt]
desugarDecl (HsForeignExport a b c qt) = do
qt <- remSynsQualType qt
return [HsForeignExport a b c qt]
desugarDecl (HsFunBind matches) = do
newMatches <- mapM desugarMatch matches
return [HsFunBind newMatches]
-- variable pattern bindings remain unchanged
desugarDecl pb@(HsPatBind sloc (HsPVar n) rhs wheres) = do
newRhs <- desugarRhs rhs
newWheres <- mapM desugarDecl wheres
return [HsPatBind sloc (HsPVar n) newRhs (concat newWheres)]
desugarDecl pb@(HsPatBind sloc pat rhs wheres) = do
rhs <- desugarRhs rhs
unique <- getUnique
let newRhsName = nameName $ toName Val ("patrhs@" ++ show unique)
newWheres <- mapM desugarDecl wheres
let newTopDeclForRhs
= HsPatBind sloc (HsPVar newRhsName) rhs (concat newWheres)
let newBinds = genBindsForPat pat sloc newRhsName
newBinds <- mapM desugarDecl newBinds
return (newTopDeclForRhs : concat newBinds)
desugarDecl (HsClassDecl sloc qualtype decls) = do
newDecls <- mapM desugarDecl decls
return [HsClassDecl sloc qualtype (concat newDecls)]
desugarDecl (HsInstDecl sloc qualtype decls) = do
newQualType <- remSynsQualType qualtype
newDecls <- mapM desugarDecl decls
return [HsInstDecl sloc newQualType (concat newDecls)]
desugarDecl sig@(HsTypeSig _sloc _names _qualType) = do
newSig <- remSynsSig sig
return [newSig]
desugarDecl dl@HsDataDecl { hsDeclSrcLoc = sloc, hsDeclName = name, hsDeclArgs = args, hsDeclCons = condecls, hsDeclDerives = derives } = do
--newConDecls <- mapM remSynsFromCondecl condecls
newConDecls <- return condecls
ds <- deriveInstances sloc name args newConDecls derives
ss <- createSelectors sloc newConDecls
return $ dl:(ds ++ ss)
desugarDecl dl@(HsNewTypeDecl sloc cntxt name args condecl derives) = do
--newConDecl <- remSynsFromCondecl condecl
newConDecl <- return condecl
ds <- deriveInstances sloc name args [newConDecl] derives
ss <- createSelectors sloc [newConDecl]
return $ dl:(ds ++ ss)
desugarDecl anyOtherDecl = return [anyOtherDecl]
createSelectors _sloc ds = ans where
ds' :: [(HsName,[(HsName,HsBangType)])]
ds' = [ (c,[(n,t) | (ns,t) <- rs , n <- ns ]) | HsRecDecl { hsConDeclName = c, hsConDeclRecArg = rs } <- ds ]
ns = sortGroupUnderF fst $ concatMap f ds' -- [ | (c,nts) <- ds' ]
f :: (HsName,[(HsName,HsBangType)]) -> [ (HsName, (HsName,Int,Int)) ]
f (c,nts) = [ (n,(c,i,length nts)) | (n,_) <- nts | i <- [0..]]
ans = return $ map g ns
g (n,cs) = HsFunBind (map f cs ++ [els]) where
f (_,(c,i,l)) = HsMatch _sloc n [pat c i l] (HsUnGuardedRhs (HsVar var)) []
pat c i l = HsPApp c [ if p == i then HsPVar var else HsPWildCard | p <- [0 .. l - 1]]
els = HsMatch _sloc n [HsPWildCard] (HsUnGuardedRhs HsError { hsExpSrcLoc = _sloc, hsExpString = show n, hsExpErrorType = HsErrorFieldSelect } ) []
var = nameName $ toName Val "x"
deriveInstances :: Monad m => SrcLoc -> HsName -> [HsName] -> [HsConDecl] -> [HsName] -> m [HsDecl]
deriveInstances sloc name args cons ds = return []
desugarMatch :: (HsMatch) -> PatSM (HsMatch)
desugarMatch (HsMatch sloc funName pats rhs wheres)
= do
newWheres <- mapM desugarDecl wheres
newRhs <- desugarRhs rhs
return (HsMatch sloc funName pats newRhs (concat newWheres))
-- generate the pattern bindings for each variable in a pattern
genBindsForPat :: HsPat -> SrcLoc -> HsName -> [HsDecl]
genBindsForPat pat sloc rhsName
= [HsPatBind sloc (HsPVar patName) (HsUnGuardedRhs (HsApp selector (HsVar rhsName))) [] | (patName, selector) <- selFuns]
where
selFuns = getPatSelFuns sloc pat
-- generate selector functions for each of the variables that
-- are bound in a pattern
getPatSelFuns :: SrcLoc -> HsPat -> [(HsName, (HsExp))]
getPatSelFuns sloc pat = [(varName, HsParen (HsLambda sloc [HsPVar newPatVarName] (kase (replaceVarNamesInPat varName pat)))) | varName <- getNamesFromHsPat pat] where
kase p = HsCase (HsVar newPatVarName) [a1, a2 ] where
a1 = HsAlt sloc p (HsUnGuardedRhs (HsVar newPatVarName)) []
a2 = HsAlt sloc HsPWildCard (HsUnGuardedRhs (HsApp (HsVar (UnQual $ HsIdent "error")) (HsLit $ HsString $ show sloc ++ " failed pattern match"))) []
-- replaces all occurrences of a name with a new variable
-- and every other name with underscore
replaceVarNamesInPat :: HsName -> HsPat -> HsPat
replaceVarNamesInPat name p = f name p where
f name1 (HsPVar name2)
| name1 == name2 = HsPVar $ newPatVarName
| otherwise = HsPWildCard
f _ p@(HsPLit _) = p
f name (HsPNeg pat) = HsPNeg $ f name pat
f name (HsPInfixApp pat1 conName pat2) = HsPInfixApp (f name pat1) conName (f name pat2)
f name (HsPApp conName pats) = HsPApp conName (map (f name) pats)
f name (HsPTuple pats) = HsPTuple (map (f name) pats)
f name (HsPUnboxedTuple pats) = HsPUnboxedTuple (map (f name) pats)
f name (HsPList pats) = HsPList (map (f name) pats)
f name (HsPParen pat) = HsPParen (f name pat)
f name (HsPRec _ _) = error "f name (HsPRec _ _): not implemented"
f name (HsPAsPat asName pat)
| name == asName = HsPAsPat newPatVarName (f name pat)
| otherwise = f name pat
f name HsPWildCard = HsPWildCard
f name (HsPIrrPat pat) = HsPIrrPat $ fmap (f name) pat
f name p = error $ "f: " ++ show (name,p)
desugarRhs :: (HsRhs) -> PatSM (HsRhs)
desugarRhs (HsUnGuardedRhs e)
= do
newE <- desugarExp e
return (HsUnGuardedRhs newE)
desugarRhs (HsGuardedRhss gRhss)
= do
newRhss <- mapM desugarGRhs gRhss
return (HsGuardedRhss newRhss)
desugarGRhs :: HsGuardedRhs -> PatSM (HsGuardedRhs)
desugarGRhs (HsGuardedRhs sloc e1 e2)
= do
newE1 <- desugarExp e1
newE2 <- desugarExp e2
return (HsGuardedRhs sloc newE1 newE2)
desugarExp :: (HsExp) -> PatSM (HsExp)
desugarExp (HsLambda sloc pats e)
| all isLazyPat pats && not (any isHsPIrrPat pats) = do
newE <- desugarExp e
return (HsLambda sloc pats newE)
desugarExp (HsLambda sloc pats e) = z where
z = do
ps <- mapM f pats
let (xs,zs) = unzip ps
e' <- (ne e $ concat zs)
return (HsLambda sloc (map HsPVar xs) e')
ne e [] = desugarExp e
ne e ((n,p):zs) = do
e' <- ne e zs
let a1 = HsAlt sloc p (HsUnGuardedRhs e') []
a2 = HsAlt sloc HsPWildCard (HsUnGuardedRhs (HsError { hsExpSrcLoc = sloc, hsExpErrorType = HsErrorPatternFailure, hsExpString = show sloc ++ " failed pattern match in lambda" })) []
return $ HsCase (HsVar n) [a1, a2 ]
f (HsPVar x) = return (x,[])
f (HsPAsPat n p) = return (n,[(n,p)])
f p = do
unique <- getUnique
let n = nameName $ toName Val ("lambind@" ++ show unique)
return (n,[(n,p)])
desugarExp (HsLet decls e) = do
newDecls <- mapM desugarDecl decls
newE <- desugarExp e
return (HsLet (concat newDecls) newE)
desugarExp (HsCase e alts) = do
newE <- desugarExp e
newAlts <- mapM desugarAlt alts
return (HsCase newE newAlts)
desugarExp (HsDo stmts) = do
newStmts <- mapM desugarStmt stmts
ss <- doToExp newStmts
return ss
desugarExp (HsListComp e stmts) = do
newE <- desugarExp e
newStmts <- mapM desugarStmt stmts
return (listCompToExp newE newStmts)
desugarExp (HsExpTypeSig sloc e qualType) = do
e' <- desugarExp e
newQualType <- remSynsQualType qualType
return (HsExpTypeSig sloc e' newQualType)
desugarExp e = traverseHsExp desugarExp e
desugarAlt :: (HsAlt) -> PatSM (HsAlt)
desugarAlt (HsAlt sloc pat gAlts wheres) = do
newGAlts <- desugarGAlts gAlts
newWheres <- mapM desugarDecl wheres
return (HsAlt sloc pat newGAlts (concat newWheres))
desugarGAlts :: (HsRhs) -> PatSM (HsRhs)
desugarGAlts (HsUnGuardedRhs e) = do
newE <- desugarExp e
return (HsUnGuardedRhs newE)
desugarGAlts (HsGuardedRhss gAlts) = do
newGAlts <- mapM desugarGuardedAlt gAlts
return (HsGuardedRhss newGAlts)
desugarGuardedAlt :: (HsGuardedRhs) -> PatSM (HsGuardedRhs)
desugarGuardedAlt (HsGuardedRhs sloc e1 e2) = do
newE1 <- desugarExp e1
newE2 <- desugarExp e2
return (HsGuardedRhs sloc newE1 newE2)
desugarStmt :: (HsStmt) -> PatSM (HsStmt)
desugarStmt (HsGenerator srcLoc pat e) = do
newE <- desugarExp e
return (HsGenerator srcLoc pat newE)
desugarStmt (HsQualifier e) = do
newE <- desugarExp e
return (HsQualifier newE)
desugarStmt (HsLetStmt decls) = do
newDecls <- mapM desugarDecl decls
return (HsLetStmt $ concat newDecls)
remSynsQualType :: HsQualType -> PatSM HsQualType
remSynsQualType qualtype
= case qualtype of
HsQualType cntxt t
-> do
newT <- remSynsType t
return (HsQualType cntxt newT)
--------------------------------------------------------------------------------
-- desugar the do-notation
-- flatten out do notation into an expression
-- involving ">>" and ">>="
-- TODO - THIS IS BROKEN
f_bind = nameName $ toUnqualified (func_bind sFuncNames)
f_bind_ = nameName $ toUnqualified (func_bind_ sFuncNames)
f_concatMap = nameName $ toUnqualified v_concatMap
f_map = nameName $ toUnqualified v_map
f_foldr = nameName $ toUnqualified v_foldr
f_fail = nameName $ toUnqualified v_fail
f_filter = nameName $ toUnqualified v_filter
f_and = nameName $ toUnqualified v_and
con_cons = nameName $ toUnqualified dc_Cons
doToExp :: Monad m => [HsStmt] -> m HsExp
doToExp [] = fail "doToExp: empty statements in do notation"
doToExp [HsQualifier e] = return e
doToExp [gen@(HsGenerator srcLoc _pat _e)] = fail $ "doToExp: last expression n do notation is a generator (srcLoc):" ++ show srcLoc
doToExp [letst@(HsLetStmt _decls)] = fail $ "doToExp: last expression n do notation is a let statement"
doToExp ((HsQualifier e):ss) = do
ss <- doToExp ss
return $ HsInfixApp (hsParen e) (HsVar f_bind_) (hsParen ss)
doToExp ((HsGenerator _srcLoc pat e):ss) | isLazyPat pat = do
ss <- doToExp ss
return $ HsInfixApp (hsParen e) (HsVar f_bind) (HsLambda _srcLoc [pat] ss)
doToExp ((HsGenerator srcLoc pat e):ss) = do
ss <- doToExp ss
let kase = HsCase patVar [a1, a2 ]
a1 = HsAlt srcLoc pat (HsUnGuardedRhs ss) []
a2 = HsAlt srcLoc HsPWildCard (HsUnGuardedRhs (HsApp (HsVar f_fail) (HsLit $ HsString $ show srcLoc ++ " failed pattern match in do"))) []
return $ HsInfixApp (hsParen e) (HsVar f_bind) (HsLambda srcLoc [HsPVar newPatVarName] kase) where
doToExp (HsLetStmt decls:ss) = do
ss <- doToExp ss
return $ HsLet decls ss
hsApp e es = hsParen $ foldl HsApp (hsParen e) (map hsParen es)
hsIf e a b = hsParen $ HsIf e a b
patVar = HsVar newPatVarName
listCompToExp :: HsExp -> [HsStmt] -> HsExp
listCompToExp exp ss = hsParen (f ss) where
f [] = HsList [exp]
f (gen:HsQualifier q1:HsQualifier q2:ss) = f (gen:HsQualifier (hsApp (HsVar f_and) [q1,q2]):ss)
f ((HsLetStmt ds):ss) = hsParen (HsLet ds (f ss))
f (HsQualifier e:ss) = hsParen (HsIf e (f ss) (HsList []))
f ((HsGenerator srcLoc pat e):ss) | isLazyPat pat, Just exp' <- g ss = hsParen $ HsApp (HsApp (HsVar f_map) (hsParen $ HsLambda srcLoc [pat] exp')) e
--f ((HsGenerator srcLoc pat e):[HsQualifier q]) | isHsPVar pat = hsParen $ HsApp (HsApp (HsVar f_filter) (hsParen $ HsLambda srcLoc [pat] q) ) e
f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isLazyPat pat, Just exp' <- g ss = hsApp (HsVar f_foldr) [HsLambda srcLoc [pat,HsPVar newPatVarName] $ hsIf q (hsApp (HsCon con_cons) [exp',patVar]) (HsVar newPatVarName), HsList [],e]
f ((HsGenerator srcLoc pat e):ss) | isLazyPat pat = hsParen $ HsApp (HsApp (HsVar f_concatMap) (hsParen $ HsLambda srcLoc [pat] (f ss))) e
f ((HsGenerator srcLoc pat e):HsQualifier q:ss) | isFailablePat pat || Nothing == (g ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap) (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
kase = HsCase (HsVar newPatVarName) [a1, a2 ]
a1 = HsAlt srcLoc pat (HsGuardedRhss [HsGuardedRhs srcLoc q (f ss)]) []
a2 = HsAlt srcLoc HsPWildCard (HsUnGuardedRhs $ HsList []) []
f ((HsGenerator srcLoc pat e):ss) | isFailablePat pat || Nothing == (g ss) = hsParen $ HsApp (HsApp (HsVar f_concatMap) (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
kase = HsCase (HsVar newPatVarName) [a1, a2 ]
a1 = HsAlt srcLoc pat (HsUnGuardedRhs (f ss)) []
a2 = HsAlt srcLoc HsPWildCard (HsUnGuardedRhs $ HsList []) []
f ((HsGenerator srcLoc pat e):ss) = hsParen $ HsApp (HsApp (HsVar f_map) (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
Just exp' = g ss
kase = HsCase (HsVar newPatVarName) [a1 ]
a1 = HsAlt srcLoc pat (HsUnGuardedRhs exp') []
g [] = return exp
g (HsLetStmt ds:ss) = do
e <- g ss
return (hsParen (HsLet ds e))
g _ = Nothing
-- patterns are
-- failable - may fail to match
-- refutable or strict - may bottom out
-- irrefutable or lazy - match no matter what
-- failable is a subset of refutable
isFailablePat p | isStrictPat p = f (openPat p) where
f (HsPTuple ps) = any isFailablePat ps
f (HsPUnboxedTuple ps) = any isFailablePat ps
f _ = True
isFailablePat _ = False
isLazyPat pat = not (isStrictPat pat)
isStrictPat p = f (openPat p) where
f HsPVar {} = False
f HsPWildCard = False
f (HsPIrrPat p) = False -- isStrictPat p -- TODO irrefutable patterns
f _ = True
openPat (HsPParen p) = openPat p
openPat (HsPNeg p) = openPat p
openPat (HsPAsPat _ p) = openPat p
openPat (HsPTypeSig _ p _) = openPat p
openPat (HsPInfixApp a n b) = HsPApp n [a,b]
openPat p = p