diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 13 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 152 | ||||
| -rw-r--r-- | compiler/hsSyn/HsLit.lhs | 4 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 26 |
4 files changed, 115 insertions, 80 deletions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index c9cbfeffb5..5933e9d5fa 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 f7b693f157..cf9c0d7402 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 c29083c63b..4a565ff8ba 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 0d91e9f796..de883f25a5 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 |