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)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
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
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
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) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda 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
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -606,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
where
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
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
......@@ -624,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
_otherwise ->
addTickLHsExprRHS expr
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ())
return stmts
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
-> TM ([ExprLStmt Id], a)
addTickLStmts' isGuard lstmts res
= bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; 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
liftM2 LastStmt
(addTickLHsExpr e)
......@@ -648,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do
(addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
liftM4 ExprStmt
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
liftM4 BodyStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
......@@ -751,63 +751,65 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
liftM HsLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsApp c e) =
liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
addTickHsCmd (HsCmdLam matchgroup) =
liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp
(addTickLHsExpr e1)
(addTickLHsCmd c2)
(return fix)
(addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
addTickHsCmd (HsCase e mgs) =
liftM2 HsCase
-}
addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
addTickHsCmd (HsCmdCase e mgs) =
liftM2 HsCmdCase
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) =
liftM3 (HsIf cnd)
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
liftM3 (HsCmdIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) =
addTickHsCmd (HsCmdLet binds c) =
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
liftM2 HsCmdLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts srcloc)
addTickHsCmd (HsCmdDo stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) }
; return (HsCmdDo stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsCmdArrApp
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
(return arr_ty)
(return lr)
addTickHsCmd (HsArrForm e fix cmdtop) =
liftM3 HsArrForm
addTickHsCmd (HsCmdArrForm e fix cmdtop) =
liftM3 HsCmdArrForm
(addTickLHsExpr e)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-- 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
matches' <- mapM (liftL addTickCmdMatch) matches
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) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs 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
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -816,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
where
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
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
......@@ -824,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd)
stmts (addTickLHsCmd cmd)
; return $ GRHS stmts' expr' }
addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
addTickLCmdStmts stmts = do
(stmts, _) <- addTickLCmdStmts' stmts (return ())
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
= bindLocals binders $ do
lstmts' <- mapM (liftL addTickCmdStmt) lstmts
......@@ -838,7 +840,7 @@ addTickLCmdStmts' lstmts res
where
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
liftM4 BindStmt
(addTickLPat pat)
......@@ -849,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
liftM4 ExprStmt
addTickCmdStmt (BodyStmt c bind' guard' ty) = do
liftM4 BodyStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
......@@ -1143,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
\begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
......
This diff is collapsed.
......@@ -324,12 +324,12 @@ dsExpr (HsLet binds body) = do
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr stmts _) = dsDo stmts
dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr stmts _) = dsDo stmts
dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts
dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
......@@ -719,7 +719,7 @@ handled in DsListComp). Basically does the translation given in the
Haskell 98 report:
\begin{code}
dsDo :: [LStmt Id] -> DsM CoreExpr
dsDo :: [ExprLStmt Id] -> DsM CoreExpr
dsDo stmts
= goL stmts
where
......@@ -730,7 +730,7 @@ dsDo stmts
= ASSERT( null stmts ) dsLExpr body
-- The 'return' op isn't used for 'do' expressions
go _ (ExprStmt rhs then_expr _ _) stmts
go _ (BodyStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs (exprType rhs2)
; then_expr2 <- dsExpr then_expr
......
......@@ -40,7 +40,7 @@ producing an expression with a runtime error in the corner if
necessary. The type argument gives the type of the @ei@.
\begin{code}
dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr
dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr
dsGuarded grhss rhs_ty = do
match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty
......@@ -52,7 +52,7 @@ In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from
-> GRHSs Id -- Guarded RHSs
-> GRHSs Id (LHsExpr Id) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
......@@ -66,7 +66,7 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
--
return match_result2
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
= matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
\end{code}
......@@ -79,31 +79,31 @@ dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
%************************************************************************
\begin{code}
matchGuards :: [Stmt Id] -- Guard
-> HsStmtContext Name -- Context
-> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
matchGuards :: [GuardStmt Id] -- Guard
-> HsStmtContext Name -- Context
-> LHsExpr Id -- RHS
-> Type -- Type of RHS of guard
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what an ExprStmt means
-- See comments with HsExpr.Stmt re what a BodyStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
matchGuards [] _ rhs _
= do { core_rhs <- dsLExpr rhs
; return (cantFailMatchResult core_rhs) }
-- ExprStmts must be guards
-- BodyStmts must be guards
-- Turn an "otherwise" guard is a no-op. This ensures that
-- you don't get a "non-exhaustive eqns" message when the guards
-- finish in "otherwise".
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
......
......@@ -43,7 +43,7 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject).
There will be at least one ``qualifier'' in the input.
\begin{code}
dsListComp :: [LStmt Id]
dsListComp :: [ExprLStmt Id]
-> Type -- Type of entire list
-> DsM CoreExpr
dsListComp lquals res_ty = do
......@@ -89,7 +89,7 @@ dsInnerListComp (ParStmtBlock stmts bndrs _)
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)
dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
, trS_by = by, trS_using = using }) = do
let (from_bndrs, to_bndrs) = unzip binderMap
......@@ -204,7 +204,7 @@ with the Unboxed variety.
\begin{code}
deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr
deListComp [] _ = panic "deListComp"
......@@ -215,7 +215,7 @@ deListComp (LastStmt body _ : quals) list
; return (mkConsExpr (exprType core_body) core_body list) }
-- Non-last: must be a guard
deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above
deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
core_guard <- dsLExpr guard
core_rest <- deListComp quals list
return (mkIfThenElse core_guard core_rest list)
......@@ -256,7 +256,7 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
\begin{code}
deBindComp :: OutPat Id
-> CoreExpr
-> [Stmt Id]
-> [ExprStmt Id]
-> CoreExpr
-> DsM (Expr Id)
deBindComp pat core_list1 quals core_list2 = do
......@@ -309,8 +309,8 @@ TE[ e | p <- l , q ] c n = let
\end{verbatim}
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
dfListComp :: Id -> Id -- 'c' and 'n'
-> [ExprStmt Id] -- the rest of the qual's
-> DsM CoreExpr
dfListComp _ _ [] = panic "dfListComp"
......@@ -321,7 +321,7 @@ dfListComp c_id n_id (LastStmt body _ : quals)
; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do
dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
core_guard <- dsLExpr guard
core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
......@@ -347,8 +347,8 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [Stmt Id] -- the rest of the qual's
-> (LPat Id, CoreExpr)
-> [ExprStmt Id] -- the rest of the qual's
-> DsM CoreExpr
dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
......@@ -469,7 +469,7 @@ mkUnzipBind _ elt_tys
--
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
dsPArrComp :: [ExprStmt Id]
-> DsM CoreExpr
-- Special case for parallel comprehension
......@@ -505,7 +505,7 @@ dsPArrComp qs = do -- no ParStmt in `qs'
-- the work horse
--
dePArrComp :: [Stmt Id]
dePArrComp :: [ExprStmt Id]
-> LPat Id -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
......@@ -524,7 +524,7 @@ dePArrComp (LastStmt e' _ : quals) pa cea
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
filterP <- dsDPHBuiltin filterPVar
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
......@@ -601,7 +601,7 @@ dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
-- where
-- {x_1, ..., x_n} = DV (qs)
--
dePArrParComp :: [ParStmtBlock Id Id] -> [Stmt Id] -> DsM CoreExpr
dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr
dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
dePArrComp quals pQss ceQss
......@@ -663,15 +663,15 @@ Translation for monad comprehensions
\begin{code}
-- Entry point for monad comprehension desugaring
dsMonadComp :: [LStmt Id] -> DsM CoreExpr
dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr
dsMonadComp stmts = dsMcStmts stmts
dsMcStmts :: [LStmt Id] -> DsM CoreExpr
dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr
dsMcStmts [] = panic "dsMcStmts"
dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
---------------
dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
dsMcStmt (LastStmt body ret_op) stmts
= ASSERT( null stmts )
......@@ -693,7 +693,7 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
--
-- [ .. | exp, stmts ]
--
dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts
dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
= do { exp' <- dsLExpr exp
; guard_exp' <- dsExpr guard_exp
; then_exp' <- dsExpr then_exp
......@@ -801,7 +801,7 @@ dsMcBindStmt :: LPat Id
-> CoreExpr -- ^ the desugared rhs of the bind statement
-> SyntaxExpr Id
-> SyntaxExpr Id
-> [LStmt Id]
-> [ExprLStmt Id]
-> DsM CoreExpr
dsMcBindStmt pat rhs' bind_op fail_op stmts
= do { body <- dsMcStmts stmts
......@@ -836,7 +836,7 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
-- returns the desugaring of
-- [ (a,b,c) | quals ]
dsInnerMonadComp :: [LStmt Id]
dsInnerMonadComp :: [ExprLStmt Id]
-> [Id] -- Return a tuple of these variables
-> HsExpr Id -- The monomorphic "return" operator
-> DsM CoreExpr
......
......@@ -922,7 +922,7 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
-- FIXME: I haven't got the types here right yet
repE e@(HsDo ctxt sts _)
| case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
wrapGenSyms ss e' }
......@@ -980,7 +980,7 @@ repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
......@@ -992,7 +992,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
; wrapGenSyms (ss1++ss2) match }}}
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
......@@ -1003,23 +1003,23 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
; clause <- repClause ps1 gs ds
; wrapGenSyms (ss1++ss2) clause }}}
repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)
repGuards [L _ (GRHS [] e)]
= do { a <- repLE e
; repNormal a }
repGuards alts
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; body <- repGuarded (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) body }
repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs))
= do { guarded <- repLNormalGE guard rhs
= do {a <- repLE e; repNormal a }
repGuards other
= do { zs <- mapM repLGRHS other
; let (xs, ys) = unzip zs
; gd <- repGuarded (nonEmptyCoreList ys)
; wrapGenSyms (concat xs) gd }
repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
= do { guarded <- repLNormalGE e1 e2
; return ([], guarded) }
repLGRHS (L _ (GRHS stmts rhs))
= do { (gs, stmts') <- repLSts stmts
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList stmts') rhs'
repLGRHS (L _ (GRHS ss rhs))
= do { (gs, ss') <- repLSts ss
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
; return (gs, guarded) }
repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
......@@ -1055,10 +1055,10 @@ repFields (HsRecFields { rec_flds = flds })
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.
repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
repSts (BindStmt p e _ _ : ss) =
do { e2 <- repLE e
; ss1 <- mkGenSyms (collectPatBinders p)
......@@ -1072,7 +1072,7 @@ repSts (LetStmt bs : ss) =
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
repSts (ExprStmt e _ _ _ : ss) =
repSts (BodyStmt e _ _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
......@@ -1190,7 +1190,7 @@ rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
......
......@@ -39,8 +39,6 @@ module DsUtils (
mkSelectorBinds,
dsSyntaxTable, lookupEvidence,
selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
mkOptTickBox, mkBinaryTickBox
) where
......@@ -48,7 +46,6 @@ module DsUtils (
#include "HsVersions.h"
import {-# SOURCE #-} Match ( matchSimply )
import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
import TcHsSyn
......@@ -60,7 +57,6 @@ import CoreUtils
import MkCore
import MkId
import Id
import Name
import Literal
import TyCon
import DataCon
......@@ -75,7 +71,6 @@ import PrelNames
import Outputable
import SrcLoc
import Util
import ListSetOps
import DynFlags
import FastString
......@@ -83,36 +78,6 @@ import Control.Monad ( zipWithM )
\end{code}
%************************************************************************
%* *
Rebindable syntax
%* *
%************************************************************************
\begin{code}
dsSyntaxTable :: SyntaxTable Id
-> DsM ([CoreBind], -- Auxiliary bindings
[(Name,Id)]) -- Maps the standard name to its value
dsSyntaxTable rebound_ids = do
(binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids
return (concat binds_s, prs)
where
-- The cheapo special case can happen when we
-- make an intermediate HsDo when desugaring a RecStmt
mk_bind (std_name, HsVar id) = return ([], (std_name, id))
mk_bind (std_name, expr) = do
rhs <- dsExpr expr
id <- newSysLocalDs (exprType rhs)
return ([NonRec id rhs], (std_name, id))
lookupEvidence :: [(Name, Id)] -> Name -> Id
lookupEvidence prs std_name
= assocDefault (mk_panic std_name) prs std_name
where
mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
\end{code}
%************************************************************************
%* *
\subsection{ Selecting match variables}
......
......@@ -664,9 +664,9 @@ Call @match@ with all of this information!
\end{enumerate}
\begin{code}
matchWrapper :: HsMatchContext Name -- For shadowing warning messages
-> MatchGroup Id -- Matches being desugared
-> DsM ([Id], CoreExpr) -- Results
matchWrapper :: HsMatchContext Name -- For shadowing warning messages
-> MatchGroup Id (LHsExpr Id) -- Matches being desugared
-> DsM ([Id], CoreExpr) -- Results
\end{code}
There is one small problem with the Lambda Patterns, when somebody
......
......@@ -4,7 +4,7 @@ import Var ( Id )
import TcType ( Type )
import DsMonad ( DsM, EquationInfo, MatchResult )
import CoreSyn ( CoreExpr )
import HsSyn ( LPat, HsMatchContext, MatchGroup )
import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr )
import Name ( Name )
match :: [Id]
......@@ -14,7 +14,7 @@ match :: [Id]
matchWrapper
:: HsMatchContext Name
-> MatchGroup Id
-> MatchGroup Id (LHsExpr Id)
-> DsM ([Id], CoreExpr)
matchSimply
......
......@@ -488,7 +488,7 @@ cvtLocalDecs doc ds
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause (Clause ps body wheres)
= do { ps' <- cvtPats ps
; g' <- cvtGuard body
......@@ -676,7 +676,7 @@ cvtHsDo do_or_lc stmts
; let Just (stmts'', last') = snocView stmts'
; last'' <- case last' of
L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
......@@ -685,11 +685,11 @@ cvtHsDo do_or_lc stmts
, nest 2 $ Outputable.ppr stmt
, ptext (sLit "(It should be an expression.)") ]
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
cvtStmts = mapM cvtStmt
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
; returnL $ LetStmt ds' }
......@@ -697,20 +697,20 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtMatch (TH.Match p body decs)
= do { p' <- cvtPat p
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
; g' <- returnL $ mkExprStmt ge'
; g' <- returnL $ mkBodyStmt ge'
; returnL $ GRHS [g'] rhs' }
cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
; returnL $ GRHS gs' rhs' }
......
......@@ -18,7 +18,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
module HsBinds where
import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
MatchGroup, pprFunBind,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
......@@ -106,7 +106,7 @@ data HsBindLR idL idR
fun_infix :: Bool, -- ^ True => infix declaration
fun_matches :: MatchGroup idR, -- ^ The payload
fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
-- the Id. Example:
......@@ -131,7 +131,7 @@ data HsBindLR idL idR
| PatBind { -- The pattern is never a simple variable;
-- That case is done by FunBind
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR,
pat_rhs :: GRHSs idR (LHsExpr idR),
pat_rhs_ty :: PostTcType, -- Type of the GRHSs
bind_fvs :: NameSet, -- See Note [Bind free vars]