diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-10-03 11:16:22 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-10-03 11:16:22 +0100 |
| commit | ba56d20d767f0425f6f7515fa9c78b186589b896 (patch) | |
| tree | b46e886476bd31b63b6727b6c8d978e2254dce53 | |
| parent | baab12043477828488b351aa595f2aaca78453af (diff) | |
| download | haskell-ba56d20d767f0425f6f7515fa9c78b186589b896.tar.gz | |
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.
32 files changed, 1179 insertions, 908 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index d92f2d1dd7..551355cb62 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 1da6a77976..66e29f8348 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -50,31 +50,37 @@ import Outputable import Bag import VarSet import SrcLoc - +import ListSetOps( assocDefault ) +import FastString import Data.List \end{code} \begin{code} data DsCmdEnv = DsCmdEnv { - meth_binds :: [CoreBind], arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr } -mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv -mkCmdEnv ids = do - (meth_binds, ds_meths) <- dsSyntaxTable ids - return $ DsCmdEnv { - meth_binds = meth_binds, - arr_id = Var (lookupEvidence ds_meths arrAName), - compose_id = Var (lookupEvidence ds_meths composeAName), - first_id = Var (lookupEvidence ds_meths firstAName), - app_id = Var (lookupEvidence ds_meths appAName), - choice_id = Var (lookupEvidence ds_meths choiceAName), - loop_id = Var (lookupEvidence ds_meths loopAName) - } - -bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr -bindCmdEnv ids body = foldr Let body (meth_binds ids) +mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) +-- See Note [CmdSyntaxTable] in HsExpr +mkCmdEnv tc_meths + = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + ; return (meth_binds, DsCmdEnv { + arr_id = Var (find_meth prs arrAName), + compose_id = Var (find_meth prs composeAName), + first_id = Var (find_meth prs firstAName), + app_id = Var (find_meth prs appAName), + choice_id = Var (find_meth prs choiceAName), + loop_id = Var (find_meth prs loopAName) + }) } + where + mk_bind (std_name, expr) + = 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 do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr @@ -245,7 +251,7 @@ dsProcExpr -> LHsCmdTop Id -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do - meth_ids <- mkCmdEnv ids + (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd let env_ty = mkBigCoreVarTupTy env_ids @@ -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 (Lam var match_code) core_cmd - return (bindCmdEnv meth_ids proc_code) + return (mkLets meth_binds proc_code) dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) \end{code} @@ -289,7 +295,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f dsCmd ids local_vars stack res_ty - (HsArrApp arrow arg arrow_ty HsFirstOrderApp _) + (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -315,7 +321,7 @@ dsCmd ids local_vars stack res_ty -- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app dsCmd ids local_vars stack res_ty - (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) + (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _) env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty @@ -344,7 +350,7 @@ dsCmd ids local_vars stack res_ty -- -- ---> 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 let arg_ty = exprType core_arg @@ -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 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 let pat_vars = mkVarSet (collectPatsBinders pats) @@ -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, 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 -- A, xs |- e :: Bool @@ -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)) >>> -- 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 core_cond <- dsLExpr cond (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: bodies with |||. \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 stack_ids <- mapM newSysLocalDs stack @@ -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 -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 defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -554,7 +560,7 @@ dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do core_body, 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 -- 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 -- ----------------------------------- -- 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 core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) -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 - return (Tick tickish expr1, id_set) +--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 +-- return (Tick tickish expr1, id_set) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) @@ -586,7 +592,7 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free 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 stack_ids <- mapM newSysLocalDs stack 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 in_ty' = envStackType env_ids' stack 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 - 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. -- Typically needs to be prefixed with arr (\p -> ((xs)*ts)) @@ -638,7 +644,7 @@ Translation of command judgements of the form dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this 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 -- This is typically fed back, -- so don't pull on it too early @@ -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 translated to a composition of such arrows. \begin{code} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id] +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] -> DsM (CoreExpr, IdSet) dsCmdLStmt ids local_vars out_ids cmd env_ids = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids @@ -682,7 +688,7 @@ dsCmdStmt :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to 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 -- This is typically fed back, -- so don't pull on it too early @@ -697,7 +703,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- 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_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -860,7 +866,7 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) dsRecCmd :: DsCmdEnv -- arrow combinators -> 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 -> [HsExpr Id] -- expressions corresponding to later_ids -> [Id] -- list of vars fed back through the loop @@ -938,7 +944,7 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [CmdLStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression IdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list @@ -950,7 +956,7 @@ dsCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [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 -> DsM (CoreExpr, -- desugared expression IdSet) -- subset of local vars that occur free @@ -995,28 +1001,28 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" List of leaf expressions, with set of variables bound in each \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))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` mkVarSet (collectLocalBinders binds) in - [(expr, + [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | L _ (GRHS stmts expr) <- grhss] + | L _ (GRHS stmts body) <- grhss] \end{code} Replace the leaf commands in a match \begin{code} replaceLeavesMatch - :: Type -- new result type - -> [LHsExpr Id] -- replacement leaf expressions of that type - -> LMatch Id -- the matches of a case command - -> ([LHsExpr Id],-- remaining leaf expressions - LMatch Id) -- updated match + :: Type -- new result type + -> [Located (body' Id)] -- replacement leaf expressions of that type + -> LMatch Id (Located (body Id)) -- the matches of a case command + -> ([Located (body' Id)], -- remaining leaf expressions + LMatch Id (Located (body' Id))) -- updated match replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss @@ -1024,10 +1030,10 @@ replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) (leaves', L loc (Match pat mt (GRHSs grhss' binds))) replaceLeavesGRHS - :: [LHsExpr Id] -- replacement leaf expressions of that type - -> LGRHS Id -- rhss of a case command - -> ([LHsExpr Id],-- remaining leaf expressions - LGRHS Id) -- updated GRHS + :: [Located (body' Id)] -- replacement leaf expressions of that type + -> LGRHS Id (Located (body Id)) -- rhss of a case command + -> ([Located (body' Id)], -- remaining leaf expressions + LGRHS Id (Located (body' Id))) -- updated GRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" @@ -1113,16 +1119,16 @@ add_ev_bndr (EvBind b _) bs | isId b = b:bs | otherwise = bs -- A worry: what about coercion variable binders?? -collectLStmtsBinders :: [LStmt Id] -> [Id] +collectLStmtsBinders :: [LStmt Id body] -> [Id] collectLStmtsBinders = concatMap collectLStmtBinders -collectLStmtBinders :: LStmt Id -> [Id] +collectLStmtBinders :: LStmt Id body -> [Id] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: Stmt Id -> [Id] +collectStmtBinders :: Stmt Id body -> [Id] collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss] diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index a7501594e6..88df581844 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -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 diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs index 9e84e46e9f..1af39d1a0f 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.lhs @@ -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) diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index efe14f2678..b590a92057 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 15dab47ca1..d9e851ae62 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 0053484b13..0b14946793 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -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 @@ -85,36 +80,6 @@ import Control.Monad ( zipWithM ) %************************************************************************ %* * - 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} %* * %************************************************************************ diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index adb9099c14..c650e103a8 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -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 diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot index d10cda961e..66ecc8aba6 100644 --- a/compiler/deSugar/Match.lhs-boot +++ b/compiler/deSugar/Match.lhs-boot @@ -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 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 57dadc5475..b19f04f033 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -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' } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 26097df6c4..f15ef5d3cc 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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] pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)]) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 719b080492..ef0263d05d 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -82,27 +82,49 @@ noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr")) -type SyntaxTable id = [(Name, SyntaxExpr id)] --- ^ Currently used only for 'CmdTop' (sigh) --- --- * Before the renamer, this list is 'noSyntaxTable' --- --- * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ --- For example, for the 'return' op of a monad --- --- * normal case: @(GHC.Base.return, HsVar GHC.Base.return)@ --- --- * with rebindable syntax: @(GHC.Base.return, return_22)@ --- where @return_22@ is whatever @return@ is in scope --- --- * After the type checker, it takes the form @[(std_name, <expression>)]@ --- where @<expression>@ is the evidence for the method +type CmdSyntaxTable id = [(Name, SyntaxExpr id)] +-- See Note [CmdSyntaxTable] -noSyntaxTable :: SyntaxTable id +noSyntaxTable :: CmdSyntaxTable id noSyntaxTable = [] +\end{code} +Note [CmdSyntaxtable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is 'noSyntaxTable' + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, <expression>)] + where <expression> is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious RnExpr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) -------------------------- + +\begin{code} -- | A Haskell expression. data HsExpr id = HsVar id -- ^ variable @@ -111,9 +133,9 @@ data HsExpr id | HsLit HsLit -- ^ Simple (non-overloaded) literals - | HsLam (MatchGroup id) -- Currently always a single match + | HsLam (MatchGroup id (LHsExpr id)) -- Currently always a single match - | HsLamCase PostTcType (MatchGroup id) -- Lambda-case + | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- Lambda-case | HsApp (LHsExpr id) (LHsExpr id) -- Application @@ -143,7 +165,7 @@ data HsExpr id Boxity | HsCase (LHsExpr id) - (MatchGroup id) + (MatchGroup id (LHsExpr id)) | HsIf (Maybe (SyntaxExpr id)) -- cond function -- Nothing => use the built-in 'if' @@ -152,7 +174,7 @@ data HsExpr id (LHsExpr id) -- then part (LHsExpr id) -- else part - | HsMultiIf PostTcType [LGRHS id] -- Multi-way if + | HsMultiIf PostTcType [LGRHS id (LHsExpr id)] -- Multi-way if | HsLet (HsLocalBinds id) -- let(rec) (LHsExpr id) @@ -160,7 +182,7 @@ data HsExpr id | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant - [LStmt id] -- "do":one or more stmts + [ExprLStmt id] -- "do":one or more stmts PostTcType -- Type of the whole expression | ExplicitList -- syntactic list @@ -238,7 +260,8 @@ data HsExpr id --------------------------------------- -- The following are commands, not expressions proper - + -- They are only used in the parsing stage and are removed + -- immediately in parser.RdrHsSyn.checkCommand | HsArrApp -- Arrow tail, or arrow application (f -< arg) (LHsExpr id) -- arrow expression, f (LHsExpr id) -- input expression, arg @@ -256,7 +279,6 @@ data HsExpr id -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands - --------------------------------------- -- Haskell program coverage (Hpc) Support @@ -558,19 +580,11 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) - = hang (ptext (sLit "(|") <> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) + = hang (ptext (sLit "(|") <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)")) ppr_expr HsHole = ptext $ sLit "_" -pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc -pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _) - = ppr_lexpr cmd -pprCmdArg (HsCmdTop cmd _ _ _) - = parens (ppr_lexpr cmd) - -instance OutputableBndr id => Outputable (HsCmdTop id) where - ppr = pprCmdArg \end{code} HsSyn records exactly where the user put parens, with HsPar. @@ -637,52 +651,52 @@ isAtomicHsExpr _ = False We re-use HsExpr to represent these. \begin{code} -type HsCmd id = HsExpr id - -type LHsCmd id = LHsExpr id +type LHsCmd id = Located (HsCmd id) -data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp - deriving (Data, Typeable) -\end{code} - -The legal constructors for commands are: - - = HsArrApp ... -- as above +data HsCmd id + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + PostTcType -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) - | HsArrForm ... -- as above + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + | HsCmdApp (LHsCmd id) + (LHsExpr id) - | HsApp (HsCmd id) - (HsExpr id) + | HsCmdLam (MatchGroup id (LHsCmd id)) -- kappa - | HsLam (Match id) -- kappa + | HsCmdPar (LHsCmd id) -- parenthesised command - -- the renamer turns this one into HsArrForm - | OpApp (HsExpr id) -- left operand - (HsCmd id) -- operator - Fixity -- Renamer adds fixity; bottom until then - (HsCmd id) -- right operand + | HsCmdCase (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - | HsPar (HsCmd id) -- parenthesised command + | HsCmdIf (Maybe (SyntaxExpr id)) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part - | HsCase (HsExpr id) - [Match id] -- bodies are HsCmd's - SrcLoc + | HsCmdLet (HsLocalBinds id) -- let(rec) + (LHsCmd id) - | HsIf (Maybe (SyntaxExpr id)) -- cond function - (HsExpr id) -- predicate - (HsCmd id) -- then part - (HsCmd id) -- else part - SrcLoc + | HsCmdDo [CmdLStmt id] + PostTcType -- Type of the whole expression + deriving (Data, Typeable) - | HsLet (HsLocalBinds id) -- let(rec) - (HsCmd id) +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving (Data, Typeable) - | HsDo (HsStmtContext Name) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - [Stmt id] -- HsExpr's are really HsCmd's - PostTcType -- Type of the whole expression - SrcLoc +\end{code} Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an @@ -693,13 +707,102 @@ type LHsCmdTop id = Located (HsCmdTop id) data HsCmdTop id = HsCmdTop (LHsCmd id) - [PostTcType] -- types of inputs on the command's stack - PostTcType -- return type of the command - (SyntaxTable id) -- after type checking: - -- names used in the command's desugaring + [PostTcType] -- types of inputs on the command's stack + PostTcType -- return type of the command + (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] deriving (Data, Typeable) \end{code} + +\begin{code} +instance OutputableBndr id => Outputable (HsCmd id) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: OutputableBndr id => LHsCmd id -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: OutputableBndr id => HsCmd id -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar _) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp _ _) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: OutputableBndr id => LHsCmd id -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall id. OutputableBndr id => HsCmd id -> SDoc +ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map pprParendExpr args)) + where + collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +--avoid using PatternSignatures for stage1 code portability +ppr_cmd (HsCmdLam matches) + = pprMatches (LambdaExpr :: HsMatchContext id) matches + +ppr_cmd (HsCmdCase expr matches) + = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ] + +ppr_cmd (HsCmdIf _ e ct ce) + = sep [hsep [ptext (sLit "if"), nest 2 (ppr e), ptext (sLit "then")], + nest 4 (ppr ct), + ptext (sLit "else"), + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _))) + = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet binds cmd) + = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), + hang (ptext (sLit "in")) 2 (ppr cmd)] + +ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts + + +ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg] +ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg] +ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] +ppr_cmd (HsCmdArrForm op _ args) + = hang (ptext (sLit "(|") <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) + +pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _) + = ppr_lcmd cmd +pprCmdArg (HsCmdTop cmd _ _ _) + = parens (ppr_lcmd cmd) + +instance OutputableBndr id => Outputable (HsCmdTop id) where + ppr = pprCmdArg + +\end{code} + %************************************************************************ %* * \subsection{Record binds} @@ -732,28 +835,28 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} -data MatchGroup id +data MatchGroup id body = MatchGroup - [LMatch id] -- The alternatives - PostTcType -- The type is the type of the entire group - -- t1 -> ... -> tn -> tr - -- where there are n patterns + [LMatch id body] -- The alternatives + PostTcType -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns deriving (Data, Typeable) -type LMatch id = Located (Match id) +type LMatch id body = Located (Match id body) -data Match id +data Match id body = Match [LPat id] -- The patterns (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking - (GRHSs id) + (GRHSs id body) deriving (Data, Typeable) -isEmptyMatchGroup :: MatchGroup id -> Bool +isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MatchGroup ms _) = null ms -matchGroupArity :: MatchGroup id -> Arity +matchGroupArity :: MatchGroup id body -> Arity matchGroupArity (MatchGroup [] _) = panic "matchGroupArity" -- Precondition: MatchGroup is non-empty matchGroupArity (MatchGroup (match:matches) _) @@ -763,43 +866,46 @@ matchGroupArity (MatchGroup (match:matches) _) where n_pats = length (hsLMatchPats match) -hsLMatchPats :: LMatch id -> [LPat id] +hsLMatchPats :: LMatch id body -> [LPat id] hsLMatchPats (L _ (Match pats _ _)) = pats -- | GRHSs are used both for pattern bindings and for Matches -data GRHSs id +data GRHSs id body = GRHSs { - grhssGRHSs :: [LGRHS id], -- ^ Guarded RHSs + grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause } deriving (Data, Typeable) -type LGRHS id = Located (GRHS id) +type LGRHS id body = Located (GRHS id body) -- | Guarded Right Hand Side. -data GRHS id = GRHS [LStmt id] -- Guards - (LHsExpr id) -- Right hand side +data GRHS id body = GRHS [GuardLStmt id] -- Guards + body -- Right hand side deriving (Data, Typeable) \end{code} We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc +pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> MatchGroup idR body -> SDoc pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => idL -> Bool -> MatchGroup idR body -> SDoc pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr id. (OutputableBndr bndr, OutputableBndr id) - => LPat bndr -> GRHSs id -> SDoc +pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body) + => LPat bndr -> GRHSs id body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc +pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> Match idR body -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty @@ -833,23 +939,22 @@ pprMatch ctxt (Match pats maybe_ty grhss) Nothing -> empty -pprGRHSs :: (OutputableBndr idL, OutputableBndr idR) - => HsMatchContext idL -> GRHSs idR -> SDoc +pprGRHSs :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ ppUnless (isEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (OutputableBndr idL, OutputableBndr idR) - => HsMatchContext idL -> GRHS idR -> SDoc +pprGRHS :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> GRHS idR body -> SDoc +pprGRHS ctxt (GRHS [] body) + = pp_rhs ctxt body -pprGRHS ctxt (GRHS [] expr) - = pp_rhs ctxt expr +pprGRHS ctxt (GRHS guards body) + = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt body] -pprGRHS ctxt (GRHS guards expr) - = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] - -pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc +pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} @@ -860,30 +965,40 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -type LStmt id = Located (StmtLR id id) -type LStmtLR idL idR = Located (StmtLR idL idR) +type LStmt id body = Located (StmtLR id id body) +type LStmtLR idL idR body = Located (StmtLR idL idR body) + +type Stmt id body = StmtLR id id body + +type CmdLStmt id = LStmt id (LHsCmd id) +type CmdStmt id = Stmt id (LHsCmd id) +type ExprLStmt id = LStmt id (LHsExpr id) +type ExprStmt id = Stmt id (LHsExpr id) -type Stmt id = StmtLR id id +type GuardLStmt id = LStmt id (LHsExpr id) +type GuardStmt id = Stmt id (LHsExpr id) +type GhciLStmt id = LStmt id (LHsExpr id) +type GhciStmt id = Stmt id (LHsExpr id) -- The SyntaxExprs in here are used *only* for do-notation and monad -- comprehensions, which have rebindable syntax. Otherwise they are unused. -data StmtLR idL idR +data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, -- and (after the renamer) DoExpr, MDoExpr - -- Not used for GhciStmt, PatGuard, which scope over other stuff - (LHsExpr idR) + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + body (SyntaxExpr idR) -- The return operator, used only for MonadComp -- For ListComp, PArrComp, we use the baked-in 'return' -- For DoExpr, MDoExpr, we don't appply a 'return' at all -- See Note [Monad Comprehensions] | BindStmt (LPat idL) - (LHsExpr idR) + body (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | ExprStmt (LHsExpr idR) -- See Note [ExprStmt] + | BodyStmt body -- See Note [BodyStmt] (SyntaxExpr idR) -- The (>>) operator (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp -- See notes [Monad Comprehensions] @@ -901,13 +1016,13 @@ data StmtLR idL idR | TransStmt { trS_form :: TransForm, - trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' -- which generates the tuples to be grouped - trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] trS_using :: LHsExpr idR, - trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) -- Invariant: if trS_form = GroupBy, then grp_by = Just e trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for @@ -919,7 +1034,7 @@ data StmtLR idL idR -- Recursive statement (see Note [How RecStmt works] below) | RecStmt - { recS_stmts :: [LStmtLR idL idR] + { recS_stmts :: [LStmtLR idL idR body] -- The next two fields are only valid after renaming , recS_later_ids :: [idR] -- The ids are a subset of the variables bound by the @@ -961,7 +1076,7 @@ data TransForm -- The 'f' below is the 'using' function, 'e' is the by function data ParStmtBlock idL idR = ParStmtBlock - [LStmt idL] + [ExprLStmt idL] [idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator deriving( Data, Typeable ) @@ -996,20 +1111,20 @@ The [(idR,idR)] in a TransStmt behaves as follows: [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] Each pair has the same unique, but different *types*. -Note [ExprStmt] +Note [BodyStmt] ~~~~~~~~~~~~~~~ -ExprStmts are a bit tricky, because what they mean +BodyStmts are a bit tricky, because what they mean depends on the context. Consider the following contexts: A do expression of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E any_ty: do { ....; E; ... } + * BodyStmt E any_ty: do { ....; E; ... } E :: m any_ty Translation: E >> ... A list comprehensions of type [elt_ty] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E Bool: [ .. | .... E ] + * BodyStmt E Bool: [ .. | .... E ] [ .. | ..., E, ... ] [ .. | .... | ..., E | ... ] E :: Bool @@ -1017,13 +1132,13 @@ depends on the context. Consider the following contexts: A guard list, guarding a RHS of type rhs_ty ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E Bool: f x | ..., E, ... = ...rhs... + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... E :: Bool Translation: if E then fail else ... A monad comprehension of type (m res_ty) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * ExprStmt E Bool: [ .. | .... E ] + * BodyStmt E Bool: [ .. | .... E ] E :: Bool Translation: guard E >> ... @@ -1086,7 +1201,7 @@ In transform and grouping statements ('then ..' and 'then group ..') the => f [ env | stmts ] >>= \bndrs -> [ body | rest ] -ExprStmts require the 'Control.Monad.guard' function for boolean +BodyStmts require the 'Control.Monad.guard' function for boolean expressions: [ body | exp, stmts ] @@ -1105,17 +1220,19 @@ In any other context than 'MonadComp', the fields for most of these \begin{code} instance (OutputableBndr idL, OutputableBndr idR) - => Outputable (ParStmtBlock idL idR) where + => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where +instance (OutputableBndr idL, OutputableBndr idR, Outputable body) + => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt -pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc +pprStmt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] -pprStmt (ExprStmt expr _ _ _) = ppr expr +pprStmt (BodyStmt expr _ _ _) = ppr expr pprStmt (ParStmt stmtss _ _) = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) @@ -1134,36 +1251,37 @@ pprTransformStmt bndrs using by , nest 2 (ppr using) , nest 2 (pprBy by)] -pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> LHsExpr id -> TransForm - -> SDoc +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc pprTransStmt by using ThenForm = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] pprTransStmt by using GroupForm = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] -pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc +pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = ptext (sLit "by") <+> ppr e -pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc -pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts -pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts -pprDo ListComp stmts = brackets $ pprComp stmts -pprDo PArrComp stmts = paBrackets $ pprComp stmts -pprDo MonadComp stmts = brackets $ pprComp stmts -pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR) => [LStmtLR idL idR] -> SDoc +pprDo :: (OutputableBndr id, Outputable body) + => HsStmtContext any -> [LStmt id body] -> SDoc +pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo PArrComp stmts = paBrackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_do_stmts :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => [LStmtLR idL idR body] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs ppr_do_stmts stmts = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace -pprComp :: OutputableBndr id => [LStmt id] -> SDoc +pprComp :: (OutputableBndr id, Outputable body) + => [LStmt id body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | not (null quals) , L _ (LastStmt body _) <- last quals @@ -1171,7 +1289,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: OutputableBndr id => [LStmt id] -> SDoc +pprQuals :: (OutputableBndr id, Outputable body) + => [LStmt id body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals \end{code} @@ -1297,7 +1416,7 @@ data HsStmtContext id | MDoExpr -- mdo { ... } ie recursive do-expression | ArrowExpr -- do-notation in an arrow-command context - | GhciStmt -- A command-line Stmt in GHCi pat <- rhs + | GhciStmtCtxt -- A command-line Stmt in GHCi pat <- rhs | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt @@ -1364,14 +1483,14 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt pp_an = ptext (sLit "an") pp_a = ptext (sLit "a") article = case ctxt of - MDoExpr -> pp_an - PArrComp -> pp_an - GhciStmt -> pp_an - _ -> pp_a + MDoExpr -> pp_an + PArrComp -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a ----------------- -pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command") +pprStmtContext GhciStmtCtxt = ptext (sLit "interactive GHCi command") pprStmtContext DoExpr = ptext (sLit "'do' block") pprStmtContext MDoExpr = ptext (sLit "'mdo' block") pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") @@ -1406,7 +1525,7 @@ matchContextErrString ThPatQuote = panic "matchContextErrString" matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") -matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") +matchContextErrString (StmtCtxt GhciStmtCtxt) = ptext (sLit "interactive GHCi command") matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") @@ -1416,13 +1535,13 @@ matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehe \end{code} \begin{code} -pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR) - => HsMatchContext idL -> Match idR -> SDoc +pprMatchInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsMatchContext idL -> Match idR body -> SDoc pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) -pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) - => HsStmtContext idL -> StmtLR idL idR -> SDoc +pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => HsStmtContext idL -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" = hang (ptext (sLit "In the expression:")) 2 (ppr e) diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 86032f5829..a04fa3095b 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -3,25 +3,31 @@ module HsExpr where import SrcLoc ( Located ) -import Outputable ( SDoc, OutputableBndr ) +import Outputable ( SDoc, OutputableBndr, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import Data.Data -- IA0_NOTE: We need kind annotations because of kind polymorphism data HsExpr (i :: *) +data HsCmd (i :: *) data HsSplice (i :: *) -data MatchGroup (a :: *) -data GRHSs (a :: *) +data MatchGroup (a :: *) (body :: *) +data GRHSs (a :: *) (body :: *) instance Typeable1 HsSplice instance Data i => Data (HsSplice i) instance Typeable1 HsExpr instance Data i => Data (HsExpr i) -instance Typeable1 MatchGroup -instance Data i => Data (MatchGroup i) -instance Typeable1 GRHSs -instance Data i => Data (GRHSs i) +instance Typeable1 HsCmd +instance Data i => Data (HsCmd i) +instance Typeable2 MatchGroup +instance (Data i, Data body) => Data (MatchGroup i body) +instance Typeable2 GRHSs +instance (Data i, Data body) => Data (GRHSs i body) + +instance OutputableBndr id => Outputable (HsExpr id) +instance OutputableBndr id => Outputable (HsCmd id) type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a @@ -35,9 +41,9 @@ pprExpr :: (OutputableBndr i) => pprSplice :: (OutputableBndr i) => HsSplice i -> SDoc -pprPatBind :: (OutputableBndr b, OutputableBndr i) => - LPat b -> GRHSs i -> SDoc +pprPatBind :: (OutputableBndr bndr, OutputableBndr id, Outputable body) + => LPat bndr -> GRHSs id body -> SDoc -pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => - idL -> Bool -> MatchGroup idR -> SDoc +pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body) + => idL -> Bool -> MatchGroup idR body -> SDoc \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 32fe487609..087ecd2985 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -50,7 +50,7 @@ module HsUtils( nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, @@ -112,7 +112,7 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) -mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id +mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) mkSimpleMatch pats rhs = L loc $ Match pats Nothing (unguardedGRHSs rhs) @@ -121,13 +121,13 @@ mkSimpleMatch pats rhs [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) -unguardedGRHSs :: LHsExpr id -> GRHSs id +unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds -unguardedRHS :: LHsExpr id -> [LGRHS id] +unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] -mkMatchGroup :: [LMatch id] -> MatchGroup id +mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id)) mkMatchGroup matches = MatchGroup matches placeHolderType mkHsAppTy :: LHsType name -> LHsType name -> LHsType name @@ -139,7 +139,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where - matches = mkMatchGroup [mkSimpleMatch pats body] + matches = mkMatchGroup [mkSimpleMatch pats body] mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr @@ -151,7 +151,7 @@ mkHsConApp data_con tys args where mk_app f a = noLoc (HsApp f (noLoc a)) -mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id +mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr @@ -178,18 +178,18 @@ mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) mkHsIntegral :: Integer -> PostTcType -> HsOverLit id mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id -mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkHsDo :: HsStmtContext Name -> [ExprLStmt id] -> HsExpr id +mkHsComp :: HsStmtContext Name -> [ExprLStmt id] -> LHsExpr id -> HsExpr id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id -mkLastStmt :: LHsExpr idR -> StmtLR idL idR -mkExprStmt :: LHsExpr idR -> StmtLR idL idR -mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR +mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBodyStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -emptyRecStmt :: StmtLR idL idR -mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR +emptyRecStmt :: StmtLR idL idR bodyR +mkRecStmt :: [LStmtLR idL idR bodyR] -> StmtLR idL idR bodyR mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr @@ -210,12 +210,16 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr -mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR +mkTransformStmt :: [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkTransformByStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupUsingStmt :: [ExprLStmt idL] -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) +mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR + -> StmtLR idL idR (LHsExpr idL) -emptyTransStmt :: StmtLR idL idR +emptyTransStmt :: StmtLR idL idR (LHsExpr idR) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noSyntaxExpr @@ -226,9 +230,9 @@ mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = s mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkLastStmt expr = LastStmt expr noSyntaxExpr -mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType -mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr +mkLastStmt body = LastStmt body noSyntaxExpr +mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType +mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr @@ -324,16 +328,16 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id +nlHsDo :: HsStmtContext Name -> [LStmt id (LHsExpr id)] -> LHsExpr id nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) -nlHsLam :: LMatch id -> LHsExpr id +nlHsLam :: LMatch id (LHsExpr id) -> LHsExpr id nlHsPar :: LHsExpr id -> LHsExpr id nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id +nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id nlList :: [LHsExpr id] -> LHsExpr id nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) @@ -413,7 +417,7 @@ l %************************************************************************ \begin{code} -mkFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName +mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , fun_matches = mkMatchGroup ms @@ -421,7 +425,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , bind_fvs = placeHolderNames , fun_tick = Nothing } -mkTopFunBind :: Located Name -> [LMatch Name] -> HsBind Name +mkTopFunBind :: Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name -- In Name-land, with empty bind_fvs mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , fun_matches = mkMatchGroup ms @@ -443,7 +447,7 @@ mk_easy_FunBind loc fun pats expr = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ -mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id +mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing (GRHSs (unguardedRHS expr) binds)) @@ -521,20 +525,20 @@ collectMethodBinders binds = foldrBag get [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR idL idR] -> [idL] +collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR idL idR] -> [idL] +collectStmtsBinders :: [StmtLR idL idR body] -> [idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR idL idR -> [idL] +collectLStmtBinders :: LStmtLR idL idR body -> [idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR idL idR -> [idL] +collectStmtBinders :: StmtLR idL idR body -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders $ [s | ParStmtBlock ss _ _ <- xs, s <- ss] @@ -702,15 +706,15 @@ The main purpose is to find names introduced by record wildcards so that we can warning the user when they don't use those names (#4404) \begin{code} -lStmtsImplicits :: [LStmtLR Name idR] -> NameSet +lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat hs_stmt (LetStmt binds) = hs_local_binds binds - hs_stmt (ExprStmt {}) = emptyNameSet + hs_stmt (BodyStmt {}) = emptyNameSet hs_stmt (LastStmt {}) = emptyNameSet hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f04ca020e2..04f89bf63e 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1611,7 +1611,7 @@ hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _ _)) -> + Just (L _ (BodyStmt expr _ _ _)) -> ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan @@ -1628,11 +1628,11 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty -hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName)) +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt RdrName)) hscParseStmt = hscParseThing parseStmt hscParseStmtWithLocation :: String -> Int -> String - -> Hsc (Maybe (LStmt RdrName)) + -> Hsc (Maybe (GhciLStmt RdrName)) hscParseStmtWithLocation source linenumber stmt = hscParseThingWithLocation source linenumber parseStmt stmt diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 718adcabfd..966d4e3613 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1334,15 +1334,15 @@ decl :: { Located (OrdList (LHsDecl RdrName)) } return $! (sL l (unitOL $! (sL l $ ValD r))) } } | docdecl { LL $ unitOL $1 } -rhs :: { Located (GRHSs RdrName) } +rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) } -gdrhs :: { Located [LGRHS RdrName] } +gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : gdrhs gdrh { LL ($2 : unLoc $1) } | gdrh { L1 [$1] } -gdrh :: { LGRHS RdrName } +gdrh :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } @@ -1422,8 +1422,9 @@ exp10 :: { LHsExpr RdrName } | 'proc' aexp '->' exp {% checkPattern $2 >>= \ p -> - return (LL $ HsProc p (LL $ HsCmdTop $4 [] - placeHolderType undefined)) } + checkCommand $4 >>= \ cmd -> + return (LL $ HsProc p (LL $ HsCmdTop cmd [] + placeHolderType undefined)) } -- TODO: is LL right here? | '{-# CORE' STRING '#-}' exp { LL $ HsCoreAnn (getSTRING $2) $4 } @@ -1516,7 +1517,8 @@ cmdargs :: { [LHsCmdTop RdrName] } | {- empty -} { [] } acmd :: { LHsCmdTop RdrName } - : aexp2 { L1 $ HsCmdTop $1 [] placeHolderType undefined } + : aexp2 {% checkCommand $1 >>= \ cmd -> + return (L1 $ HsCmdTop cmd [] placeHolderType undefined) } cvtopbody :: { [LHsDecl RdrName] } : '{' cvtopdecls0 '}' { $2 } @@ -1592,7 +1594,7 @@ lexps :: { Located [LHsExpr RdrName] } ----------------------------------------------------------------------------- -- List Comprehensions -flattenedpquals :: { Located [LStmt RdrName] } +flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : pquals { case (unLoc $1) of [qs] -> L1 qs -- We just had one thing in our "parallel" list so @@ -1604,11 +1606,11 @@ flattenedpquals :: { Located [LStmt RdrName] } -- we wrap them into as a ParStmt } -pquals :: { Located [[LStmt RdrName]] } +pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) } | squals { L (getLoc $1) [reverse (unLoc $1)] } -squals :: { Located [LStmt RdrName] } -- In reverse order, because the last +squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] } | squals ',' qual { LL ($3 : unLoc $1) } @@ -1623,7 +1625,7 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last -- consensus on the syntax, this feature is not being used until we -- get user demand. -transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } +transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) } -- Function is applied to a list of stmts *in order* : 'then' exp { LL $ \ss -> (mkTransformStmt ss $2) } | 'then' exp 'by' exp { LL $ \ss -> (mkTransformByStmt ss $2 $4) } @@ -1657,44 +1659,44 @@ parr :: { LHsExpr RdrName } ----------------------------------------------------------------------------- -- Guards -guardquals :: { Located [LStmt RdrName] } +guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } -guardquals1 :: { Located [LStmt RdrName] } +guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] } : guardquals1 ',' qual { LL ($3 : unLoc $1) } | qual { L1 [$1] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { Located [LMatch RdrName] } +altslist :: { Located [LMatch RdrName (LHsExpr RdrName)] } : '{' alts '}' { LL (reverse (unLoc $2)) } | vocurly alts close { L (getLoc $2) (reverse (unLoc $2)) } -alts :: { Located [LMatch RdrName] } +alts :: { Located [LMatch RdrName (LHsExpr RdrName)] } : alts1 { L1 (unLoc $1) } | ';' alts { LL (unLoc $2) } -alts1 :: { Located [LMatch RdrName] } +alts1 :: { Located [LMatch RdrName (LHsExpr RdrName)] } : alts1 ';' alt { LL ($3 : unLoc $1) } | alts1 ';' { LL (unLoc $1) } | alt { L1 [$1] } -alt :: { LMatch RdrName } +alt :: { LMatch RdrName (LHsExpr RdrName) } : pat opt_sig alt_rhs { LL (Match [$1] $2 (unLoc $3)) } -alt_rhs :: { Located (GRHSs RdrName) } +alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) } : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) } -ralt :: { Located [LGRHS RdrName] } +ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : '->' exp { LL (unguardedRHS $2) } | gdpats { L1 (reverse (unLoc $1)) } -gdpats :: { Located [LGRHS RdrName] } +gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] } : gdpats gdpat { LL ($2 : unLoc $1) } | gdpat { L1 [$1] } -gdpat :: { LGRHS RdrName } +gdpat :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '->' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } -- 'pat' recognises a pattern, including one with a bang at the top @@ -1716,37 +1718,37 @@ apats :: { [LPat RdrName] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { Located [LStmt RdrName] } +stmtlist :: { Located [LStmt RdrName (LHsExpr RdrName)] } : '{' stmts '}' { LL (unLoc $2) } | vocurly stmts close { $2 } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce -- here, because we need too much lookahead if we see do { e ; } --- So we use ExprStmts throughout, and switch the last one over +-- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { Located [LStmt RdrName] } +stmts :: { Located [LStmt RdrName (LHsExpr RdrName)] } : stmt stmts_help { LL ($1 : unLoc $2) } | ';' stmts { LL (unLoc $2) } | {- empty -} { noLoc [] } -stmts_help :: { Located [LStmt RdrName] } -- might be empty +stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty : ';' stmts { LL (unLoc $2) } | {- empty -} { noLoc [] } -- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. -maybe_stmt :: { Maybe (LStmt RdrName) } +maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } : stmt { Just $1 } | {- nothing -} { Nothing } -stmt :: { LStmt RdrName } +stmt :: { LStmt RdrName (LHsExpr RdrName) } : qual { $1 } | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) } -qual :: { LStmt RdrName } +qual :: { LStmt RdrName (LHsExpr RdrName) } : pat '<-' exp { LL $ mkBindStmt $1 $3 } - | exp { L1 $ mkExprStmt $1 } + | exp { L1 $ mkBodyStmt $1 } | 'let' binds { LL $ LetStmt (unLoc $2) } ----------------------------------------------------------------------------- diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 6da712ce44..5c0d3bb700 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -39,6 +39,7 @@ module RdrHsSyn ( bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] checkMonadComp, -- P (HsStmtContext RdrName) + checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@ -312,7 +313,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1, getMonoBind bind binds = (bind, binds) -has_args :: [LMatch RdrName] -> Bool +has_args :: [LMatch RdrName (LHsExpr RdrName)] -> Bool has_args [] = panic "RdrHsSyn:has_args" has_args ((L _ (Match args _ _)) : _) = not (null args) -- Don't group together FunBinds if they have @@ -637,7 +638,7 @@ patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e) checkValDef :: LHsExpr RdrName -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P (HsBind RdrName) checkValDef lhs (Just sig) grhss @@ -656,7 +657,7 @@ checkFunBind :: SrcSpan -> Bool -> [LHsExpr RdrName] -> Maybe (LHsType RdrName) - -> Located (GRHSs RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P (HsBind RdrName) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) = do ps <- checkPatterns pats @@ -665,14 +666,14 @@ checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. -makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id +makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn is_infix ms = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms, fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing } checkPatBind :: LHsExpr RdrName - -> Located (GRHSs RdrName) + -> Located (GRHSs RdrName (LHsExpr RdrName)) -> P (HsBind RdrName) checkPatBind lhs (L _ grhss) = do { lhs <- checkPattern lhs @@ -808,6 +809,94 @@ checkMonadComp = do then MonadComp else ListComp +-- ------------------------------------------------------------------------- +-- Checking arrow syntax. + +-- We parse arrow syntax as expressions and check for valid syntax below, +-- converting the expression into a pattern at the same time. + +checkCommand :: LHsExpr RdrName -> P (LHsCmd RdrName) +checkCommand lc = locMap checkCmd lc + +locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b) +locMap f (L l a) = f l a >>= (\b -> return $ L l b) + +checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) +checkCmd _ (HsArrApp e1 e2 ptt haat b) = + return $ HsCmdArrApp e1 e2 ptt haat b +checkCmd _ (HsArrForm e mf args) = + return $ HsCmdArrForm e mf args +checkCmd _ (HsApp e1 e2) = + checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) +checkCmd _ (HsLam mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg') +checkCmd _ (HsPar e) = + checkCommand e >>= (\c -> return $ HsCmdPar c) +checkCmd _ (HsCase e mg) = + checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg') +checkCmd _ (HsIf cf ep et ee) = do + pt <- checkCommand et + pe <- checkCommand ee + return $ HsCmdIf cf ep pt pe +checkCmd _ (HsLet lb e) = + checkCommand e >>= (\c -> return $ HsCmdLet lb c) +checkCmd _ (HsDo DoExpr stmts ty) = + mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty) + +checkCmd _ (OpApp eLeft op fixity eRight) = do + -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it + c1 <- checkCommand eLeft + c2 <- checkCommand eRight + let arg1 = L (getLoc c1) $ HsCmdTop c1 [] placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop c2 [] placeHolderType [] + return $ HsCmdArrForm op (Just fixity) [arg1, arg2] + +checkCmd l e = cmdFail l e + +checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName) +checkCmdLStmt = locMap checkCmdStmt + +checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName) +checkCmdStmt _ (LastStmt e r) = + checkCommand e >>= (\c -> return $ LastStmt c r) +checkCmdStmt _ (BindStmt pat e b f) = + checkCommand e >>= (\c -> return $ BindStmt pat c b f) +checkCmdStmt _ (BodyStmt e t g ty) = + checkCommand e >>= (\c -> return $ BodyStmt c t g ty) +checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds +checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do + ss <- mapM checkCmdLStmt stmts + return $ stmt { recS_stmts = ss } +checkCmdStmt l stmt = cmdStmtFail l stmt + +checkCmdMatchGroup :: MatchGroup RdrName (LHsExpr RdrName) -> P (MatchGroup RdrName (LHsCmd RdrName)) +checkCmdMatchGroup (MatchGroup ms ty) = do + ms' <- mapM (locMap $ const convert) ms + return $ MatchGroup ms' ty + where convert (Match pat mty grhss) = do + grhss' <- checkCmdGRHSs grhss + return $ Match pat mty grhss' + +checkCmdGRHSs :: GRHSs RdrName (LHsExpr RdrName) -> P (GRHSs RdrName (LHsCmd RdrName)) +checkCmdGRHSs (GRHSs grhss binds) = do + grhss' <- mapM checkCmdGRHS grhss + return $ GRHSs grhss' binds + +checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName)) +checkCmdGRHS = locMap $ const convert + where + convert (GRHS stmts e) = do + c <- checkCommand e +-- cmdStmts <- mapM checkCmdLStmt stmts + return $ GRHS {- cmdStmts -} stmts c + + +cmdFail :: SrcSpan -> HsExpr RdrName -> P a +cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e) +cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a +cmdStmtFail loc e = parseErrorSDoc loc + (text "Parse error in command statement:" <+> ppr e) + --------------------------------------------------------------------------- -- Miscellaneous utilities diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 75c49437c0..a0aea6a582 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -444,7 +444,7 @@ rnBind _ (L loc bind@(PatBind { pat_lhs = pat , bind_fvs = pat_fvs })) = setSrcSpan loc $ do { mod <- getModule - ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs grhss + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss -- No scoped type variables for pattern bindings ; let all_fvs = pat_fvs `plusFV` rhs_fvs @@ -479,7 +479,7 @@ rnBind sig_fn (L loc bind@(FunBind { fun_id = name ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ -- bindSigTyVars tests for Opt_ScopedTyVars - rnMatchGroup (FunRhs plain_name is_infix) matches + rnMatchGroup (FunRhs plain_name is_infix) rnLExpr matches ; when is_infix $ checkPrecMatch plain_name matches' ; mod <- getModule @@ -612,7 +612,7 @@ rnMethodBind cls sig_fn -- We use the selector name as the binder (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches + mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches let new_group = MatchGroup new_matches placeHolderType when is_infix $ checkPrecMatch plain_name new_group @@ -758,16 +758,25 @@ okHsSig ctxt (L _ sig) %************************************************************************ \begin{code} -rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) -rnMatchGroup ctxt (MatchGroup ms _) - = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms +rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> MatchGroup RdrName (Located (body RdrName)) + -> RnM (MatchGroup Name (Located (body Name)), FreeVars) +rnMatchGroup ctxt rnBody (MatchGroup ms _) + = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (MatchGroup new_ms placeHolderType, ms_fvs) } -rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) -rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) - -rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) -rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) +rnMatch :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LMatch RdrName (Located (body RdrName)) + -> RnM (LMatch Name (Located (body Name)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) + +rnMatch' :: Outputable (body RdrName) => HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> Match RdrName (Located (body RdrName)) + -> RnM (Match Name (Located (body Name)), FreeVars) +rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss) = do { -- Result type signatures are no longer supported case maybe_rhs_sig of Nothing -> return () @@ -776,11 +785,11 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) -- Now the main event -- note that there are no local ficity decls for matches ; rnPats ctxt pats $ \ pats' -> do - { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; return (Match pats' Nothing grhss', grhss_fvs) }} -resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc +resSigErr :: Outputable body => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc resSigErr ctxt match ty = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") @@ -795,21 +804,29 @@ resSigErr ctxt match ty %************************************************************************ \begin{code} -rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) - -rnGRHSs ctxt (GRHSs grhss binds) +rnGRHSs :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> GRHSs RdrName (Located (body RdrName)) + -> RnM (GRHSs Name (Located (body Name)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs grhss binds) = rnLocalBindsAndThen binds $ \ binds' -> do - (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss return (GRHSs grhss' binds', fvGRHSs) -rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) -rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) - -rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars) -rnGRHS' ctxt (GRHS guards rhs) +rnGRHS :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LGRHS RdrName (Located (body RdrName)) + -> RnM (LGRHS Name (Located (body Name)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> GRHS RdrName (Located (body RdrName)) + -> RnM (GRHS Name (Located (body Name)), FreeVars) +rnGRHS' ctxt rnBody (GRHS guards rhs) = do { pattern_guards_allowed <- xoptM Opt_PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ -> - rnLExpr rhs + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') (addWarn (nonStdGuardErr guards')) @@ -820,7 +837,7 @@ rnGRHS' ctxt (GRHS guards rhs) -- expression, rather than a list of qualifiers as in the -- Glasgow extension is_standard_guard [] = True - is_standard_guard [L _ (ExprStmt _ _ _ _)] = True + is_standard_guard [L _ (BodyStmt _ _ _ _)] = True is_standard_guard _ = False \end{code} @@ -861,7 +878,7 @@ bindsInHsBootFile mbinds = hang (ptext (sLit "Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) -nonStdGuardErr :: [LStmtLR Name Name] -> SDoc +nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc nonStdGuardErr guards = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c232a89cd1..6385e1b52d 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -18,7 +18,7 @@ module RnEnv ( lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, greRdrName, lookupSubBndrGREs, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, + lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -1179,27 +1179,23 @@ lookupIfThenElse lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on -> - if not rebindable_on then normal_case - else - -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - return (HsVar usr_name, unitFV usr_name) - where - normal_case = return (HsVar std_name, emptyFVs) - -lookupSyntaxTable :: [Name] -- Standard names - -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames -lookupSyntaxTable std_names - = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on -> - if not rebindable_on then normal_case - else - -- Get the similarly named thing from the local environment - mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - - return (std_names `zip` map HsVar usr_names, mkFVs usr_names) - where - normal_case = return (std_names `zip` map HsVar std_names, emptyFVs) + = do { rebindable_on <- xoptM Opt_RebindableSyntax + ; if not rebindable_on then + return (HsVar std_name, emptyFVs) + else + -- Get the similarly named thing from the local environment + do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) + ; return (HsVar usr_name, unitFV usr_name) } } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM Opt_RebindableSyntax + ; if not rebindable_on then + return (map HsVar std_names, emptyFVs) + else + do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names + ; return (map HsVar usr_names, mkFVs usr_names) } } \end{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index ec495ad33d..0d69d252f1 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -221,16 +221,16 @@ rnExpr (HsTickPragma info expr) return (HsTickPragma info expr', fvs_expr) rnExpr (HsLam matches) - = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> + = rnMatchGroup LambdaExpr rnLExpr matches `thenM` \ (matches', fvMatch) -> return (HsLam matches', fvMatch) rnExpr (HsLamCase arg matches) - = rnMatchGroup CaseAlt matches `thenM` \ (matches', fvs_ms) -> + = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> return (HsLamCase arg matches', fvs_ms) rnExpr (HsCase expr matches) - = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) -> + = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> + rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (new_matches, ms_fvs) -> return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) @@ -239,7 +239,7 @@ rnExpr (HsLet binds expr) return (HsLet binds' expr', fvExpr) rnExpr (HsDo do_or_lc stmts _) - = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs)) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) @@ -285,7 +285,7 @@ rnExpr (HsIf _ p b1 b2) ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsMultiIf ty alts) - = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt) alts + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts ; return (HsMultiIf ty alts', fvs) } rnExpr (HsType a) @@ -332,45 +332,21 @@ rnExpr (HsProc pat body) rnCmdTop body `thenM` \ (body',fvBody) -> return (HsProc pat' body', fvBody) -rnExpr (HsArrApp arrow arg _ ho rtl) - = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsArrApp arrow' arg' placeHolderType ho rtl, - fvArrow `plusFV` fvArg) - where - -- See Note [Escaping the arrow scope] in TcRnTypes - -- Before renaming 'arrow', use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside 'arrow'. In the higher-order case (-<<), they are. - select_arrow_scope tc = case ho of - HsHigherOrderApp -> tc - HsFirstOrderApp -> escapeArrowScope tc - --- infix form -rnExpr (HsArrForm op (Just _) [arg1, arg2]) - = escapeArrowScope (rnLExpr op) - `thenM` \ (op',fv_op) -> - let L _ (HsVar op_name) = op' in - rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> - rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> - - -- Deal with fixity - - lookupFixityRn op_name `thenM` \ fixity -> - mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> - - return (final_e, - fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) - -rnExpr (HsArrForm op fixity cmds) - = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> - rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> - return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) +-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. +rnExpr e@(HsArrApp {}) = arrowFail e +rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap +arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +arrowFail e + = do { addErr (vcat [ ptext (sLit "Arrow command found where an expression was expected:") + , nest 2 (ppr e) ]) + -- Return a place-holder hole, so that we can carry on + -- to report other errors + ; return (HsHole, emptyFVs) } + ---------------------- -- See Note [Parsing sections] in Parser.y.pp rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) @@ -427,77 +403,90 @@ rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where rnCmdTop' (HsCmdTop cmd _ _ _) - = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) -> - let - cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetToList (methodNamesCmd (unLoc cmd')) - in + = do { (cmd', fvCmd) <- rnLCmd cmd + ; let cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetToList (methodNamesCmd (unLoc cmd')) -- Generate the rebindable syntax for the monad - lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) -> + ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - return (HsCmdTop cmd' [] placeHolderType cmd_names', - fvCmd `plusFV` cmd_fvs) + ; return (HsCmdTop cmd' [] placeHolderType (cmd_names `zip` cmd_names'), + fvCmd `plusFV` cmd_fvs) } ---------------------------------------------------- --- convert OpApp's in a command context to HsArrForm's +rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) +rnLCmd = wrapLocFstM rnCmd + +rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) + +rnCmd (HsCmdArrApp arrow arg _ ho rtl) + = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + fvArrow `plusFV` fvArg) + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + -- See Note [Escaping the arrow scope] in TcRnTypes + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. -convertOpFormsLCmd :: LHsCmd id -> LHsCmd id -convertOpFormsLCmd = fmap convertOpFormsCmd +-- infix form +rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) + = escapeArrowScope (rnLExpr op) + `thenM` \ (op',fv_op) -> + let L _ (HsVar op_name) = op' in + rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> + rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> -convertOpFormsCmd :: HsCmd id -> HsCmd id + -- Deal with fixity -convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e -convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match) -convertOpFormsCmd (OpApp c1 op fixity c2) - = let - arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType [] - arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType [] - in - HsArrForm op (Just fixity) [arg1, arg2] + lookupFixityRn op_name `thenM` \ fixity -> + mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> -convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) + return (final_e, + fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) -convertOpFormsCmd (HsCase exp matches) - = HsCase exp (convertOpFormsMatch matches) +rnCmd (HsCmdArrForm op fixity cmds) + = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> + rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> + return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) -convertOpFormsCmd (HsIf f exp c1 c2) - = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) +rnCmd (HsCmdApp fun arg) + = rnLCmd fun `thenM` \ (fun',fvFun) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) -convertOpFormsCmd (HsLet binds cmd) - = HsLet binds (convertOpFormsLCmd cmd) +rnCmd (HsCmdLam matches) + = rnMatchGroup LambdaExpr rnLCmd matches `thenM` \ (matches', fvMatch) -> + return (HsCmdLam matches', fvMatch) -convertOpFormsCmd (HsDo DoExpr stmts ty) - = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty - -- Mark the HsDo as begin the body of an arrow command +rnCmd (HsCmdPar e) + = do { (e', fvs_e) <- rnLCmd e + ; return (HsCmdPar e', fvs_e) } --- Anything else is unchanged. This includes HsArrForm (already done), --- things with no sub-commands, and illegal commands (which will be --- caught by the type checker) -convertOpFormsCmd c = c +rnCmd (HsCmdCase expr matches) + = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> + rnMatchGroup CaseAlt rnLCmd matches `thenM` \ (new_matches, ms_fvs) -> + return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) -convertOpFormsStmt :: StmtLR id id -> StmtLR id id -convertOpFormsStmt (BindStmt pat cmd _ _) - = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr -convertOpFormsStmt (ExprStmt cmd _ _ _) - = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType -convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts }) - = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts } -convertOpFormsStmt stmt = stmt +rnCmd (HsCmdIf _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLCmd b1 + ; (b2', fvB2) <- rnLCmd b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -convertOpFormsMatch :: MatchGroup id -> MatchGroup id -convertOpFormsMatch (MatchGroup ms ty) - = MatchGroup (map (fmap convert) ms) ty - where convert (Match pat mty grhss) - = Match pat mty (convertOpFormsGRHSs grhss) +rnCmd (HsCmdLet binds cmd) + = rnLocalBindsAndThen binds $ \ binds' -> + rnLCmd cmd `thenM` \ (cmd',fvExpr) -> + return (HsCmdLet binds' cmd', fvExpr) -convertOpFormsGRHSs :: GRHSs id -> GRHSs id -convertOpFormsGRHSs (GRHSs grhss binds) - = GRHSs (map convertOpFormsGRHS grhss) binds +rnCmd (HsCmdDo stmts _) + = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo stmts' placeHolderType, fvs ) } -convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id) -convertOpFormsGRHS = fmap convert - where - convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -509,32 +498,32 @@ methodNamesLCmd = methodNamesCmd . unLoc methodNamesCmd :: HsCmd Name -> CmdNeeds -methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) = emptyFVs -methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl) +methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl) = unitFV appAName -methodNamesCmd (HsArrForm {}) = emptyFVs +methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsPar c) = methodNamesLCmd c +methodNamesCmd (HsCmdPar c) = methodNamesLCmd c -methodNamesCmd (HsIf _ _ c1 c2) +methodNamesCmd (HsCmdIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsLet _ c) = methodNamesLCmd c -methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts -methodNamesCmd (HsApp c _) = methodNamesLCmd c -methodNamesCmd (HsLam match) = methodNamesMatch match +methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam match) = methodNamesMatch match -methodNamesCmd (HsCase _ matches) +methodNamesCmd (HsCmdCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName -methodNamesCmd _ = emptyFVs +--methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. -- The type checker will complain later --------------------------------------------------- -methodNamesMatch :: MatchGroup Name -> FreeVars +methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars methodNamesMatch (MatchGroup ms _) = plusFVs (map do_one ms) where @@ -542,25 +531,25 @@ methodNamesMatch (MatchGroup ms _) ------------------------------------------------- -- gaw 2004 -methodNamesGRHSs :: GRHSs Name -> FreeVars +methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds +methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars +methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars +methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc -methodNamesStmt :: StmtLR Name Name -> FreeVars +methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd -methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {}) = emptyFVs @@ -662,59 +651,62 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" %************************************************************************ \begin{code} -rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) +rnStmts :: Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmts ctxt [] thing_inside +rnStmts ctxt _ [] thing_inside = do { checkEmptyStmts ctxt ; (thing, fvs) <- thing_inside [] ; return (([], thing), fvs) } -rnStmts MDoExpr stmts thing_inside -- Deal with mdo +rnStmts MDoExpr rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ -> + <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> do { last_stmt' <- checkLastStmt MDoExpr last_stmt - ; rnStmt MDoExpr last_stmt' thing_inside } + ; rnStmt MDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } where Just (all_but_last, last_stmt) = snocView stmts -rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside +rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside | null lstmts = setSrcSpan loc $ do { lstmt' <- checkLastStmt ctxt lstmt - ; rnStmt ctxt lstmt' thing_inside } + ; rnStmt ctxt rnBody lstmt' thing_inside } | otherwise = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ do { checkStmt ctxt lstmt - ; rnStmt ctxt lstmt $ \ bndrs1 -> - rnStmts ctxt lstmts $ \ bndrs2 -> + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + rnStmts ctxt rnBody lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } ---------------------- -rnStmt :: HsStmtContext Name - -> LStmt RdrName +rnStmt :: Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> LStmt RdrName (Located (body RdrName)) -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt ctxt (L loc (LastStmt expr _)) thing_inside - = do { (expr', fv_expr) <- rnLExpr expr +rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside + = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (LastStmt expr' ret_op)], thing), + ; return (([L loc (LastStmt body' ret_op)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } -rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside - = do { (expr', fv_expr) <- rnLExpr expr +rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body ; (then_op, fvs1) <- lookupStmtName ctxt thenMName ; (guard_op, fvs2) <- if isListCompExpr ctxt then lookupStmtName ctxt guardMName @@ -723,27 +715,27 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), + ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside - = do { (expr', fv_expr) <- rnLExpr expr +rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName ; (fail_op, fvs2) <- lookupStmtName ctxt failMName ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), + ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt _ (L loc (LetStmt binds)) thing_inside +rnStmt _ _ (L loc (LetStmt binds)) thing_inside = do { rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } -rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside +rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the @@ -754,7 +746,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside -- for which it's the fwd refs within the bind itself -- (This set may not be empty, because we're in a recursive -- context.) - ; rnRecStmtsAndThen rec_stmts $ \ segs -> do + ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs @@ -786,7 +778,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt (L loc (ParStmt segs _ _)) thing_inside +rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName @@ -794,7 +786,7 @@ rnStmt ctxt (L loc (ParStmt segs _ _)) thing_inside ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } -rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form +rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form , trS_using = using })) thing_inside = do { -- Rename the 'using' expression in the context before the transform is begun (using', fvs1) <- rnLExpr using @@ -802,7 +794,7 @@ rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing @@ -850,7 +842,7 @@ rnParallelStmts ctxt return_op segs thing_inside rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnStmts ctxt stmts $ \ bndrs -> + <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs @@ -876,7 +868,7 @@ lookupStmtName ctxt n DoExpr -> rebindable MDoExpr -> rebindable MonadComp -> rebindable - GhciStmt -> rebindable -- I suppose? + GhciStmtCtxt -> rebindable -- I suppose? ParStmtCtxt c -> lookupStmtName c n -- Look inside to TransStmtCtxt c -> lookupStmtName c n -- the parent context @@ -920,12 +912,14 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: [LStmt RdrName] +rnRecStmtsAndThen :: Outputable (body RdrName) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnRecStmtsAndThen s cont + -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnRecStmtsAndThen rnBody s cont = do { -- (A) Make the mini fixity env for all of the stmts fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) @@ -940,13 +934,13 @@ rnRecStmtsAndThen s cont addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside - { segs <- rn_rec_stmts bound_names new_lhs_and_fv + { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv ; (res, fvs) <- cont segs ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName] +collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> @@ -957,24 +951,24 @@ collectRecStmtsFixities l = -- left-hand sides -rn_rec_stmt_lhs :: MiniFixityEnv - -> LStmt RdrName +rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv + -> LStmt RdrName body -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR Name RdrName, FreeVars)] + -> RnM [(LStmtLR Name RdrName body, FreeVars)] -rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) - = return [(L loc (ExprStmt expr a b c), emptyFVs)] +rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) + = return [(L loc (BodyStmt body a b c), emptyFVs)] -rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) - = return [(L loc (LastStmt expr a), emptyFVs)] +rn_rec_stmt_lhs _ (L loc (LastStmt body a)) + = return [(L loc (LastStmt body a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt pat' expr a b), + return [(L loc (BindStmt pat' body a b), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) @@ -1000,9 +994,9 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmts_lhs :: MiniFixityEnv - -> [LStmt RdrName] - -> RnM [(LStmtLR Name RdrName, FreeVars)] +rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv + -> [LStmt RdrName body] + -> RnM [(LStmtLR Name RdrName body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts ; let boundNames = collectLStmtsBinders (map fst ls) @@ -1015,24 +1009,27 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)] +rn_rec_stmt :: (Outputable (body RdrName)) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [Name] -> LStmtLR Name RdrName (Located (body RdrName)) + -> FreeVars -> RnM [Segment (LStmt Name (Located (body Name)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt _ (L loc (LastStmt expr _)) _ - = do { (expr', fv_expr) <- rnLExpr expr +rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _ + = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupSyntaxName returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt expr' ret_op))] } + L loc (LastStmt body' ret_op))] } -rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _ - = rnLExpr expr `thenM` \ (expr', fvs) -> +rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _ + = rnBody body `thenM` \ (body', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))] + L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] -rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat - = rnLExpr expr `thenM` \ (expr', fv_expr) -> +rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat + = rnBody body `thenM` \ (body', fv_expr) -> lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> let @@ -1040,12 +1037,12 @@ rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 in return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' expr' bind_op fail_op))] + L loc (BindStmt pat' body' bind_op fail_op))] -rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _ +rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do +rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do (binds', du_binds) <- -- fixities and unused are handled above in rnRecStmtsAndThen rnLocalValBindsRHS (mkNameSet all_bndrs) binds' @@ -1053,21 +1050,26 @@ rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -- no RecStmt case becuase they get flattened above when doing the LHSes -rn_rec_stmt _ stmt@(L _ (RecStmt {})) _ +rn_rec_stmt _ _ stmt@(L _ (RecStmt {})) _ = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo +rn_rec_stmt _ _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo +rn_rec_stmt _ _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _ +rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds)) _ = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" -rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)] -rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts `thenM` \ segs_s -> - return (concat segs_s) +rn_rec_stmts :: Outputable (body RdrName) => + (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [Name] + -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] + -> RnM [Segment (LStmt Name (Located (body Name)))] +rn_rec_stmts rnBody bndrs stmts = + mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s -> + return (concat segs_s) --------------------------------------------- addFwdRefs :: [Segment a] -> [Segment a] @@ -1126,7 +1128,7 @@ addFwdRefs pairs -- See http://hackage.haskell.org/trac/ghc/ticket/4148 for -- the discussion leading to this design choice. -glomSegments :: HsStmtContext Name -> [Segment (LStmt Name)] -> [Segment [LStmt Name]] +glomSegments :: HsStmtContext Name -> [Segment (LStmt Name body)] -> [Segment [LStmt Name body]] glomSegments _ [] = [] glomSegments ctxt ((defs,uses,fwds,stmt) : segs) @@ -1157,10 +1159,10 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) ---------------------------------------------------- -segsToStmts :: Stmt Name -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt Name]] - -> FreeVars -- Free vars used 'later' - -> ([LStmt Name], FreeVars) +segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt Name body]] + -> FreeVars -- Free vars used 'later' + -> ([LStmt Name body], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1230,9 +1232,9 @@ emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'grou emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: HsStmtContext Name - -> LStmt RdrName - -> RnM (LStmt RdrName) +checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name + -> LStmt RdrName (Located (body RdrName)) + -> RnM (LStmt RdrName (Located (body RdrName))) checkLastStmt ctxt lstmt@(L loc stmt) = case ctxt of ListComp -> check_comp @@ -1243,9 +1245,9 @@ checkLastStmt ctxt lstmt@(L loc stmt) MDoExpr -> check_do _ -> check_other where - check_do -- Expect ExprStmt, and change it to LastStmt + check_do -- Expect BodyStmt, and change it to LastStmt = case stmt of - ExprStmt e _ _ _ -> return (L loc (mkLastStmt e)) + BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } @@ -1262,7 +1264,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name - -> LStmt RdrName + -> LStmt RdrName (Located (body RdrName)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -1273,10 +1275,10 @@ checkStmt ctxt (L _ stmt) msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") , ptext (sLit "in") <+> pprAStmtContext ctxt ] -pprStmtCat :: Stmt a -> SDoc +pprStmtCat :: Stmt a body -> SDoc pprStmtCat (TransStmt {}) = ptext (sLit "transform") pprStmtCat (LastStmt {}) = ptext (sLit "return expression") -pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion") +pprStmtCat (BodyStmt {}) = ptext (sLit "body") pprStmtCat (BindStmt {}) = ptext (sLit "binding") pprStmtCat (LetStmt {}) = ptext (sLit "let") pprStmtCat (RecStmt {}) = ptext (sLit "rec") @@ -1289,7 +1291,7 @@ notOK = Just empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName -> Maybe SDoc + -> Stmt RdrName (Located (body RdrName)) -> Maybe SDoc -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1300,17 +1302,17 @@ okStmt dflags ctxt stmt DoExpr -> okDoStmt dflags ctxt stmt MDoExpr -> okDoStmt dflags ctxt stmt ArrowExpr -> okDoStmt dflags ctxt stmt - GhciStmt -> okDoStmt dflags ctxt stmt + GhciStmtCtxt -> okDoStmt dflags ctxt stmt ListComp -> okCompStmt dflags ctxt stmt MonadComp -> okCompStmt dflags ctxt stmt PArrComp -> okPArrStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName -> Maybe SDoc +okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Maybe SDoc okPatGuardStmt stmt = case stmt of - ExprStmt {} -> isOK + BodyStmt {} -> isOK BindStmt {} -> isOK LetStmt {} -> isOK _ -> notOK @@ -1330,7 +1332,7 @@ okDoStmt dflags ctxt stmt | otherwise -> Just (ptext (sLit "Use -XRecursiveDo")) BindStmt {} -> isOK LetStmt {} -> isOK - ExprStmt {} -> isOK + BodyStmt {} -> isOK _ -> notOK ---------------- @@ -1338,7 +1340,7 @@ okCompStmt dflags _ stmt = case stmt of BindStmt {} -> isOK LetStmt {} -> isOK - ExprStmt {} -> isOK + BodyStmt {} -> isOK ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) @@ -1353,7 +1355,7 @@ okPArrStmt dflags _ stmt = case stmt of BindStmt {} -> isOK LetStmt {} -> isOK - ExprStmt {} -> isOK + BodyStmt {} -> isOK ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 70d891dcbf..0a00a9e2bc 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,17 +1,21 @@ \begin{code} module RnExpr where import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes +import SrcLoc ( Located ) +import Outputable ( Outputable ) rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) -rnStmts :: --forall thing. - HsStmtContext Name -> [LStmt RdrName] +rnStmts :: --forall thing body. + Outputable (body RdrName) => HsStmtContext Name + -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> [LStmt RdrName (Located (body RdrName))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) \end{code} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 57f75fb50d..c3b40fe0f2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -158,8 +158,8 @@ matchNameMaker ctxt = LamMk report_unused -- Do not report unused names in interactive contexts -- i.e. when you type 'x <- e' at the GHCi prompt report_unused = case ctxt of - StmtCtxt GhciStmt -> False - _ -> True + StmtCtxt GhciStmtCtxt -> False + _ -> True rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name)) rnHsSigCps sig diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index d9809239e2..f8bbc3d68e 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -654,15 +654,15 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged -> RnM (HsCmd Name) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _)) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsArrForm op2 (Just fix2) [a1, a2]) + return (HsCmdArrForm op2 (Just fix2) [a1, a2]) | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsArrForm op1 (Just fix1) + return (HsCmdArrForm op1 (Just fix1) [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) -- TODO: locs are wrong where @@ -670,7 +670,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _ -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsArrForm op (Just fix) [arg1, arg2]) + = return (HsCmdArrForm op (Just fix) [arg1, arg2]) -------------------------------------- @@ -699,7 +699,7 @@ not_op_pat (ConPatIn _ (InfixCon _ _)) = False not_op_pat _ = True -------------------------------------- -checkPrecMatch :: Name -> MatchGroup Name -> RnM () +checkPrecMatch :: Name -> MatchGroup Name body -> RnM () -- Check precedence of a function binding written infix -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 67b66fd579..dac8fd1367 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -334,9 +334,8 @@ tcSyntaxName :: CtOrigin -> TcType -- Type to instantiate it at -> (Name, HsExpr Name) -- (Standard name, user name) -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression) --- *** NOW USED ONLY FOR CmdTop (sigh) *** --- NB: tcSyntaxName calls tcExpr, and hence can do unification. --- So we do not call it from lookupInst, which is called from tcSimplify +-- USED ONLY FOR CmdTop (sigh) *** +-- See Note [CmdSyntaxTable] in HsExpr tcSyntaxName orig ty (std_nm, HsVar user_nm) | std_nm == user_nm diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 9d3d433a9b..f851e75206 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -99,42 +99,42 @@ tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty ---------------------------------------- -tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) +tcCmd :: CmdEnv -> LHsCmd Name -> (CmdStack, TcTauType) -> TcM (LHsCmd TcId) -- The main recursive function -tcCmd env (L loc expr) res_ty +tcCmd env (L loc cmd) res_ty = setSrcSpan loc $ do - { expr' <- tc_cmd env expr res_ty - ; return (L loc expr') } + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } -tc_cmd :: CmdEnv -> HsExpr Name -> (CmdStack, TcTauType) -> TcM (HsExpr TcId) -tc_cmd env (HsPar cmd) res_ty +tc_cmd :: CmdEnv -> HsCmd Name -> (CmdStack, TcTauType) -> TcM (HsCmd TcId) +tc_cmd env (HsCmdPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsPar cmd') } + ; return (HsCmdPar cmd') } -tc_cmd env (HsLet binds (L body_loc body)) res_ty +tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan body_loc $ tc_cmd env body res_ty - ; return (HsLet binds' (L body_loc body')) } + ; return (HsCmdLet binds' (L body_loc body')) } -tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) +tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do (scrut', scrut_ty) <- tcInferRho scrut matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty - return (HsCase scrut' matches') + return (HsCmdCase scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } mc_body body res_ty' = tcCmd env body (stk, res_ty') -tc_cmd env (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred boolTy ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsIf Nothing pred' b1' b2') + ; return (HsCmdIf Nothing pred' b1' b2') } -tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if +tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if = do { pred_ty <- newFlexiTyVarTy openTypeKind -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not @@ -148,14 +148,14 @@ tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if ; pred' <- tcMonoExpr pred pred_ty ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsIf (Just fun') pred' b1' b2') + ; return (HsCmdIf (Just fun') pred' b1' b2') } ------------------------------------------- -- Arrow application -- (f -< a) or (f -<< a) -tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty @@ -166,7 +166,7 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) ; arg' <- tcMonoExpr arg arg_ty - ; return (HsArrApp fun' arg' fun_ty ho_app lr) } + ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where -- Before type-checking f, use the environment of the enclosing -- proc for the (-<) case. @@ -179,7 +179,7 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) ------------------------------------------- -- Command application -tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind @@ -187,12 +187,12 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) ; arg' <- tcMonoExpr arg arg_ty - ; return (HsApp fun' arg') } + ; return (HsCmdApp fun' arg') } ------------------------------------------- -- Lambda -tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _)) +tc_cmd env cmd@(HsCmdLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] _)) (cmd_stk, res_ty) = addErrCtxt (pprMatchInCtxt match_ctxt match) $ @@ -206,7 +206,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig tc_grhss grhss res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') - ; return (HsLam (MatchGroup [match'] res_ty)) + ; return (HsCmdLam (MatchGroup [match'] res_ty)) } where @@ -228,10 +228,10 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdDo stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty - ; return (HsDo do_or_lc stmts' res_ty) } + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (HsCmdDo stmts' res_ty) } where @@ -245,7 +245,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) -- ---------------------------------------------- -- G |-a (| e c |) : [t1 .. tn] t -tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] ; (_, [w_tv]) <- tcInstSkolTyVars [alphaTyVar] @@ -285,9 +285,8 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; let wrap = {- mkWpLet (EvBinds outer_binds) <.> -} - WpTyLam w_tv <.> mkWpLet inner_binds - ; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') } + ; let wrap = WpTyLam w_tv <.> mkWpLet inner_binds + ; return (HsCmdArrForm (mkLHsWrap wrap expr') fixity cmds') } where -- Make the types -- b, ((e,s1) .. sm), s @@ -353,16 +352,16 @@ tc_cmd _ cmd _ -- (a) RecStmts, and -- (b) no rebindable syntax -tcArrDoStmt :: CmdEnv -> TcStmtChecker +tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside = do { rhs' <- tcCmd env rhs ([], res_ty) ; thing <- thing_inside (panic "tcArrDoStmt") ; return (LastStmt rhs' noSyntaxExpr, thing) } -tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside +tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside = do { (rhs', elt_ty) <- tc_arr_rhs env rhs ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_arr_rhs env rhs @@ -403,7 +402,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names tcArrDoStmt _ _ stmt _ _ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) -tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType) +tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCmd env rhs ([], ty) ; return (rhs', ty) } @@ -433,15 +432,15 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind %************************************************************************ \begin{code} -cmdCtxt :: HsExpr Name -> SDoc +cmdCtxt :: HsCmd Name -> SDoc cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd -nonEmptyCmdStkErr :: HsExpr Name -> SDoc +nonEmptyCmdStkErr :: HsCmd Name -> SDoc nonEmptyCmdStkErr cmd = hang (ptext (sLit "Non-empty command stack at command:")) 2 (ppr cmd) -kappaUnderflow :: HsExpr Name -> SDoc +kappaUnderflow :: HsCmd Name -> SDoc kappaUnderflow cmd = hang (ptext (sLit "Command stack underflow at command:")) 2 (ppr cmd) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 3f9f7cc4c2..cd010ef03c 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -998,8 +998,8 @@ tcMonoBinds top_lvl _ sig_fn no_gen binds -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name) - | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType + = TcFunBind MonoBindInfo SrcSpan Bool (MatchGroup Name (LHsExpr Name)) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) -- Type signature (if any), and @@ -1394,7 +1394,7 @@ strictBindErr flavour unlifted binds \begin{code} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc +patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss) \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d2ebc74ed6..e21eb4e4da 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -473,14 +473,6 @@ tcExpr (HsDo do_or_lc stmts _) res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCo coi (HsProc pat' cmd') } - -tcExpr e@(HsArrApp _ _ _ _ _) _ - = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), - ptext (sLit "was found where an expression was expected")]) - -tcExpr e@(HsArrForm _ _ _) _ - = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), - ptext (sLit "was found where an expression was expected")]) \end{code} Note [Rebindable syntax for if] @@ -847,6 +839,7 @@ tcExpr e@(HsQuasiQuoteE _) _ = \begin{code} tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) + -- Include ArrForm, ArrApp, which shouldn't appear at all \end{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index e5baaeca9f..0b3dfaee38 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -391,7 +391,7 @@ gen_Ord_binds loc tycon ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)]) - mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName + mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) -- Make the alternative (Ki a1 a2 .. av -> mkOrdOpAlt op data_con = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con) @@ -436,7 +436,7 @@ gen_Ord_binds loc tycon tag = get_tag data_con tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag))) - mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName + mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) -- First argument 'a' known to be built with K -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...) mkInnerEqAlt op data_con @@ -1604,7 +1604,8 @@ mkSimpleLam2 lam = do return (mkHsLam [nlVarPat n1,nlVarPat n2] body) -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName) +mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] + -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName (LHsExpr RdrName)) mkSimpleConMatch fold extra_pats con insides = do let con_name = getRdrName con let vars_needed = takeList insides as_RDRs @@ -1613,7 +1614,8 @@ mkSimpleConMatch fold extra_pats con insides = do return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" -mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)) +mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] + -> m (LMatch RdrName (LHsExpr RdrName))) -> TupleSort -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName) mkSimpleTupleCase match_for_con sort insides x = do let con = tupleCon sort (length insides) @@ -1863,7 +1865,7 @@ mk_FunBind loc fun pats_and_exprs where matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName +mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName mkRdrFunBind fun@(L _ fun_rdr) matches | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds] -- Catch-all eqn looks like diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index ab784eca67..92d2a5c96e 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -429,7 +429,7 @@ zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id) zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; sig_warn False (collectPatBinders new_pat) - ; new_grhss <- zonkGRHSs env grhss + ; new_grhss <- zonkGRHSs env zonkLExpr grhss ; new_ty <- zonkTcTypeToType env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } @@ -444,7 +444,7 @@ zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms = do { new_var <- zonkIdBndr env var ; sig_warn False [new_var] ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 ms + ; new_ms <- zonkMatchGroup env1 zonkLExpr ms ; return (bind { fun_id = L loc new_var, fun_matches = new_ms , fun_co_fn = new_co_fn }) } @@ -495,28 +495,34 @@ zonkLTcSpecPrags env ps %************************************************************************ \begin{code} -zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id) -zonkMatchGroup env (MatchGroup ms ty) - = do { ms' <- mapM (zonkMatch env) ms +zonkMatchGroup :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) +zonkMatchGroup env zBody (MatchGroup ms ty) + = do { ms' <- mapM (zonkMatch env zBody) ms ; ty' <- zonkTcTypeToType env ty ; return (MatchGroup ms' ty') } -zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) -zonkMatch env (L loc (Match pats _ grhss)) +zonkMatch :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) +zonkMatch env zBody (L loc (Match pats _ grhss)) = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 grhss + ; new_grhss <- zonkGRHSs env1 zBody grhss ; return (L loc (Match new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) +zonkGRHSs :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) -zonkGRHSs env (GRHSs grhss binds) +zonkGRHSs env zBody (GRHSs grhss binds) = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded rhs) - = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) -> - zonkLExpr env2 rhs `thenM` \ new_rhs -> - returnM (GRHS new_guarded new_rhs) + zonk_grhs (GRHS guarded rhs) + = zonkStmts new_env zonkLExpr guarded `thenM` \ (env2, new_guarded) -> + zBody env2 rhs `thenM` \ new_rhs -> + returnM (GRHS new_guarded new_rhs) in mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> returnM (GRHSs new_grhss new_binds) @@ -554,12 +560,12 @@ zonkExpr env (HsOverLit lit) ; return (HsOverLit lit') } zonkExpr env (HsLam matches) - = zonkMatchGroup env matches `thenM` \ new_matches -> + = zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches -> returnM (HsLam new_matches) zonkExpr env (HsLamCase arg matches) - = zonkTcTypeToType env arg `thenM` \ new_arg -> - zonkMatchGroup env matches `thenM` \ new_matches -> + = zonkTcTypeToType env arg `thenM` \ new_arg -> + zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches -> returnM (HsLamCase new_arg new_matches) zonkExpr env (HsApp e1 e2) @@ -610,8 +616,8 @@ zonkExpr env (ExplicitTuple tup_args boxed) zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') } zonkExpr env (HsCase expr ms) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkMatchGroup env ms `thenM` \ new_ms -> + = zonkLExpr env expr `thenM` \ new_expr -> + zonkMatchGroup env zonkLExpr ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) zonkExpr env (HsIf e0 e1 e2 e3) @@ -626,7 +632,7 @@ zonkExpr env (HsMultiIf ty alts) ; ty' <- zonkTcTypeToType env ty ; returnM $ HsMultiIf ty' alts' } where zonk_alt (GRHS guard expr) - = do { (env', guard') <- zonkStmts env guard + = do { (env', guard') <- zonkStmts env zonkLExpr guard ; expr' <- zonkLExpr env' expr ; returnM $ GRHS guard' expr' } @@ -636,8 +642,8 @@ zonkExpr env (HsLet binds expr) returnM (HsLet new_binds new_expr) zonkExpr env (HsDo do_or_lc stmts ty) - = zonkStmts env stmts `thenM` \ (_, new_stmts) -> - zonkTcTypeToType env ty `thenM` \ new_ty -> + = zonkStmts env zonkLExpr stmts `thenM` \ (_, new_stmts) -> + zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) @@ -697,17 +703,6 @@ zonkExpr env (HsProc pat body) ; new_body <- zonkCmdTop env1 body ; return (HsProc new_pat new_body) } -zonkExpr env (HsArrApp e1 e2 ty ho rl) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsArrApp new_e1 new_e2 new_ty ho rl) - -zonkExpr env (HsArrForm op fixity args) - = zonkLExpr env op `thenM` \ new_op -> - mappM (zonkCmdTop env) args `thenM` \ new_args -> - returnM (HsArrForm new_op fixity new_args) - zonkExpr env (HsWrap co_fn expr) = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> zonkExpr env1 expr `thenM` \ new_expr -> @@ -718,12 +713,69 @@ zonkExpr _ HsHole zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) +------------------------------------------------------------------------- + +zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id) +zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id) + +zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd + +zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsCmdArrApp new_e1 new_e2 new_ty ho rl) + +zonkCmd env (HsCmdArrForm op fixity args) + = zonkLExpr env op `thenM` \ new_op -> + mappM (zonkCmdTop env) args `thenM` \ new_args -> + returnM (HsCmdArrForm new_op fixity new_args) + +zonkCmd env (HsCmdApp c e) + = zonkLCmd env c `thenM` \ new_c -> + zonkLExpr env e `thenM` \ new_e -> + returnM (HsCmdApp new_c new_e) + +zonkCmd env (HsCmdLam matches) + = zonkMatchGroup env zonkLCmd matches `thenM` \ new_matches -> + returnM (HsCmdLam new_matches) + +zonkCmd env (HsCmdPar c) + = zonkLCmd env c `thenM` \new_c -> + returnM (HsCmdPar new_c) + +zonkCmd env (HsCmdCase expr ms) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkMatchGroup env zonkLCmd ms `thenM` \ new_ms -> + returnM (HsCmdCase new_expr new_ms) + +zonkCmd env (HsCmdIf eCond ePred cThen cElse) + = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond + ; new_ePred <- zonkLExpr env ePred + ; new_cThen <- zonkLCmd env cThen + ; new_cElse <- zonkLCmd env cElse + ; returnM (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd env (HsCmdLet binds cmd) + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> + zonkLCmd new_env cmd `thenM` \ new_cmd -> + returnM (HsCmdLet new_binds new_cmd) + +zonkCmd env (HsCmdDo stmts ty) + = zonkStmts env zonkLCmd stmts `thenM` \ (_, new_stmts) -> + zonkTcTypeToType env ty `thenM` \ new_ty -> + returnM (HsCmdDo new_stmts new_ty) + + + + + zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) - = zonkLExpr env cmd `thenM` \ new_cmd -> + = zonkLCmd env cmd `thenM` \ new_cmd -> zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys -> zonkTcTypeToType env ty `thenM` \ new_ty -> mapSndM (zonkExpr env) ids `thenM` \ new_ids -> @@ -781,14 +833,18 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) -zonkStmts env [] = return (env, []) -zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s - ; (env2, ss') <- zonkStmts env1 ss - ; return (env2, s' : ss') } - -zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) -zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op) +zonkStmts :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))]) +zonkStmts env _ [] = return (env, []) +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s + ; (env2, ss') <- zonkStmts env1 zBody ss + ; return (env2, s' : ss') } + +zonkStmt :: ZonkEnv + -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) + -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) +zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op) = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] env1 = extendIdZonkEnv env new_binders @@ -797,14 +853,14 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op) ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } where zonk_branch (ParStmtBlock stmts bndrs return_op) - = do { (env1, new_stmts) <- zonkStmts env stmts + = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_return <- zonkExpr env1 return_op ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } -zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_later_rets = later_rets, recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty }) +zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id + , recS_later_rets = later_rets, recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs ; new_ret_ty <- zonkTcTypeToType env ret_ty @@ -812,7 +868,7 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id ; let env1 = extendIdZonkEnv env new_rvs - ; (env2, new_segStmts) <- zonkStmts env1 segStmts + ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_later_rets <- mapM (zonkExpr env2) later_rets @@ -824,22 +880,22 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id , recS_later_rets = new_later_rets , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } -zonkStmt env (ExprStmt expr then_op guard_op ty) - = zonkLExpr env expr `thenM` \ new_expr -> +zonkStmt env zBody (BodyStmt body then_op guard_op ty) + = zBody env body `thenM` \ new_body -> zonkExpr env then_op `thenM` \ new_then -> zonkExpr env guard_op `thenM` \ new_guard -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_then new_guard new_ty) + returnM (env, BodyStmt new_body new_then new_guard new_ty) -zonkStmt env (LastStmt expr ret_op) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkExpr env ret_op `thenM` \ new_ret -> - returnM (env, LastStmt new_expr new_ret) +zonkStmt env zBody (LastStmt body ret_op) + = zBody env body `thenM` \ new_body -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_body new_ret) -zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) - = do { (env', stmts') <- zonkStmts env stmts +zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) + = do { (env', stmts') <- zonkStmts env zonkLExpr stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap ; by' <- fmapMaybeM (zonkLExpr env') by ; using' <- zonkLExpr env using @@ -856,16 +912,16 @@ zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env (LetStmt binds) +zonkStmt env _ (LetStmt binds) = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) -zonkStmt env (BindStmt pat expr bind_op fail_op) - = do { new_expr <- zonkLExpr env expr +zonkStmt env zBody (BindStmt pat body bind_op fail_op) + = do { new_body <- zBody env body ; (env1, new_pat) <- zonkPat env pat ; new_bind <- zonkExpr env bind_op ; new_fail <- zonkExpr env fail_op - ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } + ; return (env1, BindStmt new_pat new_body new_bind new_fail) } ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index acc20649c0..5a00470caf 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -13,10 +13,10 @@ TcMatches: Typecheck some @Matches@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module TcMatches ( tcMatchesFun, tcGRHSsPat, tcGRHS, tcMatchesCase, - tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, - tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcGuardStmt +module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda, + TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, + tcDoStmt, tcGuardStmt ) where import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, @@ -69,9 +69,10 @@ See Note [sig_tau may be polymorphic] in TcPat. \begin{code} tcMatchesFun :: Name -> Bool - -> MatchGroup Name - -> TcSigmaType -- Expected type of function - -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body + -> MatchGroup Name (LHsExpr Name) + -> TcSigmaType -- Expected type of function + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) + -- Returns type of body tcMatchesFun fun_name inf matches exp_ty = do { -- Check that they all have the same no of arguments -- Location is in the monad, set the caller so that @@ -99,11 +100,12 @@ tcMatchesFun fun_name inf matches exp_ty parser guarantees that each equation has exactly one argument. \begin{code} -tcMatchesCase :: TcMatchCtxt -- Case context - -> TcRhoType -- Type of scrutinee - -> MatchGroup Name -- The case alternatives - -> TcRhoType -- Type of whole case expressions - -> TcM (MatchGroup TcId) -- Translated alternatives +tcMatchesCase :: (Outputable (body Name)) => + TcMatchCtxt body -- Case context + -> TcRhoType -- Type of scrutinee + -> MatchGroup Name (Located (body Name)) -- The case alternatives + -> TcRhoType -- Type of whole case expressions + -> TcM (MatchGroup TcId (Located (body TcId))) -- Translated alternatives tcMatchesCase ctxt scrut_ty matches res_ty | isEmptyMatchGroup matches -- Allow empty case expressions @@ -112,7 +114,8 @@ tcMatchesCase ctxt scrut_ty matches res_ty | otherwise = tcMatches ctxt [scrut_ty] res_ty matches -tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId) +tcMatchLambda :: MatchGroup Name (LHsExpr Name) -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) tcMatchLambda match res_ty = matchFunTys herald n_pats res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match @@ -130,7 +133,8 @@ tcMatchLambda match res_ty @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. \begin{code} -tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId) +tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType + -> TcM (GRHSs TcId (LHsExpr TcId)) -- Used for pattern bindings tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty where @@ -163,18 +167,18 @@ matchFunTys herald arity res_ty thing_inside %************************************************************************ \begin{code} -tcMatches :: TcMatchCtxt - -> [TcSigmaType] -- Expected pattern types - -> TcRhoType -- Expected result-type of the Match. - -> MatchGroup Name - -> TcM (MatchGroup TcId) - -data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is - mc_body :: LHsExpr Name -- Type checker for a body of +tcMatches :: (Outputable (body Name)) => TcMatchCtxt body + -> [TcSigmaType] -- Expected pattern types + -> TcRhoType -- Expected result-type of the Match. + -> MatchGroup Name (Located (body Name)) + -> TcM (MatchGroup TcId (Located (body TcId))) + +data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + mc_body :: Located (body Name) -- Type checker for a body of -- an alternative - -> TcRhoType - -> TcM (LHsExpr TcId) } + -> TcRhoType + -> TcM (Located (body TcId)) } tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) = ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in @@ -182,11 +186,11 @@ tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) } ------------- -tcMatch :: TcMatchCtxt - -> [TcSigmaType] -- Expected pattern types - -> TcRhoType -- Expected result-type of the Match. - -> LMatch Name - -> TcM (LMatch TcId) +tcMatch :: (Outputable (body Name)) => TcMatchCtxt body + -> [TcSigmaType] -- Expected pattern types + -> TcRhoType -- Expected result-type of the Match. + -> LMatch Name (Located (body Name)) + -> TcM (LMatch TcId (Located (body TcId))) tcMatch ctxt pat_tys rhs_ty match = wrapLocM (tc_match ctxt pat_tys rhs_ty) match @@ -212,8 +216,8 @@ tcMatch ctxt pat_tys rhs_ty match m_ctxt -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType - -> TcM (GRHSs TcId) +tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType + -> TcM (GRHSs TcId (Located (body TcId))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like @@ -228,7 +232,8 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty ; return (GRHSs grhss' binds') } ------------- -tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId) +tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name)) + -> TcM (GRHS TcId (Located (body TcId))) tcGRHS ctxt res_ty (GRHS guards rhs) = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ @@ -247,7 +252,7 @@ tcGRHS ctxt res_ty (GRHS guards rhs) \begin{code} tcDoStmts :: HsStmtContext Name - -> [LStmt Name] + -> [LStmt Name (LHsExpr Name)] -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp stmts res_ty @@ -292,29 +297,33 @@ tcBody body res_ty %************************************************************************ \begin{code} -type TcStmtChecker + +type TcExprStmtChecker = TcStmtChecker HsExpr +type TcCmdStmtChecker = TcStmtChecker HsCmd + +type TcStmtChecker body = forall thing. HsStmtContext Name - -> Stmt Name - -> TcRhoType -- Result type for comprehension - -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt TcId, thing) - -tcStmts :: HsStmtContext Name - -> TcStmtChecker -- NB: higher-rank type - -> [LStmt Name] - -> TcRhoType - -> TcM [LStmt TcId] + -> Stmt Name (Located (body Name)) + -> TcRhoType -- Result type for comprehension + -> (TcRhoType -> TcM thing) -- Checker for what follows the stmt + -> TcM (Stmt TcId (Located (body TcId)), thing) + +tcStmts :: (Outputable (body Name)) => HsStmtContext Name + -> TcStmtChecker body -- NB: higher-rank type + -> [LStmt Name (Located (body Name))] + -> TcRhoType + -> TcM [LStmt TcId (Located (body TcId))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ()) ; return stmts' } -tcStmtsAndThen :: HsStmtContext Name - -> TcStmtChecker -- NB: higher-rank type - -> [LStmt Name] - -> TcRhoType - -> (TcRhoType -> TcM thing) - -> TcM ([LStmt TcId], thing) +tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name + -> TcStmtChecker body -- NB: higher-rank type + -> [LStmt Name (Located (body Name))] + -> TcRhoType + -> (TcRhoType -> TcM thing) + -> TcM ([LStmt TcId (Located (body TcId))], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts @@ -344,11 +353,11 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside -- Pattern guards --------------------------------------------------- -tcGuardStmt :: TcStmtChecker -tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside +tcGuardStmt :: TcExprStmtChecker +tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside = do { guard' <- tcMonoExpr guard boolTy ; thing <- thing_inside res_ty - ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } + ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already @@ -374,8 +383,8 @@ tcGuardStmt _ stmt _ _ -- coercion matching stuff in them. It's hard to avoid the -- potential for non-trivial coercions in tcMcStmt -tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) - -> TcStmtChecker +tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) + -> TcExprStmtChecker tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside = do { body' <- tcMonoExprNC body elt_ty @@ -391,10 +400,10 @@ tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard -tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside +tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside = do { rhs' <- tcMonoExpr rhs boolTy ; thing <- thing_inside elt_ty - ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } -- ParStmt: See notes with tcMcStmt tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside @@ -482,7 +491,7 @@ tcLcStmt _ _ stmt _ _ -- (supports rebindable syntax) --------------------------------------------------- -tcMcStmt :: TcStmtChecker +tcMcStmt :: TcExprStmtChecker tcMcStmt _ (LastStmt body return_op) res_ty thing_inside = do { a_ty <- newFlexiTyVarTy liftedTypeKind @@ -522,7 +531,7 @@ tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside -- -- [ body | stmts, expr ] -> expr :: m Bool -- -tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside +tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside = do { -- Deal with rebindable syntax: -- guard_op :: test_ty -> rhs_ty -- then_op :: rhs_ty -> new_res_ty -> res_ty @@ -536,7 +545,7 @@ tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside ; then_op' <- tcSyntaxOp MCompOrigin then_op (mkFunTys [rhs_ty, new_res_ty] res_ty) ; thing <- thing_inside new_res_ty - ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) } + ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) } -- Grouping statements -- @@ -731,7 +740,7 @@ tcMcStmt _ stmt _ _ -- (supports rebindable syntax) --------------------------------------------------- -tcDoStmt :: TcStmtChecker +tcDoStmt :: TcExprStmtChecker tcDoStmt _ (LastStmt body _) res_ty thing_inside = do { body' <- tcMonoExprNC body res_ty @@ -767,7 +776,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } -tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside +tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty -- See also Note [Treat rebindable syntax first] @@ -778,7 +787,7 @@ tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside ; rhs' <- tcMonoExprNC rhs rhs_ty ; thing <- thing_inside new_res_ty - ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } + ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op @@ -845,7 +854,7 @@ the expected/inferred stuff is back to front (see Trac #3613). number of args are used in each equation. \begin{code} -checkArgs :: Name -> MatchGroup Name -> TcM () +checkArgs :: Name -> MatchGroup Name body -> TcM () checkArgs fun (MatchGroup (match1:matches) _) | null bad_matches = return () | otherwise @@ -857,7 +866,7 @@ checkArgs fun (MatchGroup (match1:matches) _) n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] - args_in_match :: LMatch Name -> Int + args_in_match :: LMatch Name body -> Int args_in_match (L _ (Match pats _ _)) = length pats checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty \end{code} diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot index 8c421da6da..1fe05ec1e5 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.lhs-boot @@ -1,17 +1,18 @@ \begin{code} module TcMatches where -import HsSyn ( GRHSs, MatchGroup ) +import HsSyn ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name ( Name ) import TcType ( TcRhoType ) import TcRnTypes( TcM, TcId ) +--import SrcLoc ( Located ) -tcGRHSsPat :: GRHSs Name +tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType - -> TcM (GRHSs TcId) + -> TcM (GRHSs TcId (LHsExpr TcId)) tcMatchesFun :: Name -> Bool - -> MatchGroup Name + -> MatchGroup Name (LHsExpr Name) -> TcRhoType - -> TcM (HsWrapper, MatchGroup TcId) + -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId)) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 18f7951ef7..6430c95862 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1201,7 +1201,7 @@ setInteractiveContext hsc_env icxt thing_inside -- -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). -tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName +tcRnStmt :: HscEnv -> InteractiveContext -> GhciLStmt RdrName -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv)) tcRnStmt hsc_env ictxt rdr_stmt = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1312,10 +1312,10 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p -- for more details. We do this lifting by trying different ways ('plans') of -- lifting the code into the IO monad and type checking each plan until one -- succeeds. -tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv) +tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (ExprStmt expr _ _ _)) +tcUserStmt (L loc (BodyStmt expr _ _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO @@ -1339,7 +1339,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) (HsVar bindIOName) noSyntaxExpr -- [; print it] - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) + print_it = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: @@ -1375,7 +1375,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmt [rdr_stmt] $ \_ -> do + rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv return (fix_env, emptyFVs) -- Don't try to typecheck if the renamer fails! @@ -1407,19 +1407,19 @@ tcUserStmt rdr_stmt@(L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) (HsVar thenIOName) noSyntaxExpr placeHolderType -- | Typecheck the statements given and then return the results of the -- statement in the form 'IO [()]'. -tcGhciStmts :: [LStmt Name] -> TcM PlanResult +tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; ret_id <- tcLookupId returnIOName ; -- return @ IO let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; + tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ; names = collectLStmtsBinders stmts ; } ; @@ -1455,7 +1455,7 @@ tcGhciStmts stmts stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt stmts io_ret_ty)) + noLoc (HsDo GhciStmtCtxt stmts io_ret_ty)) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) |