diff options
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) |