Commit ba56d20d authored by Simon Peyton Jones's avatar Simon Peyton Jones

This big patch re-factors the way in which arrow-syntax is handled

All the work was done by Dan Winograd-Cort.

The main thing is that arrow comamnds now have their own
data type HsCmd (defined in HsExpr).  Previously it was
punned with the HsExpr type, which was jolly confusing,
and made it hard to do anything arrow-specific.

To make this work, we now parameterise
  * MatchGroup
  * Match
  * GRHSs, GRHS
  * StmtLR and friends
over the "body", that is the kind of thing they
enclose.  This "body" parameter can be instantiated to
either LHsExpr or LHsCmd respectively.

Everything else is really a knock-on effect; there should
be no change (yet!) in behaviour.  But it should be a sounder
basis for fixing bugs.
parent baab1204
...@@ -585,19 +585,19 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id) ...@@ -585,19 +585,19 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') } addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty) addTickTupArg (Missing ty) = return (Missing ty)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id) addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam (MatchGroup matches ty) = do addTickMatchGroup is_lam (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ MatchGroup matches' ty return $ MatchGroup matches' ty
addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id) addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) = addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match pats opSig gRHSs' return $ Match pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id) addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
bindLocals binders $ do bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds local_binds' <- addTickHsLocalBinds local_binds
...@@ -606,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do ...@@ -606,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
where where
binders = collectLocalBinders local_binds binders = collectLocalBinders local_binds
addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id) addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr) (addTickGRHSBody isOneOfMany isLambda expr)
...@@ -624,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do ...@@ -624,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
_otherwise -> _otherwise ->
addTickLHsExprRHS expr addTickLHsExprRHS expr
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id] addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
addTickLStmts isGuard stmts = do addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ()) (stmts, _) <- addTickLStmts' isGuard stmts (return ())
return stmts return stmts
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
-> TM ([LStmt Id], a) -> TM ([ExprLStmt Id], a)
addTickLStmts' isGuard lstmts res addTickLStmts' isGuard lstmts res
= bindLocals (collectLStmtsBinders lstmts) $ = bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res ; a <- res
; return (lstmts', a) } ; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
addTickStmt _isGuard (LastStmt e ret) = do addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt liftM2 LastStmt
(addTickLHsExpr e) (addTickLHsExpr e)
...@@ -648,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do ...@@ -648,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do
(addTickLHsExprRHS e) (addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail) (addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
liftM4 ExprStmt liftM4 BodyStmt
(addTick isGuard e) (addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard') (addTickSyntaxExpr hpcSrcSpan guard')
...@@ -751,63 +751,65 @@ addTickLHsCmd (L pos c0) = do ...@@ -751,63 +751,65 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1 return $ L pos c1
addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) = addTickHsCmd (HsCmdLam matchgroup) =
liftM HsLam (addTickCmdMatchGroup matchgroup) liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsApp c e) = addTickHsCmd (HsCmdApp c e) =
liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) = addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp liftM4 OpApp
(addTickLHsExpr e1) (addTickLHsExpr e1)
(addTickLHsCmd c2) (addTickLHsCmd c2)
(return fix) (return fix)
(addTickLHsCmd c3) (addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e) -}
addTickHsCmd (HsCase e mgs) = addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
liftM2 HsCase addTickHsCmd (HsCmdCase e mgs) =
liftM2 HsCmdCase
(addTickLHsExpr e) (addTickLHsExpr e)
(addTickCmdMatchGroup mgs) (addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) = addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
liftM3 (HsIf cnd) liftM3 (HsCmdIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1) (addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2) (addTickLHsCmd c2)
(addTickLHsCmd c3) (addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) = addTickHsCmd (HsCmdLet binds c) =
bindLocals (collectLocalBinders binds) $ bindLocals (collectLocalBinders binds) $
liftM2 HsLet liftM2 HsCmdLet
(addTickHsLocalBinds binds) -- to think about: !patterns. (addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c) (addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts srcloc) addTickHsCmd (HsCmdDo stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) } ; return (HsCmdDo stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp liftM5 HsCmdArrApp
(addTickLHsExpr e1) (addTickLHsExpr e1)
(addTickLHsExpr e2) (addTickLHsExpr e2)
(return ty1) (return ty1)
(return arr_ty) (return arr_ty)
(return lr) (return lr)
addTickHsCmd (HsArrForm e fix cmdtop) = addTickHsCmd (HsCmdArrForm e fix cmdtop) =
liftM3 HsArrForm liftM3 HsCmdArrForm
(addTickLHsExpr e) (addTickLHsExpr e)
(return fix) (return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop) (mapM (liftL (addTickHsCmdTop)) cmdtop)
-- Others should never happen in a command context. -- Others should never happen in a command context.
addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id) addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup (MatchGroup matches ty) = do addTickCmdMatchGroup (MatchGroup matches ty) = do
matches' <- mapM (liftL addTickCmdMatch) matches matches' <- mapM (liftL addTickCmdMatch) matches
return $ MatchGroup matches' ty return $ MatchGroup matches' ty
addTickCmdMatch :: Match Id -> TM (Match Id) addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match pats opSig gRHSs) = addTickCmdMatch (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs gRHSs' <- addTickCmdGRHSs gRHSs
return $ Match pats opSig gRHSs' return $ Match pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id) addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs (GRHSs guarded local_binds) = do addTickCmdGRHSs (GRHSs guarded local_binds) = do
bindLocals binders $ do bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds local_binds' <- addTickHsLocalBinds local_binds
...@@ -816,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do ...@@ -816,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
where where
binders = collectLocalBinders local_binds binders = collectLocalBinders local_binds
addTickCmdGRHS :: GRHS Id -> TM (GRHS Id) addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
-- The *guards* are *not* Cmds, although the body is -- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff -- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd) addTickCmdGRHS (GRHS stmts cmd)
...@@ -824,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd) ...@@ -824,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd)
stmts (addTickLHsCmd cmd) stmts (addTickLHsCmd cmd)
; return $ GRHS stmts' expr' } ; return $ GRHS stmts' expr' }
addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id] addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
addTickLCmdStmts stmts = do addTickLCmdStmts stmts = do
(stmts, _) <- addTickLCmdStmts' stmts (return ()) (stmts, _) <- addTickLCmdStmts' stmts (return ())
return stmts return stmts
addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a) addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
addTickLCmdStmts' lstmts res addTickLCmdStmts' lstmts res
= bindLocals binders $ do = bindLocals binders $ do
lstmts' <- mapM (liftL addTickCmdStmt) lstmts lstmts' <- mapM (liftL addTickCmdStmt) lstmts
...@@ -838,7 +840,7 @@ addTickLCmdStmts' lstmts res ...@@ -838,7 +840,7 @@ addTickLCmdStmts' lstmts res
where where
binders = collectLStmtsBinders lstmts binders = collectLStmtsBinders lstmts
addTickCmdStmt :: Stmt Id -> TM (Stmt Id) addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
addTickCmdStmt (BindStmt pat c bind fail) = do addTickCmdStmt (BindStmt pat c bind fail) = do
liftM4 BindStmt liftM4 BindStmt
(addTickLPat pat) (addTickLPat pat)
...@@ -849,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do ...@@ -849,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt liftM2 LastStmt
(addTickLHsCmd c) (addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan ret) (addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do addTickCmdStmt (BodyStmt c bind' guard' ty) = do
liftM4 ExprStmt liftM4 BodyStmt
(addTickLHsCmd c) (addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard') (addTickSyntaxExpr hpcSrcSpan guard')
...@@ -1143,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") ...@@ -1143,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
\begin{code} \begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where where
matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
......
...@@ -50,31 +50,37 @@ import Outputable ...@@ -50,31 +50,37 @@ import Outputable
import Bag import Bag
import VarSet import VarSet
import SrcLoc import SrcLoc
import ListSetOps( assocDefault )
import FastString
import Data.List import Data.List
\end{code} \end{code}
\begin{code} \begin{code}
data DsCmdEnv = DsCmdEnv { data DsCmdEnv = DsCmdEnv {
meth_binds :: [CoreBind],
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
} }
mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
mkCmdEnv ids = do -- See Note [CmdSyntaxTable] in HsExpr
(meth_binds, ds_meths) <- dsSyntaxTable ids mkCmdEnv tc_meths
return $ DsCmdEnv { = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
meth_binds = meth_binds, ; return (meth_binds, DsCmdEnv {
arr_id = Var (lookupEvidence ds_meths arrAName), arr_id = Var (find_meth prs arrAName),
compose_id = Var (lookupEvidence ds_meths composeAName), compose_id = Var (find_meth prs composeAName),
first_id = Var (lookupEvidence ds_meths firstAName), first_id = Var (find_meth prs firstAName),
app_id = Var (lookupEvidence ds_meths appAName), app_id = Var (find_meth prs appAName),
choice_id = Var (lookupEvidence ds_meths choiceAName), choice_id = Var (find_meth prs choiceAName),
loop_id = Var (lookupEvidence ds_meths loopAName) loop_id = Var (find_meth prs loopAName)
} }) }
where
bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr mk_bind (std_name, expr)
bindCmdEnv ids body = foldr Let body (meth_binds ids) = do { rhs <- dsExpr expr
; id <- newSysLocalDs (exprType rhs)
; return (NonRec id rhs, (std_name, id)) }
find_meth prs std_name
= assocDefault (mk_panic std_name) prs std_name
mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)
-- arr :: forall b c. (b -> c) -> a b c -- arr :: forall b c. (b -> c) -> a b c
do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
...@@ -245,7 +251,7 @@ dsProcExpr ...@@ -245,7 +251,7 @@ dsProcExpr
-> LHsCmdTop Id -> LHsCmdTop Id
-> DsM CoreExpr -> DsM CoreExpr
dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
meth_ids <- mkCmdEnv ids (meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat) let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
let env_ty = mkBigCoreVarTupTy env_ids let env_ty = mkBigCoreVarTupTy env_ids
...@@ -256,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do ...@@ -256,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
(Lam var match_code) (Lam var match_code)
core_cmd core_cmd
return (bindCmdEnv meth_ids proc_code) return (mkLets meth_binds proc_code)
dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c)
\end{code} \end{code}
...@@ -289,7 +295,7 @@ dsCmd :: DsCmdEnv -- arrow combinators ...@@ -289,7 +295,7 @@ dsCmd :: DsCmdEnv -- arrow combinators
-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f -- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
dsCmd ids local_vars stack res_ty dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _) (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
env_ids = do env_ids = do
let let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
...@@ -315,7 +321,7 @@ dsCmd ids local_vars stack res_ty ...@@ -315,7 +321,7 @@ dsCmd ids local_vars stack res_ty
-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app -- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
dsCmd ids local_vars stack res_ty dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _) (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
env_ids = do env_ids = do
let let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
...@@ -344,7 +350,7 @@ dsCmd ids local_vars stack res_ty ...@@ -344,7 +350,7 @@ dsCmd ids local_vars stack res_ty
-- --
-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
core_arg <- dsLExpr arg core_arg <- dsLExpr arg
let let
arg_ty = exprType core_arg arg_ty = exprType core_arg
...@@ -375,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do ...@@ -375,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars stack res_ty dsCmd ids local_vars stack res_ty
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) (HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
env_ids = do env_ids = do
let let
pat_vars = mkVarSet (collectPatsBinders pats) pat_vars = mkVarSet (collectPatsBinders pats)
...@@ -402,7 +408,7 @@ dsCmd ids local_vars stack res_ty ...@@ -402,7 +408,7 @@ dsCmd ids local_vars stack res_ty
return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body, return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
free_vars `minusVarSet` pat_vars) free_vars `minusVarSet` pat_vars)
dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids
= dsLCmd ids local_vars stack res_ty cmd env_ids = dsLCmd ids local_vars stack res_ty cmd env_ids
-- A, xs |- e :: Bool -- A, xs |- e :: Bool
...@@ -415,7 +421,7 @@ dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids ...@@ -415,7 +421,7 @@ dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
-- c1 ||| c2 -- c1 ||| c2
dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd) dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
env_ids = do env_ids = do
core_cond <- dsLExpr cond core_cond <- dsLExpr cond
(core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
...@@ -476,7 +482,7 @@ case bodies, containing the following fields: ...@@ -476,7 +482,7 @@ case bodies, containing the following fields:
bodies with |||. bodies with |||.
\begin{code} \begin{code}
dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
env_ids = do env_ids = do
stack_ids <- mapM newSysLocalDs stack stack_ids <- mapM newSysLocalDs stack
...@@ -535,7 +541,7 @@ dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) ...@@ -535,7 +541,7 @@ dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
-- --
-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c -- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do
let let
defined_vars = mkVarSet (collectLocalBinders binds) defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars local_vars' = defined_vars `unionVarSet` local_vars
...@@ -554,7 +560,7 @@ dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do ...@@ -554,7 +560,7 @@ dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
core_body, core_body,
exprFreeIds core_binds `intersectVarSet` local_vars) exprFreeIds core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids dsCmd ids local_vars [] res_ty (HsCmdDo stmts _) env_ids
= dsCmdDo ids local_vars res_ty stmts env_ids = dsCmdDo ids local_vars res_ty stmts env_ids
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
...@@ -562,16 +568,16 @@ dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids ...@@ -562,16 +568,16 @@ dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
-- ----------------------------------- -- -----------------------------------
-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn -- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do dsCmd _ids local_vars _stack _res_ty (HsCmdArrForm op _ args) env_ids = do
let env_ty = mkBigCoreVarTupTy env_ids let env_ty = mkBigCoreVarTupTy env_ids
core_op <- dsLExpr op core_op <- dsLExpr op
(core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
return (mkApps (App core_op (Type env_ty)) core_args, return (mkApps (App core_op (Type env_ty)) core_args,
unionVarSets fv_sets) unionVarSets fv_sets)
dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do --dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do
(expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids -- (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids
return (Tick tickish expr1, id_set) -- return (Tick tickish expr1, id_set)
dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
...@@ -586,7 +592,7 @@ dsTrimCmdArg ...@@ -586,7 +592,7 @@ dsTrimCmdArg
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- subset of local vars that occur free IdSet) -- subset of local vars that occur free
dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
meth_ids <- mkCmdEnv ids (meth_binds, meth_ids) <- mkCmdEnv ids
(core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd
stack_ids <- mapM newSysLocalDs stack stack_ids <- mapM newSysLocalDs stack
trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
...@@ -595,7 +601,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do ...@@ -595,7 +601,7 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
in_ty' = envStackType env_ids' stack in_ty' = envStackType env_ids' stack
arg_code = if env_ids' == env_ids then core_cmd else arg_code = if env_ids' == env_ids then core_cmd else
do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
return (bindCmdEnv meth_ids arg_code, free_vars) return (mkLets meth_binds arg_code, free_vars)
-- Given A | xs |- c :: [ts] t, builds c with xs fed back. -- Given A | xs |- c :: [ts] t, builds c with xs fed back.
-- Typically needs to be prefixed with arr (\p -> ((xs)*ts)) -- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
...@@ -638,7 +644,7 @@ Translation of command judgements of the form ...@@ -638,7 +644,7 @@ Translation of command judgements of the form
dsCmdDo :: DsCmdEnv -- arrow combinators dsCmdDo :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> Type -- return type of the statement -> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar -> [CmdLStmt Id] -- statements to desugar
-> [Id] -- list of vars in the input to this statement -> [Id] -- list of vars in the input to this statement
-- This is typically fed back, -- This is typically fed back,
-- so don't pull on it too early -- so don't pull on it too early
...@@ -673,7 +679,7 @@ A statement maps one local environment to another, and is represented ...@@ -673,7 +679,7 @@ A statement maps one local environment to another, and is represented
as an arrow from one tuple type to another. A statement sequence is as an arrow from one tuple type to another. A statement sequence is
translated to a composition of such arrows. translated to a composition of such arrows.
\begin{code} \begin{code}
dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id] dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]
-> DsM (CoreExpr, IdSet) -> DsM (CoreExpr, IdSet)
dsCmdLStmt ids local_vars out_ids cmd env_ids dsCmdLStmt ids local_vars out_ids cmd env_ids
= dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
...@@ -682,7 +688,7 @@ dsCmdStmt ...@@ -682,7 +688,7 @@ dsCmdStmt
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [Id] -- list of vars in the output of this statement -> [Id] -- list of vars in the output of this statement
-> Stmt Id -- statement to desugar -> CmdStmt Id -- statement to desugar
-> [Id] -- list of vars in the input to this statement -> [Id] -- list of vars in the input to this statement
-- This is typically fed back, -- This is typically fed back,
-- so don't pull on it too early -- so don't pull on it too early
...@@ -697,7 +703,7 @@ dsCmdStmt ...@@ -697,7 +703,7 @@ dsCmdStmt
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss -- arr snd >>> ss
dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
core_mux <- matchEnvStack env_ids [] core_mux <- matchEnvStack env_ids []
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
...@@ -860,7 +866,7 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) ...@@ -860,7 +866,7 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
dsRecCmd dsRecCmd
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [LStmt Id] -- list of statements inside the RecCmd -> [CmdLStmt Id] -- list of statements inside the RecCmd
-> [Id] -- list of vars defined here and used later -> [Id] -- list of vars defined here and used later
-> [HsExpr Id] -- expressions corresponding to later_ids -> [HsExpr Id] -- expressions corresponding to later_ids
-> [Id] -- list of vars fed back through the loop -> [Id] -- list of vars fed back through the loop
...@@ -938,7 +944,7 @@ dsfixCmdStmts ...@@ -938,7 +944,7 @@ dsfixCmdStmts
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [Id] -- output vars of these statements -> [Id] -- output vars of these statements
-> [LStmt Id] -- statements to desugar -> [CmdLStmt Id] -- statements to desugar
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet, -- subset of local vars that occur free IdSet, -- subset of local vars that occur free
[Id]) -- same local vars as a list [Id]) -- same local vars as a list
...@@ -950,7 +956,7 @@ dsCmdStmts ...@@ -950,7 +956,7 @@ dsCmdStmts
:: DsCmdEnv -- arrow combinators :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement -> IdSet -- set of local vars available to this statement
-> [Id] -- output vars of these statements -> [Id] -- output vars of these statements
-> [LStmt Id] -- statements to desugar -> [CmdLStmt Id] -- statements to desugar
-> [Id] -- list of vars in the input to these statements -> [Id] -- list of vars in the input to these statements
-> DsM (CoreExpr, -- desugared expression -> DsM (CoreExpr, -- desugared expression
IdSet) -- subset of local vars that occur free IdSet) -- subset of local vars that occur free
...@@ -995,28 +1001,28 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" ...@@ -995,28 +1001,28 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
List of leaf expressions, with set of variables bound in each List of leaf expressions, with set of variables bound in each
\begin{code} \begin{code}
leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)] leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let = let