From: Simon Peyton Jones Date: Wed, 4 May 2011 14:44:42 +0000 (+0100) Subject: Final batch of monad-comprehension stuff X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3bb700d515de2405fa5db3326482e529f332d508 Final batch of monad-comprehension stuff * Do-notation in arrows is marked with HsStmtContext = ArrowExpr * tcMDoStmt (which was only used for arrows) is moved to TcArrows, and renamed tcArrDoStmt * Improved documentation in the user manual * Lots of other minor changes --- diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 57455c4..8071da7 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -431,7 +431,7 @@ addTickLStmts' isGuard lstmts res addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) addTickStmt _isGuard (LastStmt e ret) = do liftM2 LastStmt - (addTickLHsExprAlways e) + (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt pat e bind fail) = do liftM4 BindStmt @@ -633,6 +633,10 @@ addTickCmdStmt (BindStmt pat c bind fail) = do (addTickLHsCmd c) (return bind) (return fail) +addTickCmdStmt (LastStmt c ret) = do + liftM2 LastStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan ret) addTickCmdStmt (ExprStmt c bind' guard' ty) = do liftM4 ExprStmt (addTickLHsCmd c) diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 0d3adbc..aabd6b0 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -120,7 +120,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list - inner_list_expr = mkApps usingExpr' (Type from_tup_ty : usingArgs) + inner_list_expr = mkApps usingExpr' usingArgs -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and -- the "b" to be a tuple of "to" lists! @@ -861,11 +861,11 @@ mkMcUnzipM ThenForm _ ys _ mkMcUnzipM _ fmap_op ys elt_tys = do { fmap_op' <- dsExpr fmap_op ; xs <- mapM newSysLocalDs elt_tys - ; tup_xs <- newSysLocalDs (mkBigCoreTupTy elt_tys) - - ; let arg_ty = idType ys - mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b - [ Type arg_ty, Type (elt_tys !! i) + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalDs tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (elt_tys !! i) , mk_sel i, Var ys] mk_sel n = Lam tup_xs $ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 6dd1381..9c88783 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1116,6 +1116,7 @@ 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 = pa_brackets $ pprComp stmts @@ -1261,32 +1262,28 @@ data HsStmtContext id | DoExpr -- do { ... } | MDoExpr -- mdo { ... } ie recursive do-expression + | ArrowExpr -- do-notation in an arrow-command context | GhciStmt -- 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 - | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt deriving (Data, Typeable) \end{code} \begin{code} -isDoExpr :: HsStmtContext id -> Bool -isDoExpr DoExpr = True -isDoExpr MDoExpr = True -isDoExpr GhciStmt = True -isDoExpr _ = False - isListCompExpr :: HsStmtContext id -> Bool +-- Uses syntax [ e | quals ] isListCompExpr ListComp = True isListCompExpr PArrComp = True isListCompExpr MonadComp = True isListCompExpr _ = False isMonadCompExpr :: HsStmtContext id -> Bool -isMonadCompExpr MonadComp = True -isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt -isMonadCompExpr (TransformStmtCtxt ctxt) = isMonadCompExpr ctxt -isMonadCompExpr _ = False +isMonadCompExpr MonadComp = True +isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr _ = False \end{code} \begin{code} @@ -1340,6 +1337,7 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt pprStmtContext GhciStmt = 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") pprStmtContext ListComp = ptext (sLit "list comprehension") pprStmtContext MonadComp = ptext (sLit "monad comprehension") pprStmtContext PArrComp = ptext (sLit "array comprehension") @@ -1353,7 +1351,7 @@ pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchCon pprStmtContext (ParStmtCtxt c) | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] | otherwise = pprStmtContext c -pprStmtContext (TransformStmtCtxt c) +pprStmtContext (TransStmtCtxt c) | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] | otherwise = pprStmtContext c @@ -1367,15 +1365,16 @@ matchContextErrString RecUpd = ptext (sLit "record update") matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") -matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") -matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") -matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression") -matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") -matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") -matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") +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 DoExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") +matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") +matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") +matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") \end{code} \begin{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 40a2a52..b3458db 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -440,8 +440,9 @@ convertOpFormsCmd (HsIf f exp c1 c2) convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) -convertOpFormsCmd (HsDo ctxt stmts ty) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty +convertOpFormsCmd (HsDo DoExpr stmts ty) + = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty + -- Mark the HsDo as begin the body of an arrow command -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@ -582,14 +583,16 @@ rnArithSeq (FromThenTo expr1 expr2 expr3) \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr n) = do { name <- lookupOccRn n - ; this_mod <- getModule - ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the - ; return () } -- only way that is going to happen - ; return (VarBr name, unitFV name) } - where - msg = ptext (sLit "Need interface for Template Haskell quoted Name") +rnBracket (VarBr n) + = do { name <- lookupOccRn n + ; this_mod <- getModule + ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes + do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and + ; return () } -- this is the only way that is going + -- to happen + ; return (VarBr name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } @@ -619,7 +622,8 @@ rnBracket (DecBrL decls) rnSrcDecls group -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env)))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" @@ -676,19 +680,20 @@ rnStmt :: HsStmtContext Name -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt _ (L loc (LastStmt expr _)) thing_inside +rnStmt ctxt (L loc (LastStmt expr _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr - ; (ret_op, fvs1) <- lookupSyntaxName returnMName - ; (thing, fvs3) <- thing_inside [] + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] ; return (([L loc (LastStmt expr' ret_op)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr - ; (then_op, fvs1) <- lookupSyntaxName thenMName - ; (guard_op, fvs2) <- if isMonadCompExpr ctxt - then lookupSyntaxName guardMName - else return (noSyntaxExpr, emptyFVs) + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' ; (thing, fvs3) <- thing_inside [] ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } @@ -696,8 +701,8 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; (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), @@ -710,7 +715,7 @@ rnStmt _ (L loc (LetStmt binds)) thing_inside { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } -rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside +rnStmt ctxt (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 @@ -726,9 +731,9 @@ rnStmt _ (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupSyntaxName returnMName - ; (mfix_op, fvs2) <- lookupSyntaxName mfixName - ; (bind_op, fvs3) <- lookupSyntaxName bindMName + ; (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName ; let -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref @@ -754,13 +759,9 @@ rnStmt _ (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 - = do { ((mzip_op, fvs1), (bind_op, fvs2), (return_op, fvs3)) <- if isMonadCompExpr ctxt - then (,,) <$> lookupSyntaxName mzipName - <*> lookupSyntaxName bindMName - <*> lookupSyntaxName returnMName - else return ( (noSyntaxExpr, emptyFVs) - , (noSyntaxExpr, emptyFVs) - , (noSyntaxExpr, emptyFVs) ) + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } @@ -768,31 +769,29 @@ rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside 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 - let implicit_name | isMonadCompExpr ctxt = groupMName - | otherwise = groupWithName - ; (using', fvs1) <- case form of - GroupFormB -> do { (e,fvs) <- lookupSyntaxName implicit_name - ; return (noLoc e, fvs) } + (using', fvs1) <- case form of + GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName + ; return (noLoc e, fvs) } _ -> rnLExpr using -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing used_bndrs = filter (`elemNameSet` fvs) bndrs - -- The paper (Fig 5) has a bug here; we must treat any free varaible of - -- the "thing inside", **or of the by-expression**, as used + -- The paper (Fig 5) has a bug here; we must treat any free varaible + -- of the "thing inside", **or of the by-expression**, as used ; return ((by', used_bndrs, thing), fvs) } -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions - ; (return_op, fvs3) <- lookupSyntaxName returnMName - ; (bind_op, fvs4) <- lookupSyntaxName bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName ; (fmap_op, fvs5) <- case form of ThenForm -> return (noSyntaxExpr, emptyFVs) - _ -> lookupSyntaxName fmapName + _ -> lookupStmtName ctxt fmapName ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4 `plusFV` fvs5 @@ -839,6 +838,12 @@ rnParallelStmts ctxt segs thing_inside cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") <+> quotes (ppr (head vs))) + +lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable +lookupStmtName ListComp n = return (HsVar n, emptyFVs) +lookupStmtName PArrComp n = return (HsVar n, emptyFVs) +lookupStmtName _ n = lookupSyntaxName n \end{code} Note [Renaming parallel Stmts] @@ -1172,9 +1177,9 @@ okEmpty (PatGuard {}) = True okEmpty _ = False emptyErr :: HsStmtContext Name -> SDoc -emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") -emptyErr (TransformStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") -emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt +emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") +emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") +emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------------------- checkLastStmt :: HsStmtContext Name @@ -1185,6 +1190,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) ListComp -> check_comp MonadComp -> check_comp PArrComp -> check_comp + ArrowExpr -> check_do DoExpr -> check_do MDoExpr -> check_do _ -> check_other @@ -1233,42 +1239,52 @@ isOK, notOK :: Maybe SDoc isOK = Nothing notOK = Just empty -okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName -> Maybe SDoc +okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt + :: DynFlags -> HsStmtContext Name + -> Stmt 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 -okStmt _ (PatGuard {}) stmt + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmt -> 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 = case stmt of ExprStmt {} -> isOK BindStmt {} -> isOK LetStmt {} -> isOK _ -> notOK -okStmt dflags (ParStmtCtxt ctxt) stmt +------------- +okParStmt dflags ctxt stmt = case stmt of LetStmt (HsIPBinds {}) -> notOK _ -> okStmt dflags ctxt stmt -okStmt dflags (TransformStmtCtxt ctxt) stmt - = okStmt dflags ctxt stmt - -okStmt dflags ctxt stmt - | isDoExpr ctxt = okDoStmt dflags ctxt stmt - | isListCompExpr ctxt = okCompStmt dflags ctxt stmt - | otherwise = pprPanic "okStmt" (pprStmtContext ctxt) - ---------------- -okDoStmt dflags _ stmt +okDoStmt dflags ctxt stmt = case stmt of - RecStmt {} + RecStmt {} | Opt_DoRec `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use -XDoRec")) + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | otherwise -> Just (ptext (sLit "Use -XDoRec")) BindStmt {} -> isOK LetStmt {} -> isOK ExprStmt {} -> isOK _ -> notOK - ---------------- okCompStmt dflags _ stmt = case stmt of @@ -1281,8 +1297,21 @@ okCompStmt dflags _ stmt TransStmt {} | Opt_TransformListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) - LastStmt {} -> notOK RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + +---------------- +okPArrStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} -> notOK + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 5d92738..cfbdf35 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -7,7 +7,7 @@ Typecheck arrow notation \begin{code} module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn import TcMatches @@ -17,7 +17,9 @@ import TcBinds import TcPat import TcUnify import TcRnMonad +import TcEnv import Coercion +import Id( mkLocalId ) import Inst import Name import TysWiredIn @@ -83,20 +85,12 @@ tcCmdTop :: CmdEnv tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty = setSrcSpan loc $ - do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty + do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- -tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack - -> TcTauType -> TcM (LHsExpr TcId) --- A wrapper that deals with the refinement (if any) -tcGuardedCmd env expr stk res_ty - = do { body <- tcCmd env expr (stk, res_ty) - ; return body - } - tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function tcCmd env (L loc expr) res_ty @@ -123,7 +117,7 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } - mc_body body res_ty' = tcGuardedCmd env body stk res_ty' + mc_body body res_ty' = tcCmd env body (stk, res_ty') tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty) = do { pred_ty <- newFlexiTyVarTy openTypeKind @@ -207,7 +201,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig tc_grhs res_ty (GRHS guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - tcGuardedCmd env body stk' + \ res_ty -> tcCmd env body (stk', res_ty) ; return (GRHS guards' rhs') } ------------------------------------------- @@ -215,12 +209,9 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; stmts' <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty + ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty ; return (HsDo do_or_lc stmts' res_ty) } where - tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs ([], ty) - ; return (rhs', ty) } ----------------------------------------------------------------- @@ -306,6 +297,69 @@ tc_cmd _ cmd _ %************************************************************************ %* * + Stmts +%* * +%************************************************************************ + +\begin{code} +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcStmtChecker +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 + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (ExprStmt 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 + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside res_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames + , recS_rec_ids = recNames }) res_ty thing_inside + = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind + ; let rec_ids = zipWith mkLocalId recNames rec_tys + ; tcExtendIdEnv rec_ids $ do + { (stmts', (later_ids, rec_rets)) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + do { rec_rets <- zipWithM tcCheckId recNames rec_tys + ; later_ids <- tcLookupLocalIds laterNames + ; return (later_ids, rec_rets) } + + ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) + + ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets + , recS_ret_ty = res_ty }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs ([], ty) + ; return (rhs', ty) } +\end{code} + + +%************************************************************************ +%* * Helpers %* * %************************************************************************ diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 579e5d4..48fdf77 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -6,10 +6,11 @@ TcMatches: Typecheck some @Matches@ \begin{code} +{-# OPTIONS_GHC -w #-} -- debugging module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), + TcMatchCtxt(..), TcStmtChecker, tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, - tcDoStmt, tcMDoStmt, tcGuardStmt + tcDoStmt, tcGuardStmt ) where import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, @@ -29,7 +30,7 @@ import TysWiredIn import Id import TyCon import TysPrim -import Coercion ( mkSymCoI ) +import Coercion ( isIdentityCoI, mkSymCoI ) import Outputable import Util import SrcLoc @@ -245,15 +246,15 @@ tcDoStmts :: HsStmtContext Name -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; let list_ty = mkListTy elt_ty ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty - ; return $ mkHsWrapCoI coi - (HsDo ListComp stmts' (mkListTy elt_ty)) } + ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' list_ty) } tcDoStmts PArrComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; let parr_ty = mkPArrTy elt_ty ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty - ; return $ mkHsWrapCoI coi - (HsDo PArrComp stmts' (mkPArrTy elt_ty)) } + ; return $ mkHsWrapCoI coi (HsDo PArrComp stmts' parr_ty) } tcDoStmts DoExpr stmts res_ty = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty @@ -333,8 +334,10 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside thing_inside ; return (L loc stmt' : stmts', thing) } --------------------------------- --- Pattern guards +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + tcGuardStmt :: TcStmtChecker tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside = do { guard' <- tcMonoExpr guard boolTy @@ -351,8 +354,19 @@ tcGuardStmt _ stmt _ _ = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) --------------------------------- --- List comprehensions and PArrays +--------------------------------------------------- +-- List comprehensions and PArrays +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill +-- b) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- 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 @@ -376,27 +390,7 @@ tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside ; thing <- thing_inside elt_ty ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } --- A parallel set of comprehensions --- [ (g x, h x) | ... ; let g v = ... --- | ... ; let h v = ... ] --- --- It's possible that g,h are overloaded, so we need to feed the LIE from the --- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). --- Similarly if we had an existential pattern match: --- --- data T = forall a. Show a => C a --- --- [ (show x, show y) | ... ; C x <- ... --- | ... ; C y <- ... ] --- --- Then we need the LIE from (show x, show y) to be simplified against --- the bindings for x and y. --- --- It's difficult to do this in parallel, so we rely on the renamer to --- ensure that g,h and x,y don't duplicate, and simply grow the environment. --- So the binders of the first parallel group will be in scope in the second --- group. But that's fine; there's no shadowing to worry about. - +-- ParStmt: See notes with tcMcStmt tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside = do { (pairs', thing) <- loop bndr_stmts_s ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) } @@ -421,7 +415,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts -- The inner 'stmts' lack a LastStmt, so the element type -- passed in to tcStmtsAndThen is never looked at ; (stmts', (bndr_ids, by')) - <- tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do { by' <- case by of Nothing -> return Nothing Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) } @@ -442,7 +436,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present by_arrow = case by' of Nothing -> \ty -> ty - Just (_,e_ty) -> \ty -> e_ty `mkFunTy` ty + Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy @@ -475,10 +469,12 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts tcLcStmt _ _ stmt _ _ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - --------------------------------- --- Monad comprehensions + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- tcMcStmt :: TcStmtChecker @@ -563,20 +559,19 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; m1_ty <- newFlexiTyVarTy star_star_kind ; m2_ty <- newFlexiTyVarTy star_star_kind ; tup_ty <- newFlexiTyVarTy liftedTypeKind - ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) - - --------------- Typecheck the 'using' function ------------- - -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm ; n_app <- case form of ThenForm -> return (\ty -> ty) _ -> do { n_ty <- newFlexiTyVarTy star_star_kind ; return (n_ty `mkAppTy`) } - ; let by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) by_arrow = case by of - Nothing -> \ty -> ty - Just {} -> \ty -> by_e_ty `mkFunTy` ty + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res poly_arg_ty = m1_ty `mkAppTy` alphaTy using_arg_ty = m1_ty `mkAppTy` tup_ty @@ -585,32 +580,12 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkFunTy` poly_res_ty - ; using' <- tcPolyExpr using using_poly_ty - ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' - - --------------- Typecheck the 'bind' function ------------- - -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty - ; new_res_ty <- newFlexiTyVarTy liftedTypeKind - ; let n_tup_ty = n_app tup_ty -- n (a,b,c) - ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ - using_res_ty `mkFunTy` (n_tup_ty `mkFunTy` new_res_ty) - `mkFunTy` res_ty - - --------------- Typecheck the 'fmap' function ------------- - ; fmap_op' <- case form of - ThenForm -> return noSyntaxExpr - _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ - (alphaTy `mkFunTy` betaTy) - `mkFunTy` (n_app alphaTy) - `mkFunTy` (n_app betaTy) - -- 'stmts' returns a result of type (m1_ty tuple_ty), -- typically something like [(Int,Bool,Int)] -- We don't know what tuple_ty is yet, so we use a variable ; let (bndr_names, n_bndr_names) = unzip bindersMap ; (stmts', (bndr_ids, by', return_op')) <- - tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do { by' <- case by of Nothing -> return Nothing Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') } @@ -625,6 +600,29 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; return (bndr_ids, by', return_op') } + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty) + `mkFunTy` res_ty + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noSyntaxExpr + _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ + mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ + (alphaTy `mkFunTy` betaTy) + `mkFunTy` (n_app alphaTy) + `mkFunTy` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + --------------- Bulding the bindersMap ---------------- ; let mk_n_bndr :: Name -> TcId -> TcId mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) @@ -636,15 +634,33 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- Type check the thing in the environment with -- these new binders and return the result - ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty) + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty) ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' , trS_by = by', trS_using = final_using , trS_ret = return_op', trS_bind = bind_op' , trS_fmap = fmap_op', trS_form = form }, thing) } --- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking --- of `ParStmt`s. +-- A parallel set of comprehensions +-- [ (g x, h x) | ... ; let g v = ... +-- | ... ; let h v = ... ] +-- +-- It's possible that g,h are overloaded, so we need to feed the LIE from the +-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods). +-- Similarly if we had an existential pattern match: +-- +-- data T = forall a. Show a => C a +-- +-- [ (show x, show y) | ... ; C x <- ... +-- | ... ; C y <- ... ] +-- +-- Then we need the LIE from (show x, show y) to be simplified against +-- the bindings for x and y. +-- +-- It's difficult to do this in parallel, so we rely on the renamer to +-- ensure that g,h and x,y don't duplicate, and simply grow the environment. +-- So the binders of the first parallel group will be in scope in the second +-- group. But that's fine; there's no shadowing to worry about. -- -- Note: The `mzip` function will get typechecked via: -- @@ -655,61 +671,77 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- -> m (st1, (st2, st3)) -- tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside - = do { (_,(m_ty,_)) <- matchExpectedAppTy res_ty - -- ToDo: what if the coercion isn't the identity? + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m_ty <- newFlexiTyVarTy star_star_kind - ; (pairs', thing) <- loop m_ty bndr_stmts_s + ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkFunTy` + (m_ty `mkAppTy` betaTy) + `mkFunTy` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty - ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ - (m_ty `mkAppTy` alphaTy) - `mkFunTy` - (m_ty `mkAppTy` betaTy) - `mkFunTy` - (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty + ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $ + mkForAllTy alphaTyVar $ + alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy) - -- Typecheck bind: - ; let tys = map (mkBigCoreVarTupTy . snd) pairs' - tuple_ty = mk_tuple_ty tys + ; (pairs', thing) <- loop m_ty bndr_stmts_s - ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ - (m_ty `mkAppTy` tuple_ty) - `mkFunTy` - (tuple_ty `mkFunTy` res_ty) - `mkFunTy` - res_ty + -- Typecheck bind: + ; let tys = map (mkBigCoreVarTupTy . snd) pairs' + tuple_ty = mk_tuple_ty tys - ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $ - mkForAllTy alphaTyVar $ - alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy) + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + (m_ty `mkAppTy` tuple_ty) + `mkFunTy` (tuple_ty `mkFunTy` res_ty) + `mkFunTy` res_ty - ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) } + ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) } - where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys -- loop :: Type -- m_ty -- -> [([LStmt Name], [Name])] -- -> TcM ([([LStmt TcId], [TcId])], thing) - loop _ [] = do { thing <- thing_inside res_ty - ; return ([], thing) } -- matching in the branches - - loop m_ty ((stmts, names) : pairs) - = do { -- type dummy since we don't know all binder types yet - ty_dummy <- newFlexiTyVarTy liftedTypeKind - ; (stmts', (ids, pairs', thing)) - <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' -> - do { ids <- tcLookupLocalIds names - ; _ <- unifyType res_ty' (m_ty `mkAppTy` mkBigCoreVarTupTy ids) - ; (pairs', thing) <- loop m_ty pairs - ; return (ids, pairs', thing) } - ; return ( (stmts', ids) : pairs', thing ) } + loop _ [] = do { thing <- thing_inside res_ty + ; return ([], thing) } -- matching in the branches + + loop m_ty ((stmts, names) : pairs) + = do { -- type dummy since we don't know all binder types yet + ty_dummy <- newFlexiTyVarTy liftedTypeKind + ; (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' -> + do { ids <- tcLookupLocalIds names + ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids + + ; check_same m_tup_ty res_ty' + ; check_same m_tup_ty ty_dummy + + ; (pairs', thing) <- loop m_ty pairs + ; return (ids, pairs', thing) } + ; return ( (stmts', ids) : pairs', thing ) } + + -- Check that the types match up. + -- This is a grevious hack. They always *will* match + -- If (>>=) and (>>) are polymorpic in the return type, + -- but we don't have any good way to incorporate the coercion + -- so for now we just check that it's the identity + check_same actual expected + = do { coi <- unifyType actual expected + ; unless (isIdentityCoI coi) $ + failWithMisMatch [UnifyOrigin { uo_expected = expected + , uo_actual = actual }] } tcMcStmt _ stmt _ _ = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) --------------------------------- --- Do-notation --- The main excitement here is dealing with rebindable syntax + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- tcDoStmt :: TcStmtChecker @@ -788,7 +820,6 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty) ; thing <- thing_inside new_res_ty --- ; lie_binds <- bindLocalMethods lie tup_ids ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names @@ -814,54 +845,6 @@ rebindable syntax first, and push that information into (tcMonoExprNC rhs). Otherwise the error shows up when cheking the rebindable syntax, and the expected/inferred stuff is back to front (see Trac #3613). -\begin{code} --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference - -> TcStmtChecker --- Used only by TcArrows... should be gotten rid of -tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside res_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } - -tcMDoStmt tc_rhs _ (ExprStmt rhs _ _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_rhs rhs - ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } - -tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames - , recS_rec_ids = recNames }) res_ty thing_inside - = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind - ; let rec_ids = zipWith mkLocalId recNames rec_tys - ; tcExtendIdEnv rec_ids $ do - { (stmts', (later_ids, rec_rets)) - <- tcStmtsAndThen ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - do { rec_rets <- zipWithM tcCheckId recNames rec_tys - ; later_ids <- tcLookupLocalIds laterNames - ; return (later_ids, rec_rets) } - - ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) - - ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets - , recS_ret_ty = res_ty }, thing) - }} - -tcMDoStmt _ _ stmt _ _ - = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt) -\end{code} - %************************************************************************ %* * diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index d28e901..39594f0 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -36,7 +36,6 @@ import PrelNames import BasicTypes hiding (SuccessFlag(..)) import DynFlags import SrcLoc -import ErrUtils import Util import Outputable import FastString @@ -348,9 +347,9 @@ tc_lpat :: LPat Name -> TcM a -> TcM (LPat TcId, a) tc_lpat (L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - maybeAddErrCtxt (patCtxt pat) $ - do { (pat', res) <- tc_pat penv pat pat_ty thing_inside + = setSrcSpan span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) + thing_inside ; return (L span pat', res) } tc_lpats :: PatEnv @@ -774,7 +773,6 @@ matchExpectedConTy data_tc pat_ty -- coi : T tys ~ pat_ty \end{code} -Noate [ Note [Matching constructor patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty @@ -1006,12 +1004,18 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env -} \begin{code} -patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context -patCtxt (VarPat _) = Nothing -patCtxt (ParPat _) = Nothing -patCtxt (AsPat _ _) = Nothing -patCtxt pat = Just (hang (ptext (sLit "In the pattern:")) - 2 (ppr pat)) +maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) ----------------------------------------------- checkExistentials :: [TyVar] -> PatEnv -> TcM () diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ad2405b..826c09b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -781,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 31352e1..e229b8b 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -20,7 +20,7 @@ module TcUnify ( matchExpectedListTy, matchExpectedPArrTy, matchExpectedTyConApp, matchExpectedAppTy, matchExpectedFunTys, matchExpectedFunKind, - wrapFunResCoercion + wrapFunResCoercion, failWithMisMatch ) where #include "HsVersions.h" diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 54a4833..89198c4 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1208,8 +1208,11 @@ output = [ x monad comprehensions - Monad comprehesions generalise the list comprehension notation to work - for any monad. + Monad comprehesions generalise the list comprehension notation, + including parallel comprehensions + () and + transform comprenensions () + to work for any monad. Monad comprehensions support: @@ -1360,7 +1363,70 @@ do (x,y) <- mzip (do x <- [1..10] lists, which make MonadComprehensions backward compatible to built-in, transform and parallel list comprehensions. + More formally, the desugaring is as follows. We write D[ e | Q] +to mean the desugaring of the monad comprehension [ e | Q]: + +Expressions: e +Declarations: d +Lists of qualifiers: Q,R,S + +-- Basic forms +D[ e | ] = return e +D[ e | p <- e, Q ] = e >>= \p -> D[ e | Q ] +D[ e | e, Q ] = guard e >> \p -> D[ e | Q ] +D[ e | let d, Q ] = let d in D[ e | Q ] + +-- Parallel comprehensions (iterate for multiple parallel branches) +D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] >>= \(Qv,Rv) -> D[ e | S ] + +-- Transform comprehensions +D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then f by b, R ] = f b D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +where Qv is the tuple of variables bound by Q (and used subsequently) + selQvi is a selector mapping Qv to the ith component of Qv +Operator Standard binding Expected type +-------------------------------------------------------------------- +return GHC.Base t1 -> m t2 +(>>=) GHC.Base m1 t1 -> (t2 -> m2 t3) -> m3 t3 +(>>) GHC.Base m1 t1 -> m2 t2 -> m3 t3 +guard Control.Monad t1 -> m t2 +fmap GHC.Base forall a b. (a->b) -> n a -> n b +mgroupWith Control.Monad.Group forall a. (a -> t) -> m1 a -> m2 (n a) +mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b) + +The comprehension should typecheck when its desugaring would typecheck. + + +Monad comprehensions support rebindable syntax (). +Without rebindable +syntax, the operators from the "standard binding" module are used; with +rebindable syntax, the operators are looked up in the current lexical scope. +For example, parallel comprehensions will be typechecked and desugared +using whatever "mzip" is in scope. + + +The rebindable operators must have the "Expected type" given in the +table above. These types are surprisingly general. For example, you can +use a bind operator with the type + +(>>=) :: T x y a -> (a -> T y z b) -> T x z b + +In the case of transform comprehensions, notice that the groups are +parameterised over some arbitrary type n (provided it +has an fmap, as well as +the comprehension being over an arbitrary monad. +