diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 94 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 40 |
2 files changed, 56 insertions, 78 deletions
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index fba270ce23..6dd1381611 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -864,48 +864,24 @@ data StmtLR idL idR -- 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 + -- bound by the stmts and used after themp - -- "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 - -- within this transform statement that are used after it - - (LHsExpr idR) -- "then f" - - (Maybe (LHsExpr idR)) -- "by e" (optional) - - (SyntaxExpr idR) -- The 'return' function for inner monad - -- comprehensions - (SyntaxExpr idR) -- The '(>>=)' operator. - -- See Note [Monad Comprehensions] - - | GroupStmt { - grpS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + | TransStmt { + trS_form :: TransForm, + trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' -- which generates the tuples to be grouped - grpS_bndrs :: [(idR, idR)], -- See Note [GroupStmt binder map] + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] - grpS_by :: Maybe (LHsExpr idR), -- "by e" (optional) - - 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) - - -- 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 + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) @@ -943,6 +919,15 @@ data StmtLR idL idR -- be quite as simple as (m (tya, tyb, tyc)). } deriving (Data, Typeable) + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e + | GroupFormU -- group using f or group using f by e + | GroupFormB -- group by e + -- In the GroupByFormB, trS_using is filled in with + -- 'groupWith' (list comprehensions) or + -- 'groupM' (monad comprehensions) + deriving (Data, Typeable) \end{code} Note [The type of bind in Stmts] @@ -956,9 +941,9 @@ exotic type, such as 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] +Note [TransStmt binder map] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The [(idR,idR)] in a GroupStmt behaves as follows: +The [(idR,idR)] in a TransStmt behaves as follows: * Before renaming: [] @@ -1098,11 +1083,8 @@ pprStmt (ExprStmt expr _ _ _) = ppr expr pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss) where doStmts stmts = ptext (sLit "| ") <> ppr stmts -pprStmt (TransformStmt stmts bndrs using by _ _) - = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by]) - -pprStmt (GroupStmt { grpS_stmts = stmts, grpS_by = by, grpS_using = using, grpS_explicit = explicit }) - = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using explicit]) +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) + = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) @@ -1117,14 +1099,15 @@ pprTransformStmt bndrs using by , nest 2 (ppr using) , nest 2 (pprBy by)] -pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> LHsExpr id -> Bool +pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id) + -> LHsExpr id -> TransForm -> SDoc -pprGroupStmt by using explicit - = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 pp_using ] - where - pp_using | explicit = ptext (sLit "using") <+> ppr using - | otherwise = empty +pprTransStmt by using ThenForm + = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by _ GroupFormB + = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ] +pprTransStmt by using GroupFormU + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc pprBy Nothing = empty @@ -1412,8 +1395,7 @@ pprStmtInCtxt ctxt stmt 2 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! - 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 + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 51a0de35c7..5e8dda3fcf 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -43,7 +43,7 @@ module HsUtils( -- Stmts mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, - emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -196,9 +196,6 @@ mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id -mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR - mkLastStmt :: LHsExpr idR -> StmtLR idL idR mkExprStmt :: LHsExpr idR -> StmtLR idL idR mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR @@ -225,22 +222,23 @@ mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr -mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing noSyntaxExpr noSyntaxExpr -mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr - +mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -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 } +emptyTransStmt :: StmtLR idL idR +emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noSyntaxExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss + , trS_by = Just b, trS_using = u } mkLastStmt expr = LastStmt expr noSyntaxExpr mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType @@ -512,9 +510,8 @@ collectStmtBinders (ExprStmt {}) = [] collectStmtBinders (LastStmt {}) = [] collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -659,9 +656,8 @@ 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 { grpS_stmts = stmts }) = hs_lstmts stmts - hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (TransStmt { trS_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 |