X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=7930caa00d2a10c13ec3085c6b4015919b51cc9c;hb=f278f0676579f67075033a4f9857715909c4b71e;hp=fd4f6db8ebe59941e79f1b3237990b1024ef6d14;hpb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;p=ghc-hetmet.git diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index fd4f6db..7930caa 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -3,6 +3,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -24,6 +25,9 @@ import DataCon import SrcLoc import Outputable import FastString + +-- libraries: +import Data.Data hiding (Fixity) \end{code} @@ -275,6 +279,7 @@ data HsExpr id | HsWrap HsWrapper -- TRANSLATION (HsExpr id) + deriving (Data, Typeable) -- HsTupArg is used for tuple sections -- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3] @@ -282,6 +287,7 @@ data HsExpr id data HsTupArg id = Present (LHsExpr id) -- The argument | Missing PostTcType -- The argument is missing, but this is its type + deriving (Data, Typeable) tupArgPresent :: HsTupArg id -> Bool tupArgPresent (Present {}) = True @@ -587,6 +593,7 @@ type HsCmd id = HsExpr id type LHsCmd id = LHsExpr id data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving (Data, Typeable) \end{code} The legal constructors for commands are: @@ -640,6 +647,7 @@ data HsCmdTop id PostTcType -- return type of the command (SyntaxTable id) -- after type checking: -- names used in the command's desugaring + deriving (Data, Typeable) \end{code} %************************************************************************ @@ -681,6 +689,7 @@ data MatchGroup id PostTcType -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns + deriving (Data, Typeable) type LMatch id = Located (Match id) @@ -690,6 +699,7 @@ data Match id (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking (GRHSs id) + deriving (Data, Typeable) isEmptyMatchGroup :: MatchGroup id -> Bool isEmptyMatchGroup (MatchGroup ms _) = null ms @@ -712,13 +722,14 @@ data GRHSs id = GRHSs { grhssGRHSs :: [LGRHS id], -- ^ Guarded RHSs grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause - } + } deriving (Data, Typeable) type LGRHS id = Located (GRHS id) -- | Guarded Right Hand Side. data GRHS id = GRHS [LStmt id] -- Guards (LHsExpr id) -- Right hand side + deriving (Data, Typeable) \end{code} We know the list must have at least one @Match@ in it. @@ -808,15 +819,6 @@ type LStmtLR idL idR = Located (StmtLR idL idR) type Stmt id = StmtLR id id -data GroupByClause id - = GroupByNothing (LHsExpr id) -- Using expression, i.e. - -- "then group using f" ==> GroupByNothing f - | GroupBySomething (Either (LHsExpr id) (SyntaxExpr id)) (LHsExpr id) - -- "then group using f by e" ==> GroupBySomething (Left f) e - -- "then group by e" ==> GroupBySomething (Right _) e: in - -- this case the expression is filled - -- in by the renamer - -- The SyntaxExprs in here are used *only* for do-notation, which -- has rebindable syntax. Otherwise they are unused. data StmtLR idL idR @@ -827,7 +829,7 @@ data StmtLR idL idR -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | ExprStmt (LHsExpr idR) + | ExprStmt (LHsExpr idR) -- See Note [ExprStmt] (SyntaxExpr idR) -- The (>>) operator PostTcType -- Element type of the RHS (used for arrows) @@ -838,18 +840,32 @@ data StmtLR idL idR -- After renaming, the ids are the binders bound by the stmts and used -- after them - | TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR)) - -- After renaming, the IDs are the binders occurring within this - -- transform statement that are used after it - -- "qs, then f by e" ==> TransformStmt (qs, binders) f (Just e) - -- "qs, then f" ==> TransformStmt (qs, binders) f Nothing + -- "qs, then f by e" ==> TransformStmt qs binders f (Just e) + -- "qs, then f" ==> TransformStmt qs binders f Nothing + | 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" - | GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR) - -- After renaming, the IDs are the binders occurring within this - -- transform statement that are used after it which are paired with - -- the names which they group over in statements + (Maybe (LHsExpr idR)) -- "by e" (optional) - -- Recursive statement (see Note [RecStmt] below) + | GroupStmt + [LStmt idL] -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + [(idR, idR)] -- See Note [GroupStmt binder map] + + (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' + + + -- Recursive statement (see Note [How RecStmt works] below) | RecStmt { recS_stmts :: [LStmtLR idL idR] @@ -882,8 +898,29 @@ data StmtLR idL idR , recS_dicts :: DictBinds idR -- Method bindings of Ids bound by the -- RecStmt, and used afterwards } + deriving (Data, Typeable) \end{code} +Note [GroupStmt binder map] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The [(idR,idR)] in a GroupStmt behaves as follows: + + * Before renaming: [] + + * After renaming: + [ (x27,x27), ..., (z35,z35) ] + These are the variables + 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. + + * After typechecking: + [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] + Each pair has the same unique, but different *types*. + +Note [ExprStmt] +~~~~~~~~~~~~~~~ ExprStmts are a bit tricky, because what they mean depends on the context. Consider the following contexts: @@ -959,43 +996,57 @@ pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] pprStmt (ExprStmt expr _ _) = ppr expr pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss) where doStmts stmts = ptext (sLit "| ") <> ppr stmts -pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr) - = (hsep [stmtsDoc, ptext (sLit "then"), ppr usingExpr, byExprDoc]) - where stmtsDoc = interpp'SP stmts - byExprDoc = maybe empty (\byExpr -> hsep [ptext (sLit "by"), ppr byExpr]) maybeByExpr -pprStmt (GroupStmt (stmts, _) groupByClause) = (hsep [stmtsDoc, ptext (sLit "then group"), pprGroupByClause groupByClause]) - where stmtsDoc = interpp'SP stmts -pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids, recS_later_ids = later_ids }) + +pprStmt (TransformStmt stmts _ using by) + = sep (ppr_lc_stmts stmts ++ [pprTransformStmt using by]) + +pprStmt (GroupStmt stmts _ by using) + = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) = ptext (sLit "rec") <+> vcat [ braces (vcat (map ppr segment)) , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids , ptext (sLit "later_ids=") <> ppr later_ids])] -pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc -pprGroupByClause (GroupByNothing usingExpr) = hsep [ptext (sLit "using"), ppr usingExpr] -pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit "by"), ppr byExpr, usingExprDoc] - where usingExprDoc = either (\usingExpr -> hsep [ptext (sLit "using"), ppr usingExpr]) (const empty) eitherUsingExpr +pprTransformStmt :: OutputableBndr id => LHsExpr id -> Maybe (LHsExpr id) -> SDoc +pprTransformStmt using by = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] + +pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) + -> Either (LHsExpr id) (SyntaxExpr is) + -> SDoc +pprGroupStmt by using + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)] + where + ppr_using (Right _) = empty + ppr_using (Left e) = ptext (sLit "using") <+> ppr e + +pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc +pprBy Nothing = empty +pprBy (Just e) = ptext (sLit "by") <+> ppr e pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body -pprDo ListComp stmts body = pprComp brackets stmts body -pprDo PArrComp stmts body = pprComp pa_brackets stmts body +pprDo ListComp stmts body = brackets $ pprComp stmts body +pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr 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 body - = lbrace <+> pprDeeperList vcat ([ ppr s <> semi | s <- stmts] ++ [ppr body]) + = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body]) <+> rbrace -pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc -pprComp brack quals body - = brack $ - hang (ppr body <+> char '|') - 4 (interpp'SP quals) +ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] +ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts] + +pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc +pprComp quals body -- Prints: body | qual1, ..., qualn + = hang (ppr body <+> char '|') 2 (interpp'SP quals) \end{code} %************************************************************************ @@ -1008,6 +1059,7 @@ pprComp brack quals body data HsSplice id = HsSplice -- $z or $(f 4) id -- The id is just a unique name to (LHsExpr id) -- identify this splice point + deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsSplice id) where ppr = pprSplice @@ -1023,6 +1075,7 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | DecBrG (HsGroup id) -- [d| decls |]; result of renamer | TypBr (LHsType id) -- [t| type |] | VarBr id -- 'x, ''T + deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsBracket id) where ppr = pprHsBracket @@ -1061,6 +1114,7 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) + deriving (Data, Typeable) \end{code} \begin{code} @@ -1094,7 +1148,7 @@ data HsMatchContext id -- Context of a Match -- runtime error message to generate] | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] - deriving () + deriving (Data, Typeable) data HsStmtContext id = ListComp @@ -1107,6 +1161,7 @@ data HsStmtContext id | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + deriving (Data, Typeable) \end{code} \begin{code} @@ -1202,5 +1257,10 @@ 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) - 4 (ppr stmt) + 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 (TransformStmt _ _ using by) = pprTransformStmt using by + ppr_stmt stmt = pprStmt stmt \end{code}