From d76d9636aeebe933d160157331b8c8c0087e73ac Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 2 May 2011 09:02:18 +0100 Subject: [PATCH] More hacking on monad-comp; now works --- compiler/deSugar/Coverage.lhs | 20 +-- compiler/deSugar/DsExpr.lhs | 25 ++-- compiler/deSugar/DsListComp.lhs | 246 +++++++++++-------------------------- compiler/deSugar/DsMeta.hs | 10 +- compiler/hsSyn/Convert.lhs | 13 +- compiler/hsSyn/HsExpr.lhs | 152 +++++++++++++---------- compiler/hsSyn/HsLit.lhs | 4 +- compiler/hsSyn/HsUtils.lhs | 26 ++-- compiler/main/DynFlags.hs | 4 +- compiler/prelude/PrelNames.lhs | 5 +- compiler/rename/RnExpr.lhs | 225 +++++++++++++++------------------ compiler/typecheck/TcArrows.lhs | 9 +- compiler/typecheck/TcGenDeriv.lhs | 4 +- compiler/typecheck/TcHsSyn.lhs | 12 +- compiler/typecheck/TcMatches.lhs | 113 +++++++++-------- compiler/typecheck/TcRnDriver.lhs | 45 +++---- 16 files changed, 412 insertions(+), 501 deletions(-) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 711f66e..30be2aa 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -463,14 +463,18 @@ addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr returnExpr bi t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr) return $ TransformStmt t_s ids t_u t_m t_r t_b -addTickStmt isGuard (GroupStmt stmts binderMap by using returnExpr bindExpr liftMExpr) = do - t_s <- (addTickLStmts isGuard stmts) - t_y <- (fmapMaybeM addTickLHsExprAlways by) - t_u <- (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using) - t_f <- (addTickSyntaxExpr hpcSrcSpan returnExpr) - t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr) - t_m <- (addTickSyntaxExpr hpcSrcSpan liftMExpr) - return $ GroupStmt t_s binderMap t_y t_u t_b t_f t_m +addTickStmt isGuard stmt@(GroupStmt { grpS_stmts = stmts + , grpS_by = by, grpS_using = using + , grpS_ret = returnExpr, grpS_bind = bindExpr + , grpS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- fmapMaybeM addTickLHsExprAlways by + t_u <- addTickLHsExprAlways using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr + return $ stmt { grpS_stmts = t_s, grpS_by = t_y, grpS_using = t_u + , grpS_ret = t_f, grpS_bind = t_b, grpS_fmap = t_m } addTickStmt isGuard stmt@(RecStmt {}) = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index c55c2d4..418bda5 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -327,10 +327,10 @@ dsExpr (HsLet binds body) = do -- dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) -dsExpr (HsDo DoExpr stmts res_ty) = dsDo stmts res_ty -dsExpr (HsDo GhciStmt stmts res_ty) = dsDo stmts res_ty -dsExpr (HsDo MDoExpr stmts res_ty) = dsDo stmts res_ty -dsExpr (HsDo MonadComp stmts res_ty) = dsMonadComp stmts res_ty +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 (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -694,21 +694,16 @@ handled in DsListComp). Basically does the translation given in the Haskell 98 report: \begin{code} -dsDo :: [LStmt Id] - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsDo stmts result_ty +dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo stmts = goL stmts where goL [] = panic "dsDo" goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (LastStmt body ret_op) stmts - = ASSERT( null stmts ) - do { body' <- dsLExpr body - ; ret_op' <- dsExpr ret_op - ; return (App ret_op' body') } + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions go _ (ExprStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs @@ -753,7 +748,7 @@ dsDo stmts result_ty (mkFunTy tup_ty body_ty)) mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty - ret_stmt = noLoc $ LastStmt return_op (mkLHsTupleExpr rets) + ret_stmt = noLoc $ LastStmt (mkLHsTupleExpr rets) return_op tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 1ecab67..63cae93 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -54,7 +54,9 @@ dsListComp :: [LStmt Id] dsListComp lquals res_ty = do dflags <- getDOptsDs let quals = map unLoc lquals - [elt_ty] = tcTyConAppArgs res_ty + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags -- Either rules are switched off, or we are ignoring what there are; @@ -82,9 +84,9 @@ dsListComp lquals res_ty = do -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type) -dsInnerListComp (stmts, bndrs) = do +dsInnerListComp (stmts, bndrs) = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) - bndrs_tuple_type + (mkListTy bndrs_tuple_type) ; return (expr, bndrs_tuple_type) } where bndrs_tuple_type = mkBigCoreVarTupTy bndrs @@ -117,7 +119,8 @@ dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr _ _) -- 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 dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsGroupStmt (GroupStmt stmts binderMap by using _ _ _) = do +dsGroupStmt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = binderMap + , grpS_by = by, grpS_using = using }) = do let (fromBinders, toBinders) = unzip binderMap fromBindersTypes = map idType fromBinders @@ -130,7 +133,7 @@ dsGroupStmt (GroupStmt stmts binderMap by using _ _ _) = do -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments - usingExpr' <- dsLExpr (either id noLoc using) + usingExpr' <- dsLExpr using usingArgs <- case by of Nothing -> return [expr] Just by_e -> do { by_e' <- dsLExpr by_e @@ -688,45 +691,15 @@ parrElemType e = Translation for monad comprehensions \begin{code} - --- | Keep the "context" of a monad comprehension in a small data type to avoid --- some boilerplate... -data DsMonadComp = DsMonadComp - { mc_return :: Either (SyntaxExpr Id) (Expr CoreBndr) - , mc_body :: LHsExpr Id - , mc_m_ty :: Type - } - --- -- Entry point for monad comprehension desugaring --- -dsMonadComp :: [LStmt Id] -- the statements - -> Type -- the final type - -> DsM CoreExpr -dsMonadComp stmts res_ty - = dsMcStmts stmts (DsMonadComp (Left return_op) body m_ty) - where - (m_ty, _) = tcSplitAppTy res_ty - - -dsMcStmts :: [LStmt Id] - -> DsMonadComp - -> DsM CoreExpr - --- No statements left for desugaring. Desugar the body after calling "return" --- on it. -dsMcStmts [] DsMonadComp { mc_return, mc_body } - = case mc_return of - Left ret -> dsLExpr $ noLoc ret `nlHsApp` mc_body - Right ret' -> do - { body' <- dsLExpr mc_body - ; return $ mkApps ret' [body'] } - --- Otherwise desugar each statement step by step -dsMcStmts ((L loc stmt) : lstmts) mc - = putSrcSpanDs loc (dsMcStmt stmt lstmts mc) +dsMonadComp :: [LStmt Id] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts +dsMcStmts :: [LStmt Id] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) +--------------- dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr dsMcStmt (LastStmt body ret_op) stmts @@ -785,7 +758,7 @@ dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) s -- -- [| (q, then group by e using f); rest |] -- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> --- case unzip n_tup of qv -> [| rest |] +-- case unzip n_tup of qv' -> [| rest |] -- -- where variables (v1:t1, ..., vk:tk) are bound by q -- qv = (v1, ..., vk) @@ -794,61 +767,42 @@ dsMcStmt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_op) s -- f :: forall a. (a -> t) -> m1 a -> m2 (n a) -- n_tup :: n qt -- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) --- --- [| q, then group by e using f |] -> (f (\q_v -> e) [| q |]) >>= (return . (unzip q_v)) --- --- which is equal to --- --- [| q, then group by e using f |] -> liftM (unzip q_v) (f (\q_v -> e) [| q |]) --- --- where unzip is of the form --- --- unzip :: n (a,b,c,..) -> (n a,n b,n c,..) --- unzip m_tuple = ( fmap selN1 m_tuple --- , fmap selN2 m_tuple --- , .. ) --- where selN1 (a,b,c,..) = a --- selN2 (a,b,c,..) = b --- .. --- -dsMcStmt (GroupStmt stmts binderMap by using return_op bind_op fmap_op) stmts_rest - = do { let (fromBinders, toBinders) = unzip binderMap - fromBindersTypes = map idType fromBinders -- Types ty - fromBindersTupleTy = mkBigCoreTupTy fromBindersTypes - toBindersTypes = map idType toBinders -- Types (n ty) - toBindersTupleTy = mkBigCoreTupTy toBindersTypes + +dsMcStmt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bndrs + , grpS_by = by, grpS_using = using + , grpS_ret = return_op, grpS_bind = bind_op + , grpS_fmap = fmap_op }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + from_bndr_tys = map idType from_bndrs -- Types ty -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - ; expr <- dsInnerMonadComp stmts fromBinders return_op + ; expr <- dsInnerMonadComp stmts from_bndrs return_op -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments - ; usingExpr' <- dsLExpr (either id noLoc using) + ; usingExpr' <- dsLExpr using ; usingArgs <- case by of Nothing -> return [expr] Just by_e -> do { by_e' <- dsLExpr by_e - ; lam <- matchTuple fromBinders by_e' + ; lam <- matchTuple from_bndrs by_e' ; return [lam, expr] } - -- Create an unzip function for the appropriate arity and element types - ; fmap_op' <- dsExpr fmap_op - ; (unzip_fn, unzip_rhs) <- mkMcUnzipM fmap_op' m_ty fromBindersTypes - -- Generate the expressions to build the grouped list -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold monads rather than single values + ; fmap_op' <- dsExpr fmap_op ; bind_op' <- dsExpr bind_op ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 - n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty - - ; body <- dsMcStmts stmts_rest - ; n_tup_var <- newSysLocalDs n_tup_ty - ; tup_n_var <- newSysLocalDs (mkBigCoreVarTupTy toBinders) - ; us <- newUniqueSupply - ; let unzip_n_tup = Let (Rec [(unzip_fn, unzip_rhs)]) $ - App (Var unzip_fn) (Var n_tup_var) - -- unzip_n_tup :: (n a, n b, n c) - body' = mkTupleCase us toBinders body unzip_n_tup (Var tup_n_var) + n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c) + tup_n_ty = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var <- newSysLocalDs n_tup_ty + ; tup_n_var <- newSysLocalDs tup_n_ty + ; tup_n_expr <- mkMcUnzipM fmap_op' n_tup_var from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs + body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) } @@ -864,23 +818,26 @@ dsMcStmt (GroupStmt stmts binderMap by using return_op bind_op fmap_op) stmts_re -- NB: we need a polymorphic mzip because we call it several times dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest - = do { exps <- mapM ds_inner pairs - ; let qual_tys = map (mkBigCoreVarTupTy . snd) pairs - ; mzip_op' <- dsExpr mzip_op - ; (zip_fn, zip_rhs) <- mkMcZipM mzip_op' (mc_m_ty mc) qual_tys + = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op ; let -- The pattern variables - vars = map (mkBigLHsVarPatTup . snd) pairs + pats = map (mkBigLHsVarPatTup . snd) pairs -- Pattern with tuples of variables -- [v1,v2,v3] => (v1, (v2, v3)) - pat = foldr (\tn tm -> mkBigLHsPatTup [tn, tm]) (last vars) (init vars) - rhs = Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } where - ds_inner (stmts, bndrs) = dsInnerMonadComp stmts bndrs mono_ret_op + ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op + ; return (exp, tup_ty) } where - mono_ret_op = HsWrap (WpTyApp (mkBigCoreVarTupTy bndrs)) return_op + mono_ret_op = HsWrap (WpTyApp tup_ty) return_op + tup_ty = mkBigCoreVarTupTy bndrs dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) @@ -891,10 +848,9 @@ matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr -- \x. case x of (a,b,c) -> body matchTuple ids body = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs (mkBigLHsVarPatTup ids) + ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } - -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` dsMcBindStmt :: LPat Id @@ -936,10 +892,10 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts dsInnerMonadComp :: [LStmt Id] -> [Id] -- Return a tuple of these variables - -> LHsExpr Id -- The monomorphic "return" operator + -> HsExpr Id -- The monomorphic "return" operator -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op - = dsMcStmts (stmts ++ [noLoc (ReturnStmt (mkBigLHsVarTup bndrs) ret_op)]) + = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)]) -- The `unzip` function for `GroupStmt` in a monad comprehensions -- @@ -948,85 +904,25 @@ dsInnerMonadComp stmts bndrs ret_op -- , liftM selN2 m_tuple -- , .. ) -- --- mkMcUnzipM m [t1, t2] --- = (unzip_fn, \ys :: m (t1, t2) -> --- ( liftM (selN1 :: (t1, t2) -> t1) ys --- , liftM (selN2 :: (t1, t2) -> t2) ys --- )) --- -mkMcUnzipM :: CoreExpr - -> Type -- m - -> [Type] -- [a,b,c,..] - -> DsM (Id, CoreExpr) -mkMcUnzipM liftM_op m_ty elt_tys - = do { ys <- newSysLocalDs monad_tuple_ty - ; xs <- mapM newSysLocalDs elt_tys - ; scrut <- newSysLocalDs tuple_tys - - ; unzip_fn <- newSysLocalDs unzip_fn_ty - - ; let -- Select one Id from our tuple - selectExpr n = mkLams [scrut] $ mkTupleSelector xs (xs !! n) scrut (Var scrut) - -- Apply 'selectVar' and 'ys' to 'liftM' - tupleElem n = mkApps liftM_op - -- Types (m is figured out by the type checker): - -- liftM :: forall a b. (a -> b) -> m a -> m b - [ Type tuple_tys, Type (elt_tys !! n) - -- Arguments: - , selectExpr n, Var ys ] - -- The final expression with the big tuple - unzip_body = mkBigCoreTup [ tupleElem n | n <- [0..length elt_tys - 1] ] - - ; return (unzip_fn, mkLams [ys] unzip_body) } - where monad_tys = map (m_ty `mkAppTy`) elt_tys -- [m a,m b,m c,..] - tuple_monad_tys = mkBigCoreTupTy monad_tys -- (m a,m b,m c,..) - tuple_tys = mkBigCoreTupTy elt_tys -- (a,b,c,..) - monad_tuple_ty = m_ty `mkAppTy` tuple_tys -- m (a,b,c,..) - unzip_fn_ty = monad_tuple_ty `mkFunTy` tuple_monad_tys -- m (a,b,c,..) -> (m a,m b,m c,..) - --- Generate the `mzip` function for `ParStmt` in monad comprehensions, for --- example: --- --- mzip :: m t1 --- -> (m t2 -> m t3 -> m (t2, t3)) --- -> m (t1, (t2, t3)) --- --- mkMcZipM m [t1, t2, t3] --- = (zip_fn, \(q1::t1) (q2::t2) (q3::t3) -> --- mzip q1 (mzip q2 q3)) --- -mkMcZipM :: CoreExpr - -> Type - -> [Type] - -> DsM (Id, CoreExpr) - -mkMcZipM mzip_op m_ty tys@(_:_:_) -- min. 2 types - = do { (ids, t1, tuple_ty, zip_body) <- loop tys - ; zip_fn <- newSysLocalDs $ - (m_ty `mkAppTy` t1) - `mkFunTy` - (m_ty `mkAppTy` tuple_ty) - `mkFunTy` - (m_ty `mkAppTy` mkBigCoreTupTy [t1, tuple_ty]) - ; return (zip_fn, mkLams ids zip_body) } - - where - -- loop :: [Type] -> DsM ([Id], Type, [Type], CoreExpr) - loop [t1, t2] = do -- last run of the `loop` - { ids@[a,b] <- newSysLocalsDs (map (m_ty `mkAppTy`) [t1,t2]) - ; let zip_body = mkApps mzip_op [ Type t1, Type t2 , Var a, Var b ] - ; return (ids, t1, t2, zip_body) } - - loop (t1:tr) = do - { -- Get ty, ids etc from the "inner" zip - (ids', t1', t2', zip_body') <- loop tr - - ; a <- newSysLocalDs $ m_ty `mkAppTy` t1 - ; let tuple_ty' = mkBigCoreTupTy [t1', t2'] - zip_body = mkApps mzip_op [ Type t1, Type tuple_ty', Var a, zip_body' ] - ; return ((a:ids'), t1, tuple_ty', zip_body) } - --- This case should never happen: -mkMcZipM _ _ tys = pprPanic "mkMcZipM: unexpected argument" (ppr tys) +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: CoreExpr -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM fmap_op ys elt_tys + = do { 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) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs) + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } \end{code} diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2c1939f..e68173a 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -721,19 +721,15 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt sts body _ _) +repE e@(HsDo ctxt sts _) | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; - body' <- addBinds ss $ repLE body; - ret <- repNoBindSt body'; - e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); + e' <- repDoE (nonEmptyCoreList zs); wrapGenSyms ss e' } | ListComp <- ctxt = do { (ss,zs) <- repLSts sts; - body' <- addBinds ss $ repLE body; - ret <- repNoBindSt body'; - e' <- repComp (nonEmptyCoreList (zs ++ [ret])); + e' <- repComp (nonEmptyCoreList zs); wrapGenSyms ss e' } | otherwise diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index c9cbfef..5933e9d 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -522,12 +522,15 @@ cvtHsDo do_or_lc stmts | null stmts = failWith (ptext (sLit "Empty stmt list in do-block")) | otherwise = do { stmts' <- cvtStmts stmts - ; body <- case last stmts' of - L _ (ExprStmt body _ _ _) -> return body - stmt' -> failWith (bad_last stmt') - ; return $ HsDo do_or_lc (init stmts') body noSyntaxExpr void } + ; let Just (stmts'', last') = snocView stmts' + + ; last'' <- case last' of + L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body)) + _ -> failWith (bad_last last') + + ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void } where - bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon + bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt , ptext (sLit "(It should be an expression.)") ] diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index f7b693f..cf9c0d7 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -24,6 +24,7 @@ import BasicTypes import DataCon import SrcLoc import Util( dropTail ) +import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString @@ -836,17 +837,19 @@ data StmtLR idL idR -- Not used for GhciStmt, PatGuard, which scope over other stuff (LHsExpr idR) (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) - (SyntaxExpr idR) -- The (>>=) operator + (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] (SyntaxExpr idR) -- The (>>) operator - (SyntaxExpr idR) -- The `guard` operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp -- See notes [Monad Comprehensions] PostTcType -- Element type of the RHS (used for arrows) @@ -859,16 +862,15 @@ data StmtLR idL idR (SyntaxExpr idR) -- Polymorphic `return` operator -- with type (forall a. a -> m a) -- See notes [Monad Comprehensions] - - -- After renaming, the ids are the binders bound by the stmts and used - -- after them + -- After renaming, the ids are the binders + -- bound by the stmts and used after them -- "qs, then f by e" ==> TransformStmt qs binders f (Just e) (return) (>>=) -- "qs, then f" ==> TransformStmt qs binders f Nothing (return) (>>=) | TransformStmt [LStmt idL] -- Stmts are the ones to the left of the 'then' - [idR] -- After renaming, the IDs are the binders occurring + [idR] -- After renaming, the Ids are the binders occurring -- within this transform statement that are used after it (LHsExpr idR) -- "then f" @@ -880,25 +882,30 @@ data StmtLR idL idR (SyntaxExpr idR) -- The '(>>=)' operator. -- See Note [Monad Comprehensions] - | GroupStmt - [LStmt idL] -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped + | GroupStmt { + grpS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped - [(idR, idR)] -- See Note [GroupStmt binder map] + grpS_bndrs :: [(idR, idR)], -- See Note [GroupStmt binder map] - (Maybe (LHsExpr idR)) -- "by e" (optional) + grpS_by :: Maybe (LHsExpr idR), -- "by e" (optional) - (Either -- "using f" - (LHsExpr idR) -- Left f => explicit "using f" - (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith' - -- (list comprehensions) or 'groupM' (monad - -- comprehensions) + grpS_using :: LHsExpr idR, + grpS_explicit :: Bool, -- True <=> explicit "using f" + -- False <=> implicit; grpS_using is filled in with + -- 'groupWith' (list comprehensions) or + -- 'groupM' (monad comprehensions) - (SyntaxExpr idR) -- The 'return' function for inner monad - -- comprehensions - (SyntaxExpr idR) -- The '(>>=)' operator - (SyntaxExpr idR) -- The 'liftM' function from Control.Monad for desugaring - -- See Note [Monad Comprehensions] + -- Invariant: if grpS_explicit = False, then grp_by = Just e + -- That is, we can have group by e + -- group using f + -- group by e using f + + grpS_ret :: SyntaxExpr idR, -- The 'return' function for inner monad + -- comprehensions + grpS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + grpS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) | RecStmt @@ -937,6 +944,17 @@ data StmtLR idL idR deriving (Data, Typeable) \end{code} +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see Trac #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + Note [GroupStmt binder map] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The [(idR,idR)] in a GroupStmt behaves as follows: @@ -946,7 +964,7 @@ The [(idR,idR)] in a GroupStmt behaves as follows: * After renaming: [ (x27,x27), ..., (z35,z35) ] These are the variables - bound by the stmts to the left of the 'group' + bound by the stmts to the left of the 'group' and used either in the 'by' clause, or in the stmts following the 'group' Each item is a pair of identical variables. @@ -986,7 +1004,7 @@ depends on the context. Consider the following contexts: E :: Bool Translation: guard E >> ... -Array comprehensions are handled like list comprehensions -=chak +Array comprehensions are handled like list comprehensions. Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1045,7 +1063,7 @@ In transform and grouping statements ('then ..' and 'then group ..') the => f [ env | stmts ] >>= \bndrs -> [ body | rest ] -Normal expressions require the 'Control.Monad.guard' function for boolean +ExprStmts require the 'Control.Monad.guard' function for boolean expressions: [ body | exp, stmts ] @@ -1082,8 +1100,8 @@ pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss) pprStmt (TransformStmt stmts bndrs using by _ _) = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by]) -pprStmt (GroupStmt stmts _ by using _ _ _) - = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using]) +pprStmt (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_using = using, grpS_explicit = explicit }) + = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using explicit]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) @@ -1099,13 +1117,13 @@ pprTransformStmt bndrs using by , nest 2 (pprBy by)] pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> Either (LHsExpr id) (SyntaxExpr is) + -> LHsExpr id -> Bool -> SDoc -pprGroupStmt by using - = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)] +pprGroupStmt by using explicit + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 pp_using ] where - ppr_using (Right _) = empty - ppr_using (Left e) = ptext (sLit "using") <+> ppr e + pp_using | explicit = ptext (sLit "using") <+> ppr using + | otherwise = empty pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc pprBy Nothing = empty @@ -1124,7 +1142,7 @@ ppr_do_stmts :: OutputableBndr id => [LStmt id] -> 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 ([ppr s <> semi | s <- stmts]) + = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] @@ -1269,9 +1287,10 @@ data HsStmtContext id \begin{code} isDoExpr :: HsStmtContext id -> Bool -isDoExpr DoExpr = True -isDoExpr MDoExpr = True -isDoExpr _ = False +isDoExpr DoExpr = True +isDoExpr MDoExpr = True +isDoExpr GhciStmt = True +isDoExpr _ = False isListCompExpr :: HsStmtContext id -> Bool isListCompExpr ListComp = True @@ -1320,34 +1339,40 @@ pprMatchContextNoun ProcExpr = ptext (sLit "arrow abstraction") pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") $$ pprStmtContext ctxt -pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +----------------- +pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + 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 + + +----------------- +pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command") +pprStmtContext DoExpr = ptext (sLit "'do' expression") +pprStmtContext MDoExpr = ptext (sLit "'mdo' expression") +pprStmtContext ListComp = ptext (sLit "list comprehension") +pprStmtContext MonadComp = ptext (sLit "monad comprehension") +pprStmtContext PArrComp = ptext (sLit "array comprehension") +pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) - = sep [ptext (sLit "a parallel branch of"), pprStmtContext c] + | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c pprStmtContext (TransformStmtCtxt c) - = sep [ptext (sLit "a transformed branch of"), pprStmtContext c] -pprStmtContext (PatGuard ctxt) - = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt -pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") -pprStmtContext DoExpr = ptext (sLit "a 'do' expression") -pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression") -pprStmtContext ListComp = ptext (sLit "a list comprehension") -pprStmtContext MonadComp = ptext (sLit "a monad comprehension") -pprStmtContext PArrComp = ptext (sLit "an array comprehension") - -{- -pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun) -pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative") -pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding") -pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda") -pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc") -pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt - --- Used for the result statement of comprehension --- e.g. the 'e' in [ e | ... ] --- or the 'r' in f x = r -pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt -pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other --} + | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c + -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc @@ -1377,11 +1402,12 @@ pprMatchInCtxt ctxt match = hang (ptext (sLit "In") <+> pprMatchContext ctxt <> pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) => HsStmtContext idL -> StmtLR idL idR -> SDoc -pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon) +pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon) 4 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (GroupStmt _ _ by using _ _ _) = pprGroupStmt by using + ppr_stmt (GroupStmt { grpS_by = by, grpS_using = using + , grpS_explicit = explicit }) = pprGroupStmt by using explicit ppr_stmt (TransformStmt _ bndrs using by _ _) = pprTransformStmt bndrs using by ppr_stmt stmt = pprStmt stmt \end{code} diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index c29083c..4a565ff 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -63,7 +63,7 @@ instance Eq HsLit where data HsOverLit id -- An overloaded literal = OverLit { ol_val :: OverLitVal, - ol_rebindable :: Bool, -- + ol_rebindable :: Bool, -- Note [ol_rebindable] ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] ol_type :: PostTcType } deriving (Data, Typeable) @@ -101,7 +101,7 @@ This witness should replace the literal. This dual role is unusual, because we're replacing 'fromInteger' with a call to fromInteger. Reason: it allows commoning up of the fromInteger -calls, which wouldn't be possible if the desguarar made the application +calls, which wouldn't be possible if the desguarar made the application. The PostTcType in each branch records the type the overload literal is found to have. diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 0d91e9f..de883f2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -43,7 +43,7 @@ module HsUtils( -- Stmts mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, - mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -238,9 +238,15 @@ mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL id mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr -mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr -mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) noSyntaxExpr noSyntaxExpr noSyntaxExpr +emptyGroupStmt :: StmtLR idL idR +emptyGroupStmt = GroupStmt { grpS_stmts = [], grpS_bndrs = [], grpS_explicit = False + , grpS_by = Nothing, grpS_using = noLoc noSyntaxExpr + , grpS_ret = noSyntaxExpr, grpS_bind = noSyntaxExpr + , grpS_fmap = noSyntaxExpr } +mkGroupUsingStmt ss u = emptyGroupStmt { grpS_stmts = ss, grpS_explicit = True, grpS_using = u } +mkGroupByStmt ss b = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b } +mkGroupByUsingStmt ss b u = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b + , grpS_explicit = True, grpS_using = u } mkLastStmt expr = LastStmt expr noSyntaxExpr mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType @@ -512,9 +518,9 @@ collectStmtBinders (ExprStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt stmts _ _ _ _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -659,9 +665,9 @@ lStmtsImplicits = hs_lstmts hs_stmt (LastStmt {}) = emptyNameSet hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs - hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts - hs_stmt (GroupStmt stmts _ _ _ _ _ _) = hs_lstmts stmts - hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts + hs_stmt (GroupStmt { grpS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds _) = emptyNameSet diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ba862c5..ffdb144 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1625,9 +1625,9 @@ xFlags = [ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, + ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), + ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 421ec45..e1d287a 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -607,7 +607,7 @@ inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) -eqClassName, eqName, ordClassName, geName, functorClassName :: Name +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey @@ -1299,7 +1299,8 @@ unboundKey = mkPreludeMiscIdUnique 101 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey + failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, + fmapClassOpKey :: Unique fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 minusClassOpKey = mkPreludeMiscIdUnique 103 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index e3e92bc..d1dd222 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -40,7 +40,7 @@ import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List -import Util ( isSingleton ) +import Util ( isSingleton, snocView ) import ListSetOps ( removeDups ) import Outputable import SrcLoc @@ -225,7 +225,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 ()) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs)) ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) @@ -440,10 +440,8 @@ convertOpFormsCmd (HsIf f exp c1 c2) convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) -convertOpFormsCmd (HsDo ctxt stmts body return_op ty) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) - (convertOpFormsLCmd body) - (convertOpFormsCmd return_op) ty +convertOpFormsCmd (HsDo ctxt stmts ty) + = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ty -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@ -495,14 +493,10 @@ methodNamesCmd (HsPar c) = methodNamesLCmd c methodNamesCmd (HsIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsLet _ c) = methodNamesLCmd c - -methodNamesCmd (HsDo _ stmts body _ _) - = methodNamesStmts stmts `plusFV` methodNamesLCmd body - -methodNamesCmd (HsApp c _) = methodNamesLCmd c - -methodNamesCmd (HsLam match) = methodNamesMatch match +methodNamesCmd (HsLet _ c) = methodNamesLCmd c +methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts +methodNamesCmd (HsApp c _) = methodNamesLCmd c +methodNamesCmd (HsLam match) = methodNamesMatch match methodNamesCmd (HsCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName @@ -538,6 +532,7 @@ methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR Name Name -> FreeVars +methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName @@ -639,42 +634,48 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \begin{code} rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars --- --- Renaming a single RecStmt can give a sequence of smaller Stmts rnStmts ctxt [] thing_inside - = do { addErr (ptext (sLit "Empty") <+> pprStmtContext ctxt) + = do { checkEmptyStmts ctxt ; (thing, fvs) <- thing_inside [] ; return (([], thing), fvs) } rnStmts MDoExpr stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr (mkRecStmt all_but_last) $ \ bndrs -> + <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ -> do { checkStmt MDoExpr True last_stmt ; rnStmt MDoExpr last_stmt thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } where Just (all_but_last, last_stmt) = snocView stmts -rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside - | null stmts +rnStmts ctxt (lstmt@(L loc stmt) : lstmts) thing_inside + | null lstmts = setSrcSpan loc $ - do { let last_stmt = case stmt of - ExprStmt e _ _ _ -> LastStmt e noSyntaxExpr - ; checkStmt ctxt True {- last stmt -} stmt - ; rnStmt ctxt stmt thing_inside } + do { -- Turn a final ExprStmt into a LastStmt + -- This is the first place it's convenient to do this + -- (In principle the parser could do it, but it's + -- just not very convenient to do so.) + let stmt' | okEmpty ctxt + = lstmt + | otherwise + = case stmt of + ExprStmt e _ _ _ -> L loc (mkLastStmt e) + _ -> lstmt + ; checkStmt ctxt True {- last stmt -} stmt' + ; rnStmt ctxt stmt' thing_inside } | otherwise = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ - do { checkStmt ctxt False {- Not last -} stmt - ; rnStmt ctxt stmt $ \ bndrs1 -> - rnStmts ctxt stmts $ \ bndrs2 -> + do { checkStmt ctxt False {- Not last -} lstmt + ; rnStmt ctxt lstmt $ \ bndrs1 -> + rnStmts ctxt lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } @@ -686,7 +687,7 @@ rnStmt :: HsStmtContext Name -- 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 +rnStmt _ (L loc (LastStmt expr _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr ; (ret_op, fvs1) <- lookupSyntaxName returnMName ; (thing, fvs3) <- thing_inside [] @@ -704,8 +705,7 @@ rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside - = do { checkBindStmt ctxt is_last - ; (expr', fv_expr) <- rnLExpr expr + = do { (expr', fv_expr) <- rnLExpr expr -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupSyntaxName bindMName ; (fail_op, fvs2) <- lookupSyntaxName failMName @@ -716,13 +716,12 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt ctxt (L loc (LetStmt binds)) thing_inside - = do { checkLetStmt ctxt binds - ; rnLocalBindsAndThen binds $ \binds' -> do +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 _ (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 @@ -803,17 +802,15 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by _ _)) thing_inside ; return (([L loc (TransformStmt stmts' used_bndrs using' by' return_op bind_op)], thing), fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } -rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside +rnStmt ctxt (L loc (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_explicit = explicit + , grpS_using = using })) thing_inside = do { -- Rename the 'using' expression in the context before the transform is begun - ; (using', fvs1) <- case using of - Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) } - Right _ - | isMonadCompExpr ctxt -> - do { (e', fvs) <- lookupSyntaxName groupMName - ; return (Right e', fvs) } - | otherwise -> - do { (e', fvs) <- lookupSyntaxName groupWithName - ; return (Right e', fvs) } + let implicit_name | isMonadCompExpr ctxt = groupMName + | otherwise = groupWithName + ; (using', fvs1) <- if explicit + then rnLExpr using + else do { (e,fvs) <- lookupSyntaxName implicit_name + ; return (noLoc e, fvs) } -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression @@ -841,7 +838,10 @@ rnStmt ctxt (L loc (GroupStmt stmts _ by using _ _ _)) thing_inside -- See Note [GroupStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) - ; return (([L loc (GroupStmt stmts' bndr_map by' using' return_op bind_op fmap_op)], thing), all_fvs) } + ; return (([L loc (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bndr_map + , grpS_by = by', grpS_using = using', grpS_explicit = explicit + , grpS_ret = return_op, grpS_bind = bind_op + , grpS_fmap = fmap_op })], thing), all_fvs) } type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts @@ -958,9 +958,11 @@ rn_rec_stmt_lhs :: MiniFixityEnv -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR Name RdrName, FreeVars)] -rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) = return [(L loc (ExprStmt expr a b c), - -- this is actually correct - emptyFVs)] +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 (LastStmt expr a)) + = return [(L loc (LastStmt expr a), emptyFVs)] rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) = do @@ -1014,6 +1016,12 @@ rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt -- 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 + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt expr' ret_op))] } + rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _ = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> @@ -1198,6 +1206,20 @@ program. %************************************************************************ \begin{code} +checkEmptyStmts :: HsStmtContext Name -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) + +okEmpty :: HsStmtContext Name -> Bool +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 + ---------------------- -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name @@ -1207,11 +1229,11 @@ checkStmt :: HsStmtContext Name checkStmt ctxt is_last (L _ stmt) = do { dflags <- getDOpts ; case okStmt dflags ctxt is_last stmt of - Nothing -> return () - Just extr -> addErr (msg $$ extra) } + Nothing -> return () + Just extra -> addErr (msg $$ extra) } where - msg = ptext (sLit "Unexpected") <+> pprStmtCat stmt - <+> ptext (sLit "statement in") <+> pprStmtContext ctxt + msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") + , ptext (sLit "in") <+> pprAStmtContext ctxt ] pprStmtCat :: Stmt a -> SDoc pprStmtCat (TransformStmt {}) = ptext (sLit "transform") @@ -1232,49 +1254,42 @@ okStmt, okDoStmt, okCompStmt :: DynFlags -> HsStmtContext Name -> Bool -> 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 dflags GhciStmt is_last stmt - = case stmt of - ExprStmt {} -> isOK - BindStmt {} -> isOK - LetStmt {} -> isOK - _ -> notOK - -okStmt dflags (PatGuard {}) is_last stmt +okStmt _ (PatGuard {}) _ stmt = case stmt of ExprStmt {} -> isOK BindStmt {} -> isOK LetStmt {} -> isOK _ -> notOK -okStmt dflags (ParStmtCtxt ctxt) is_last stmt +okStmt dflags (ParStmtCtxt ctxt) _ stmt = case stmt of LetStmt (HsIPBinds {}) -> notOK - _ -> okStmt dflags ctxt is_last stmt + _ -> okStmt dflags ctxt False stmt + -- NB: is_last=False in recursive + -- call; the branches of of a Par + -- not finish with a LastStmt -okStmt dflags (TransformStmtCtxt ctxt) is_last stmt - = okStmt dflags ctxt is_last stmt +okStmt dflags (TransformStmtCtxt ctxt) _ stmt + = okStmt dflags ctxt False stmt -okStmt ctxt is_last stmt - | isDoExpr ctxt = okDoStmt ctxt is_last stmt - | isCompExpr ctxt = okCompStmt ctxt is_last stmt - | otherwise = pprPanic "okStmt" (pprStmtContext ctxt) +okStmt dflags ctxt is_last stmt + | isDoExpr ctxt = okDoStmt dflags ctxt is_last stmt + | isListCompExpr ctxt = okCompStmt dflags ctxt is_last stmt + | otherwise = pprPanic "okStmt" (pprStmtContext ctxt) ---------------- okDoStmt dflags ctxt is_last stmt | is_last = case stmt of LastStmt {} -> isOK - _ -> Just (ptext (sLit "The last statement in") <+> what <+> - ptext (sLIt "construct must be an expression")) - where - what = case ctxt of - DoExpr -> ptext (sLit "a 'do'") - MDoExpr -> ptext (sLit "an 'mdo'") - _ -> panic "checkStmt" + _ -> Just (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt + <+> ptext (sLit "must be an expression")) | otherwise = case stmt of - RecStmt {} -> isOK -- Shouldn't we test a flag? + RecStmt {} + | Opt_DoRec `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XDoRec")) BindStmt {} -> isOK LetStmt {} -> isOK ExprStmt {} -> isOK @@ -1282,68 +1297,28 @@ okDoStmt dflags ctxt is_last stmt ---------------- -okCompStmt dflags ctxt is_last stmt +okCompStmt dflags _ is_last stmt | is_last = case stmt of LastStmt {} -> Nothing - -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error + _ -> pprPanic "Unexpected stmt" (ppr stmt) -- Not a user error | otherwise = case stmt of BindStmt {} -> isOK LetStmt {} -> isOK ExprStmt {} -> isOK - RecStmt {} -> notOK ParStmt {} - | dopt dflags Opt_ParallelListComp -> isOK + | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) TransformStmt {} - | dopt dflags Opt_transformListComp -> isOK + | Opt_TransformListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) GroupStmt {} - | dopt dflags Opt_transformListComp -> isOK + | Opt_TransformListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) - - -checkStmt :: HsStmtContext Name -> Stmt RdrName -> Maybe SDoc --- Non-last stmt - -checkStmt (ParStmtCtxt _) (HsIPBinds binds) - = Just (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds) - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. - -checkStmt ctxt (RecStmt {}) - | not (isDoExpr ctxt) - = addErr (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt) - ---------- -checkParStmt :: HsStmtContext Name -> RnM () -checkParStmt _ - = do { monad_comp <- xoptM Opt_MonadComprehensions - ; unless monad_comp $ do - { parallel_list_comp <- xoptM Opt_ParallelListComp - ; checkErr parallel_list_comp msg } - } - where - msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp or -XMonadComprehensions") - ---------- -checkTransformStmt :: HsStmtContext Name -> RnM () -checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the - -- desugarer will break when we come to operate on a parallel array - = do { transform_list_comp <- xoptM Opt_TransformListComp - ; checkErr transform_list_comp msg } - where - msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp or -XMonadComprehensions") -checkTransformStmt MonadComp -- Monad comprehensions are always fine, since the - -- MonadComprehensions flag will already be turned on - = do { return () } -checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension -checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension -checkTransformStmt ctxt = addErr msg - where - msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt + LastStmt {} -> notOK + RecStmt {} -> notOK --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 8fdb47c..5d92738 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -206,18 +206,17 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig ; return (GRHSs grhss' binds') } tc_grhs res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $ + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ tcGuardedCmd env body stk' ; return (GRHS guards' rhs') } ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsDo do_or_lc stmts body _ _ty) (cmd_stk, res_ty) +tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $ - tcGuardedCmd env body [] - ; return (HsDo do_or_lc stmts' body' noSyntaxExpr res_ty) } + ; stmts' <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty + ; return (HsDo do_or_lc stmts' res_ty) } where tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcCmd env rhs ([], ty) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index f7e5d39..dba87d2 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -893,7 +893,7 @@ gen_Read_binds get_fixity loc tycon read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo DoExpr (match_con con ++ [mkExprStmt (result_expr con [])])] + [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the @@ -967,7 +967,7 @@ gen_Read_binds get_fixity loc tycon ------------------------------------------------------------------------ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo DoExpr (ss ++ [mkExprStmt b])] + , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP con_app con as = nlHsVarApps (getRdrName con) as -- con as result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 518582f..7692271 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -743,7 +743,7 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) 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_rec_rets = rets, redS_ret_ty = ret_ty }) + , recS_rec_rets = rets, recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs ; new_ret_ty <- zonkTcTypeToType env ret_ty @@ -782,16 +782,20 @@ zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_o ; bind_op' <- zonkExpr env' bind_op ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr' return_op' bind_op') } -zonkStmt env (GroupStmt stmts binderMap by using return_op bind_op liftM_op) +zonkStmt env (GroupStmt { grpS_stmts = stmts, grpS_bndrs = binderMap + , grpS_by = by, grpS_explicit = explicit, grpS_using = using + , grpS_ret = return_op, grpS_bind = bind_op, grpS_fmap = liftM_op }) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using + ; using' <- zonkLExpr env using ; return_op' <- zonkExpr env' return_op ; bind_op' <- zonkExpr env' bind_op ; liftM_op' <- zonkExpr env' liftM_op ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt stmts' binderMap' by' using' return_op' bind_op' liftM_op') } + ; return (env'', GroupStmt { grpS_stmts = stmts', grpS_bndrs = binderMap' + , grpS_by = by', grpS_explicit = explicit, grpS_using = using' + , grpS_ret = return_op', grpS_bind = bind_op', grpS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 60bf7e2..820e517 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -8,7 +8,7 @@ TcMatches: Typecheck some @Matches@ \begin{code} module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, TcMatchCtxt(..), - tcStmts, tcDoStmts, tcBody, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, tcDoStmt, tcMDoStmt, tcGuardStmt ) where @@ -224,7 +224,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId) tcGRHS ctxt res_ty (GRHS guards rhs) - = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $ + = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs ; return (GRHS guards' rhs') } where @@ -245,7 +245,7 @@ tcDoStmts :: HsStmtContext Name -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts res_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty ; return $ mkHsWrapCoI coi (HsDo ListComp stmts' (mkListTy elt_ty)) } @@ -267,7 +267,7 @@ tcDoStmts MonadComp stmts res_ty = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty ; return (HsDo MonadComp stmts' res_ty) } -tcDoStmts ctxt _ _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcBody body res_ty @@ -298,7 +298,7 @@ tcStmts :: HsStmtContext Name -> TcRhoType -> TcM [LStmt TcId] tcStmts ctxt stmt_chk stmts res_ty - = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_check stmts res_ty $ + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ()) ; return stmts' } @@ -357,9 +357,9 @@ tcGuardStmt _ stmt _ _ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) -> TcStmtChecker -tcLcStmt m_tc ctxt (LastStmt body _) elt_ty thing_inside +tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside = do { body' <- tcMonoExpr body elt_ty - ; thing <- thing_inside elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") ; return (LastStmt body' noSyntaxExpr, thing) } -- A generator, pat <- rhs @@ -407,7 +407,7 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside loop ((stmts, names) : pairs) = do { (stmts', (ids, pairs', thing)) - <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> + <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> do { ids <- tcLookupLocalIds names ; (pairs', thing) <- loop pairs ; return (ids, pairs', thing) } @@ -415,7 +415,7 @@ tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_ty thing_inside = do (stmts', (binders', usingExpr', maybeByExpr', thing)) <- - tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do + tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do let alphaListTy = mkTyConApp m_tc [alphaTy] (usingExpr', maybeByExpr') <- @@ -442,11 +442,13 @@ tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr _ _) elt_t return (TransformStmt stmts' binders' usingExpr' maybeByExpr' noSyntaxExpr noSyntaxExpr, thing) -tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using _ _ _) elt_ty thing_inside +tcLcStmt m_tc ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bindersMap + , grpS_by = by, grpS_using = using + , grpS_explicit = explicit }) elt_ty thing_inside = do { let (bndr_names, list_bndr_names) = unzip bindersMap ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <- - tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do + tcStmtsAndThen (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do (by', using_ty) <- case by of Nothing -> -- check that using :: forall a. [a] -> [[a]] @@ -471,14 +473,14 @@ tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using _ _ _) elt_ty thing_insi bindersMap' = bndr_ids `zip` list_bndr_ids -- See Note [GroupStmt binder map] in HsExpr - ; using' <- case using of - Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') } - Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) } + ; using' <- tcPolyExpr using using_ty -- Type check the thing in the environment with -- these new binders and return the result ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty') - ; return (GroupStmt stmts' bindersMap' by' using' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) } + ; return (emptyGroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap' + , grpS_by = by', grpS_using = using' + , grpS_explicit = explicit }, thing) } where alphaListTy = mkTyConApp m_tc [alphaTy] alphaListListTy = mkTyConApp m_tc [alphaListTy] @@ -496,12 +498,13 @@ tcLcStmt _ _ stmt _ _ tcMcStmt :: TcStmtChecker -tcMcStmt ctxt (LastStmt body return_op) res_ty thing_inside +tcMcStmt _ (LastStmt body return_op) res_ty thing_inside = do { a_ty <- newFlexiTyVarTy liftedTypeKind ; return_op' <- tcSyntaxOp MCompOrigin return_op (a_ty `mkFunTy` res_ty) ; body' <- tcMonoExpr body a_ty - ; return (body', return_op') } + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt body' return_op', thing) } -- Generators for monad comprehensions ( pat <- rhs ) -- @@ -561,7 +564,7 @@ tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_ ty_dummy <- newFlexiTyVarTy liftedTypeKind ; (stmts', (binders', usingExpr', maybeByExpr', return_op', bind_op', thing)) <- - tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \res_ty' -> do + tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts ty_dummy $ \res_ty' -> do { (_, (m_ty, _)) <- matchExpectedAppTy res_ty' ; (usingExpr', maybeByExpr') <- case maybeByExpr of @@ -627,10 +630,14 @@ tcMcStmt ctxt (TransformStmt stmts binders usingExpr maybeByExpr return_op bind_ -- [ body | stmts, then group using f ] -- -> f :: forall a. m a -> m (m a) -- -tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) res_ty thing_inside - = do { m1_ty <- newFlexiTyVarTy liftedTypeKind - ; m2_ty <- newFlexiTyVarTy liftedTypeKind - ; n_ty <- newFlexiTyVarTy liftedTypeKind +tcMcStmt ctxt (GroupStmt { grpS_stmts = stmts, grpS_bndrs = bindersMap + , grpS_by = by, grpS_using = using, grpS_explicit = explicit + , grpS_ret = return_op, grpS_bind = bind_op + , grpS_fmap = fmap_op }) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m1_ty <- newFlexiTyVarTy star_star_kind + ; m2_ty <- newFlexiTyVarTy star_star_kind + ; n_ty <- newFlexiTyVarTy star_star_kind ; tup_ty_var <- newFlexiTyVarTy liftedTypeKind ; new_res_ty <- newFlexiTyVarTy liftedTypeKind ; let (bndr_names, n_bndr_names) = unzip bindersMap @@ -640,8 +647,10 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re -- typically something like [(Int,Bool,Int)] -- We don't know what tuple_ty is yet, so we use a variable ; (stmts', (bndr_ids, by_e_ty, return_op')) <- - tcStmts (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do - { by_e_ty <- mapM tcInferRhoNC by_e + tcStmtsAndThen (TransformStmtCtxt ctxt) tcMcStmt stmts m1_tup_ty $ \res_ty' -> do + { by_e_ty <- case by of + Nothing -> return Nothing + Just e -> do { e_ty <- tcInferRhoNC e; return (Just e_ty) } -- Find the Ids (and hence types) of all old binders ; bndr_ids <- tcLookupLocalIds bndr_names @@ -671,40 +680,34 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re `mkFunTy` res_ty --------------- Typecheck the 'using' function ------------- - ; let using_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy` + ; let poly_fun_ty = (m1_ty `mkAppTy` alphaTy) `mkFunTy` (m2_ty `mkAppTy` (n_ty `mkAppTy` alphaTy)) using_poly_ty = case by_e_ty of - Nothing -> mkForAllTy alphaTyVar using_fun_ty + Nothing -> mkForAllTy alphaTyVar poly_fun_ty -- using :: forall a. m1 a -> m2 (n a) Just (_,t_ty) -> mkForAllTy alphaTyVar $ - (alphaTy `mkFunTy` t_ty) `mkFunTy` using_fun_ty + (alphaTy `mkFunTy` t_ty) `mkFunTy` poly_fun_ty -- using :: forall a. (a->t) -> m1 a -> m2 (n a) -- where by :: t - ; using' <- case using of - Left e -> do { e' <- tcPolyExpr e using_poly_ty - ; return (Left e') } - Right e -> do { e' <- tcPolyExpr (noLoc e) using_poly_ty - ; return (Right (unLoc e')) } + ; using' <- tcPolyExpr using using_poly_ty ; coi <- unifyType (applyTy using_poly_ty tup_ty) (case by_e_ty of Nothing -> using_fun_ty Just (_,t_ty) -> (tup_ty `mkFunTy` t_ty) `mkFunTy` using_fun_ty) - ; let final_using = mkHsWrapCoI coi (HsWrap (WpTyApp tup_ty) using') + ; let final_using = fmap (mkHsWrapCoI coi . HsWrap (WpTyApp tup_ty)) using' --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- fmap unLoc . tcPolyExpr (noLoc fmap_op) $ mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ - (alphaTy `mkFunTy` betaTy) - `mkFunTy` - (m_ty `mkAppTy` alphaTy) - `mkFunTy` - (m_ty `mkAppTy` betaTy) + (alphaTy `mkFunTy` betaTy) + `mkFunTy` (n_ty `mkAppTy` alphaTy) + `mkFunTy` (n_ty `mkAppTy` betaTy) ; let mk_n_bndr :: Name -> TcId -> TcId mk_n_bndr n_bndr_name bndr_id - = mkLocalId bndr_name (n_ty `mkAppTy` idType bndr_id) + = mkLocalId n_bndr_name (n_ty `mkAppTy` idType bndr_id) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` @@ -716,9 +719,10 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re -- return the result ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside res_ty) - ; return (GroupStmt stmts' bindersMap' - (fmap fst by_e_ty) final_using - return_op' bind_op' fmap_op', thing) } + ; return (GroupStmt { grpS_stmts = stmts', grpS_bndrs = bindersMap' + , grpS_by = fmap fst by_e_ty, grpS_using = final_using + , grpS_ret = return_op', grpS_bind = bind_op' + , grpS_fmap = fmap_op', grpS_explicit = explicit }, thing) } -- Typecheck `ParStmt`. See `tcLcStmt` for more informations about typechecking -- of `ParStmt`s. @@ -733,6 +737,8 @@ tcMcStmt ctxt (GroupStmt stmts bindersMap by using return_op bind_op fmap_op) re -- 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? + ; (pairs', thing) <- loop m_ty bndr_stmts_s ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ @@ -757,12 +763,10 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $ mkForAllTy alphaTyVar $ alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy) - ; return_op' <- tcSyntaxOp MCompOrigin return_op - (bndr_ty `mkFunTy` m_bndr_ty) ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) } - where mk_tuple_ty tys = foldr (\tn tm -> mkBoxedTupleTy [tn, tm]) (last tys) (init tys) + where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys -- loop :: Type -- m_ty -- -> [([LStmt Name], [Name])] @@ -774,7 +778,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi = do { -- type dummy since we don't know all binder types yet ty_dummy <- newFlexiTyVarTy liftedTypeKind ; (stmts', (ids, pairs', thing)) - <- tcStmts ctxt tcMcStmt stmts ty_dummy $ \res_ty' -> + <- 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 @@ -790,9 +794,9 @@ tcMcStmt _ stmt _ _ tcDoStmt :: TcStmtChecker -tcDoStmt ctxt (LastStmt body _) res_ty thing_inside - = do { body' <- tcMonoExpr body res_ty - ; thing <- thing_inside body_ty +tcDoStmt _ (LastStmt body _) res_ty thing_inside + = do { body' <- tcMonoExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") ; return (LastStmt body' noSyntaxExpr, thing) } tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside @@ -849,7 +853,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; tcExtendIdEnv tup_ids $ do { stmts_ty <- newFlexiTyVarTy liftedTypeKind ; (stmts', (ret_op', tup_rets)) - <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> + <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys -- Unify the types of the "final" Ids (which may -- be polymorphic) with those of "knot-tied" Ids @@ -916,9 +920,9 @@ 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 + ; tcExtendIdEnv rec_ids $ do { (stmts', (later_ids, rec_rets)) - <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' -> + <- 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 @@ -930,12 +934,13 @@ tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames -- some of them with polymorphic things with the same Name -- (see note [RecStmt] in HsExpr) - ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing) + ; 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/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b9f7913..7b1d5a6 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1269,11 +1269,25 @@ tcGhciStmts stmts let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ; - + tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope - -- mk_return builds the expression + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + traceTc "TcRnDriver.tcGhciStmts: done" empty ; + let { -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] -- -- Despite the inconvenience of building the type applications etc, @@ -1284,27 +1298,14 @@ tcGhciStmts stmts -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt tc_stmts (mk_return ids) noSyntaxExpr io_ret_ty)) + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} -- 1.7.10.4