X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=6969de23f1b0b6e5048a96d2d54c077e831dd368;hb=98232a6130f0661486899530fa3461e32499366f;hp=91ddad3b9afe09c1babdf0bc68b3e8180e2b6b0d;hpb=32a895831dbc202fab780fdd8bee65be81e2d232;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 91ddad3..6969de2 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -9,24 +9,26 @@ module HsExpr where #include "HsVersions.h" -- friends: +import HsDecls ( HsGroup ) import HsBinds ( HsBinds(..), nullBinds ) -import HsTypes ( PostTcType ) +import HsPat ( Pat ) import HsLit ( HsLit, HsOverLit ) -import BasicTypes ( Fixity(..) ) -import HsTypes ( HsType ) -import HsImpExp ( isOperator ) +import HsTypes ( HsType, PostTcType, SyntaxName ) +import HsImpExp ( isOperator, pprHsVar ) -- others: -import Name ( Name ) import ForeignCall ( Safety ) -import Outputable import PprType ( pprParendType ) -import Type ( Type ) -import Var ( TyVar ) +import Type ( Type ) +import Var ( TyVar, Id ) +import Name ( Name ) +import NameSet ( FreeVars ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) -import BasicTypes ( IPName, Boxity, tupleParens ) +import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) import SrcLoc ( SrcLoc ) +import Outputable +import FastString \end{code} %************************************************************************ @@ -36,15 +38,15 @@ import SrcLoc ( SrcLoc ) %************************************************************************ \begin{code} -data HsExpr id pat +data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker | HsLit HsLit -- Simple (non-overloaded) literals - | HsLam (Match id pat) -- lambda - | HsApp (HsExpr id pat) -- application - (HsExpr id pat) + | HsLam (Match id) -- lambda + | HsApp (HsExpr id) -- application + (HsExpr id) -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -52,57 +54,54 @@ data HsExpr id pat -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (HsExpr id pat) -- left operand - (HsExpr id pat) -- operator - Fixity -- Renamer adds fixity; bottom until then - (HsExpr id pat) -- right operand + | OpApp (HsExpr id) -- left operand + (HsExpr id) -- operator + Fixity -- Renamer adds fixity; bottom until then + (HsExpr id) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. -- They are eventually removed by the type checker. - | NegApp (HsExpr id pat) -- negated expr - Name -- Name of 'negate' (see RnEnv.lookupSyntaxName) + | NegApp (HsExpr id) -- negated expr + SyntaxName -- Name of 'negate' (see RnEnv.lookupSyntaxName) - | HsPar (HsExpr id pat) -- parenthesised expr + | HsPar (HsExpr id) -- parenthesised expr - | SectionL (HsExpr id pat) -- operand - (HsExpr id pat) -- operator - | SectionR (HsExpr id pat) -- operator - (HsExpr id pat) -- operand + | SectionL (HsExpr id) -- operand + (HsExpr id) -- operator + | SectionR (HsExpr id) -- operator + (HsExpr id) -- operand - | HsCase (HsExpr id pat) - [Match id pat] + | HsCase (HsExpr id) + [Match id] SrcLoc - | HsIf (HsExpr id pat) -- predicate - (HsExpr id pat) -- then part - (HsExpr id pat) -- else part + | HsIf (HsExpr id) -- predicate + (HsExpr id) -- then part + (HsExpr id) -- else part SrcLoc - | HsLet (HsBinds id pat) -- let(rec) - (HsExpr id pat) - - | HsWith (HsExpr id pat) -- implicit parameter binding - [(IPName id, HsExpr id pat)] + | HsLet (HsBinds id) -- let(rec) + (HsExpr id) - | HsDo HsDoContext - [Stmt id pat] -- "do":one or more stmts - SrcLoc - - | HsDoOut HsDoContext - [Stmt id pat] -- "do":one or more stmts - id -- id for return - id -- id for >>= - id -- id for fail - Type -- Type of the whole expression + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + [Stmt id] -- "do":one or more stmts + (ReboundNames id) -- Ids for [return,fail,>>=,>>] + PostTcType -- Type of the whole expression SrcLoc | ExplicitList -- syntactic list PostTcType -- Gives type of components of list - [HsExpr id pat] + [HsExpr id] + + | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + PostTcType -- type of elements of the parallel array + [HsExpr id] | ExplicitTuple -- tuple - [HsExpr id pat] + [HsExpr id] -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components @@ -111,35 +110,39 @@ data HsExpr id pat -- Record construction | RecordCon id -- The constructor - (HsRecordBinds id pat) + (HsRecordBinds id) | RecordConOut DataCon - (HsExpr id pat) -- Data con Id applied to type args - (HsRecordBinds id pat) + (HsExpr id) -- Data con Id applied to type args + (HsRecordBinds id) -- Record update - | RecordUpd (HsExpr id pat) - (HsRecordBinds id pat) + | RecordUpd (HsExpr id) + (HsRecordBinds id) - | RecordUpdOut (HsExpr id pat) -- TRANSLATION + | RecordUpdOut (HsExpr id) -- TRANSLATION Type -- Type of *input* record Type -- Type of *result* record (may differ from -- type of input record) - [id] -- Dicts needed for construction - (HsRecordBinds id pat) + (HsRecordBinds id) | ExprWithTySig -- signature binding - (HsExpr id pat) + (HsExpr id) (HsType id) | ArithSeqIn -- arithmetic sequence - (ArithSeqInfo id pat) + (ArithSeqInfo id) | ArithSeqOut - (HsExpr id pat) -- (typechecked, of course) - (ArithSeqInfo id pat) + (HsExpr id) -- (typechecked, of course) + (ArithSeqInfo id) + | PArrSeqIn -- arith. sequence for parallel array + (ArithSeqInfo id) -- [:e1..e2:] or [:e1, e2..e3:] + | PArrSeqOut + (HsExpr id) -- (typechecked, of course) + (ArithSeqInfo id) | HsCCall CLabelString -- call into the C world; string is - [HsExpr id pat] -- the C function; exprs are the + [HsExpr id] -- the C function; exprs are the -- arguments to pass. Safety -- True <=> might cause Haskell -- garbage-collection (must generate @@ -151,11 +154,59 @@ data HsExpr id pat PostTcType -- The result type; will be *bottom* -- until the typechecker gets ahold of it - | HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation - (HsExpr id pat) -- expr whose cost is to be measured + | HsSCC FastString -- "set cost centre" (_scc_) annotation + (HsExpr id) -- expr whose cost is to be measured + + | HsCoreAnn FastString -- hdaume: core annotation + (HsExpr id) + + ----------------------------------------------------------- + -- MetaHaskell Extensions + | HsBracket (HsBracket id) SrcLoc + + | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original* + [PendingSplice] -- renamed expression, plus *typechecked* splices + -- to be pasted back in by the desugarer + + | HsSplice id (HsExpr id) SrcLoc -- $z or $(f 4) + -- The id is just a unique name to + -- identify this splice point + + | HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity + + ----------------------------------------------------------- + -- Arrow notation extension + + | HsProc (Pat id) -- arrow abstraction, proc + (HsCmdTop id) -- body of the abstraction + -- always has an empty stack + SrcLoc + + --------------------------------------- + -- The following are commands, not expressions proper + + | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (HsExpr id) -- arrow expression, f + (HsExpr id) -- input expression, arg + PostTcType -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + SrcLoc + + | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (HsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [HsCmdTop id] -- argument commands + SrcLoc \end{code} + These constructors only appear temporarily in the parser. The renamer translates them into the Right Thing. @@ -163,9 +214,9 @@ The renamer translates them into the Right Thing. | EWildPat -- wildcard | EAsPat id -- as pattern - (HsExpr id pat) + (HsExpr id) - | ELazyPat (HsExpr id pat) -- ~ pattern + | ELazyPat (HsExpr id) -- ~ pattern | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y \end{code} @@ -175,23 +226,38 @@ Everything from here on appears only in typechecker output. \begin{code} | TyLam -- TRANSLATION [TyVar] - (HsExpr id pat) + (HsExpr id) | TyApp -- TRANSLATION - (HsExpr id pat) -- generated by Spec + (HsExpr id) -- generated by Spec [Type] -- DictLam and DictApp are "inverses" | DictLam [id] - (HsExpr id pat) + (HsExpr id) | DictApp - (HsExpr id pat) + (HsExpr id) [id] -type HsRecordBinds id pat - = [(id, HsExpr id pat, Bool)] - -- True <=> source code used "punning", - -- i.e. {op1, op2} rather than {op1=e1, op2=e2} +type PendingSplice = (Name, HsExpr Id) -- Typechecked splices, waiting to be + -- pasted back in by the desugarer +\end{code} + +Table of bindings of names used in rebindable syntax. +This gets filled in by the renamer. + +\begin{code} +type ReboundNames id = [(Name, HsExpr id)] +-- * Before the renamer, this list is empty +-- +-- * After the renamer, it takes the form [(std_name, HsVar actual_name)] +-- For example, for the 'return' op of a monad +-- normal case: (GHC.Base.return, HsVar GHC.Base.return) +-- with rebindable syntax: (GHC.Base.return, return_22) +-- where return_22 is whatever "return" is in scope +-- +-- * After the type checker, it takes the form [(std_name, )] +-- where is the evidence for the method \end{code} A @Dictionary@, unless of length 0 or 1, becomes a tuple. A @@ -201,29 +267,22 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A \end{verbatim} \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (HsExpr id pat) where +instance OutputableBndr id => Outputable (HsExpr id) where ppr expr = pprExpr expr \end{code} \begin{code} -pprExpr :: (Outputable id, Outputable pat) - => HsExpr id pat -> SDoc +pprExpr :: OutputableBndr id => HsExpr id -> SDoc -pprExpr e = pprDeeper (ppr_expr e) +pprExpr e = pprDeeper (ppr_expr e) pprBinds b = pprDeeper (ppr b) -ppr_expr (HsVar v) - -- Put it in parens if it's an operator - | isOperator v = parens (ppr v) - | otherwise = ppr v - +ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsLam match) - = hsep [char '\\', nest 2 (pprMatch LambdaExpr match)] +ppr_expr (HsLam match) = pprMatch LambdaExpr match ppr_expr expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in @@ -244,11 +303,7 @@ ppr_expr (OpApp e1 op fixity e2) = hang (pprExpr op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, hsep [pp_v_op, pp_e2]] - where - pp_v_op | isOperator v = ppr v - | otherwise = char '`' <> ppr v <> char '`' - -- Put it in backquotes if it's not an operator already + = sep [pp_e1, hsep [pprInfix v, pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e @@ -296,15 +351,14 @@ ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), hang (ptext SLIT("in")) 2 (ppr expr)] -ppr_expr (HsWith expr binds) - = hsep [ppr expr, ptext SLIT("with"), pp_ipbinds binds] - -ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts -ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts +ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) = brackets (fsep (punctuate comma (map ppr_expr exprs))) +ppr_expr (ExplicitPArr _ exprs) + = pa_brackets (fsep (punctuate comma (map ppr_expr exprs))) + ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) @@ -315,7 +369,7 @@ ppr_expr (RecordConOut data_con con rbinds) ppr_expr (RecordUpd aexp rbinds) = pp_rbinds (pprParendExpr aexp) rbinds -ppr_expr (RecordUpdOut aexp _ _ _ rbinds) +ppr_expr (RecordUpdOut aexp _ _ rbinds) = pp_rbinds (pprParendExpr aexp) rbinds ppr_expr (ExprWithTySig expr sig) @@ -327,6 +381,11 @@ ppr_expr (ArithSeqIn info) ppr_expr (ArithSeqOut expr info) = brackets (ppr info) +ppr_expr (PArrSeqIn info) + = pa_brackets (ppr info) +ppr_expr (PArrSeqOut expr info) + = pa_brackets (ppr info) + ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e @@ -338,10 +397,12 @@ ppr_expr (HsCCall fun args _ is_asm result_ty) 4 (sep (map pprParendExpr args)) ppr_expr (HsSCC lbl expr) - = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext lbl), pprParendExpr expr ] + = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] ppr_expr (TyLam tyvars expr) - = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) + = hang (hsep [ptext SLIT("/\\"), + hsep (map (pprBndr LambdaBind) tyvars), + ptext SLIT("->")]) 4 (ppr_expr expr) ppr_expr (TyApp expr [ty]) @@ -352,7 +413,9 @@ ppr_expr (TyApp expr tys) 4 (brackets (interpp'SP tys)) ppr_expr (DictLam dictvars expr) - = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")]) + = hang (hsep [ptext SLIT("\\{-dict-}"), + hsep (map (pprBndr LambdaBind) dictvars), + ptext SLIT("->")]) 4 (ppr_expr expr) ppr_expr (DictApp expr [dname]) @@ -363,13 +426,50 @@ ppr_expr (DictApp expr dnames) 4 (brackets (interpp'SP dnames)) ppr_expr (HsType id) = ppr id - + +ppr_expr (HsSplice n e _) = char '$' <> brackets (ppr n) <> pprParendExpr e +ppr_expr (HsBracket b _) = pprHsBracket b +ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps +ppr_expr (HsReify r) = ppr r + +ppr_expr (HsProc pat (HsCmdTop cmd _ _ _) _) + = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), pprExpr cmd] + +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True _) + = hsep [pprExpr arrow, ptext SLIT("-<"), pprExpr arg] +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False _) + = hsep [pprExpr arg, ptext SLIT(">-"), pprExpr arrow] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True _) + = hsep [pprExpr arrow, ptext SLIT("-<<"), pprExpr arg] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False _) + = hsep [pprExpr arg, ptext SLIT(">>-"), pprExpr arrow] + +ppr_expr (HsArrForm (HsVar v) (Just _) [arg1, arg2] _) + = sep [pprCmdArg arg1, hsep [pprInfix v, pprCmdArg arg2]] +ppr_expr (HsArrForm op _ args _) + = hang (ptext SLIT("(|") <> pprExpr op) + 4 (sep (map pprCmdArg args) <> ptext SLIT("|)")) + +pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg (HsCmdTop cmd@(HsArrForm _ Nothing [] _) _ _ _) = pprExpr cmd +pprCmdArg (HsCmdTop cmd _ _ _) = parens (pprExpr cmd) + +-- Put a var in backquotes if it's not an operator already +pprInfix :: Outputable name => name -> SDoc +pprInfix v | isOperator ppr_v = ppr_v + | otherwise = char '`' <> ppr_v <> char '`' + where + ppr_v = ppr v + +-- add parallel array brackets around a document +-- +pa_brackets :: SDoc -> SDoc +pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} Parenthesize unless very simple: \begin{code} -pprParendExpr :: (Outputable id, Outputable pat) - => HsExpr id pat -> SDoc +pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc pprParendExpr expr = let @@ -382,6 +482,7 @@ pprParendExpr expr HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was ExplicitTuple _ _ -> pp_as_was HsPar _ -> pp_as_was @@ -390,34 +491,92 @@ pprParendExpr expr %************************************************************************ %* * +\subsection{Commands (in arrow abstractions)} +%* * +%************************************************************************ + +We re-use HsExpr to represent these. + +\begin{code} +type HsCmd id = HsExpr id + +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp +\end{code} + +The legal constructors for commands are: + + = HsArrApp ... -- as above + + | HsArrForm ... -- as above + + | HsApp (HsCmd id) + (HsExpr id) + + | HsLam (Match id) -- kappa + + -- the renamer turns this one into HsArrForm + | OpApp (HsExpr id) -- left operand + (HsCmd id) -- operator + Fixity -- Renamer adds fixity; bottom until then + (HsCmd id) -- right operand + + | HsPar (HsCmd id) -- parenthesised command + + | HsCase (HsExpr id) + [Match id] -- bodies are HsCmd's + SrcLoc + + | HsIf (HsExpr id) -- predicate + (HsCmd id) -- then part + (HsCmd id) -- else part + SrcLoc + + | HsLet (HsBinds id) -- let(rec) + (HsCmd id) + + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + [Stmt id] -- HsExpr's are really HsCmd's + (ReboundNames id) + PostTcType -- Type of the whole expression + SrcLoc + +Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. + +\begin{code} +data HsCmdTop id + = HsCmdTop (HsCmd id) + [PostTcType] -- types of inputs on the command's stack + PostTcType -- return type of the command + (ReboundNames id) + -- after type checking: + -- names used in the command's desugaring +\end{code} + +%************************************************************************ +%* * \subsection{Record binds} %* * %************************************************************************ \begin{code} -pp_rbinds :: (Outputable id, Outputable pat) - => SDoc - -> HsRecordBinds id pat -> SDoc +type HsRecordBinds id = [(id, HsExpr id)] + +recBindFields :: HsRecordBinds id -> [id] +recBindFields rbinds = [field | (field,_) <- rbinds] + +pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc pp_rbinds thing rbinds = hang thing 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) where - pp_rbind (v, e, pun_flag) - = getPprStyle $ \ sty -> - if pun_flag && userStyle sty then - ppr v - else - hsep [ppr v, char '=', ppr e] + pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e] \end{code} -\begin{code} -pp_ipbinds :: (Outputable id, Outputable pat) - => [(IPName id, HsExpr id pat)] -> SDoc -pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs)) - where - pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs -\end{code} %************************************************************************ @@ -441,32 +600,35 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} -data Match id pat +data Match id = Match - [pat] -- The patterns + [Pat id] -- The patterns (Maybe (HsType id)) -- A type signature for the result of the match -- Nothing after typechecking - (GRHSs id pat) + (GRHSs id) -- GRHSs are used both for pattern bindings and for Matches -data GRHSs id pat - = GRHSs [GRHS id pat] -- Guarded RHSs - (HsBinds id pat) -- The where clause +data GRHSs id + = GRHSs [GRHS id] -- Guarded RHSs + (HsBinds id) -- The where clause PostTcType -- Type of RHS (after type checking) -data GRHS id pat - = GRHS [Stmt id pat] -- The RHS is the final ResultStmt - -- I considered using a RetunStmt, but - -- it printed 'wrong' in error messages +data GRHS id + = GRHS [Stmt id] -- The RHS is the final ResultStmt SrcLoc -mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat +mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id mkSimpleMatch pats rhs rhs_ty locn = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) -unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] +unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] + +glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id +glueBindsOnGRHSs EmptyBinds grhss = grhss +glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) + = GRHSs grhss (binds1 `ThenBinds` binds2) ty \end{code} @getMatchLoc@ takes a @Match@ and returns the @@ -474,44 +636,43 @@ source-location gotten from the GRHS inside. THis is something of a nuisance, but no more. \begin{code} -getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc :: Match id -> SrcLoc getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc \end{code} We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (Outputable id, Outputable pat) - => HsMatchContext id -> [Match id pat] -> SDoc +pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches) -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (Outputable id, Outputable pat) - => id -> [Match id pat] -> SDoc +pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc pprFunBind fun matches = pprMatches (FunRhs fun) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: (Outputable id, Outputable pat) - => pat -> GRHSs id pat -> SDoc +pprPatBind :: (OutputableBndr id) + => Pat id -> GRHSs id -> SDoc pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] -pprMatch :: (Outputable id, Outputable pat) - => HsMatchContext id -> Match id pat -> SDoc +pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) = pp_name ctxt <+> sep [sep (map ppr pats), ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] where - pp_name (FunRhs fun) = ppr fun + pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will + -- have printed the signature + pp_name LambdaExpr = char '\\' pp_name other = empty + ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty Nothing -> empty -pprGRHSs :: (Outputable id, Outputable pat) - => HsMatchContext id -> GRHSs id pat -> SDoc +pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc pprGRHSs ctxt (GRHSs grhss binds ty) = vcat (map (pprGRHS ctxt) grhss) $$ @@ -519,8 +680,7 @@ pprGRHSs ctxt (GRHSs grhss binds ty) else text "where" $$ nest 4 (pprDeeper (ppr binds))) -pprGRHS :: (Outputable id, Outputable pat) - => HsMatchContext id -> GRHS id pat -> SDoc +pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc pprGRHS ctxt (GRHS [ResultStmt expr _] locn) = pp_rhs ctxt expr @@ -531,7 +691,7 @@ pprGRHS ctxt (GRHS guarded locn) ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards guards = init guarded -pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs) +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} @@ -543,15 +703,33 @@ pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -data Stmt id pat - = BindStmt pat (HsExpr id pat) SrcLoc - | LetStmt (HsBinds id pat) - | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow - | ExprStmt (HsExpr id pat) PostTcType SrcLoc -- See notes that follow +data Stmt id + = BindStmt (Pat id) (HsExpr id) SrcLoc + | LetStmt (HsBinds id) + | ResultStmt (HsExpr id) SrcLoc -- See notes that follow + | ExprStmt (HsExpr id) PostTcType SrcLoc -- See notes that follow -- The type is the *element type* of the expression - | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals - | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders - -- bound by the stmts + + -- ParStmts only occur in a list comprehension + | ParStmt [([Stmt id], [id])] -- After remaing, the ids are the binders + -- bound by the stmts and used subsequently + + -- Recursive statement + | RecStmt [Stmt id] + --- The next two fields are only valid after renaming + [id] -- The ids are a subset of the variables bound by the stmts + -- that are used in stmts that follow the RecStmt + + [id] -- Ditto, but these variables are the "recursive" ones, that + -- are used before they are bound in the stmts of the RecStmt + -- From a type-checking point of view, these ones have to be monomorphic + + --- This field is only valid after typechecking + [HsExpr id] -- These expressions correspond + -- 1-to-1 with the "recursive" [id], and are the expresions that + -- should be returned by the recursion. They may not quite be the + -- Ids themselves, because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*. \end{code} ExprStmts and ResultStmts are a bit tricky, because what they mean @@ -589,35 +767,80 @@ depends on the context. Consider the following contexts: E :: rhs_ty Translation: E +Array comprehensions are handled like list comprehensions -=chak \begin{code} -consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat] +consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id] consLetStmt EmptyBinds stmts = stmts consLetStmt binds stmts = LetStmt binds : stmts \end{code} \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (Stmt id pat) where +instance OutputableBndr id => Outputable (Stmt id) where ppr stmt = pprStmt stmt -pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] -pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] -pprStmt (ExprStmt expr _ _) = ppr expr -pprStmt (ResultStmt expr _) = ppr expr -pprStmt (ParStmt stmtss) - = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) -pprStmt (ParStmtOut stmtss) - = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] +pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] +pprStmt (ExprStmt expr _ _) = ppr expr +pprStmt (ResultStmt expr _) = ppr expr +pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (RecStmt segment _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) -pprDo :: (Outputable id, Outputable pat) => HsDoContext -> [Stmt id pat] -> SDoc +pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) -pprDo ListComp stmts = brackets $ - hang (pprExpr expr <+> char '|') - 4 (interpp'SP quals) - where - ResultStmt expr _ = last stmts -- Last stmt should - quals = init stmts -- be an ResultStmt +pprDo MDoExpr stmts = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts)) +pprDo ListComp stmts = pprComp brackets stmts +pprDo PArrComp stmts = pprComp pa_brackets stmts + +pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [Stmt id] -> SDoc +pprComp brack stmts = brack $ + hang (pprExpr expr <+> char '|') + 4 (interpp'SP quals) + where + ResultStmt expr _ = last stmts -- Last stmt should + quals = init stmts -- be an ResultStmt +\end{code} + +%************************************************************************ +%* * + Template Haskell quotation brackets +%* * +%************************************************************************ + +\begin{code} +data HsBracket id = ExpBr (HsExpr id) + | PatBr (Pat id) + | DecBr (HsGroup id) + | TypBr (HsType id) + +instance OutputableBndr id => Outputable (HsBracket id) where + ppr = pprHsBracket + + +pprHsBracket (ExpBr e) = thBrackets empty (ppr e) +pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d) +pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) + + +thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> + pp_body <+> ptext SLIT("|]") + +data HsReify id = Reify ReifyFlavour id -- Pre typechecking + | ReifyOut ReifyFlavour Name -- Post typechecking + -- The Name could be the name of + -- an Id, TyCon, or Class + +data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity + +instance Outputable id => Outputable (HsReify id) where + ppr (Reify flavour id) = ppr flavour <+> ppr id + ppr (ReifyOut flavour thing) = ppr flavour <+> ppr thing + +instance Outputable ReifyFlavour where + ppr ReifyDecl = ptext SLIT("reifyDecl") + ppr ReifyType = ptext SLIT("reifyType") + ppr ReifyFixity = ptext SLIT("reifyFixity") \end{code} %************************************************************************ @@ -627,20 +850,19 @@ pprDo ListComp stmts = brackets $ %************************************************************************ \begin{code} -data ArithSeqInfo id pat - = From (HsExpr id pat) - | FromThen (HsExpr id pat) - (HsExpr id pat) - | FromTo (HsExpr id pat) - (HsExpr id pat) - | FromThenTo (HsExpr id pat) - (HsExpr id pat) - (HsExpr id pat) +data ArithSeqInfo id + = From (HsExpr id) + | FromThen (HsExpr id) + (HsExpr id) + | FromTo (HsExpr id) + (HsExpr id) + | FromThenTo (HsExpr id) + (HsExpr id) + (HsExpr id) \end{code} \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (ArithSeqInfo id pat) where +instance OutputableBndr id => Outputable (ArithSeqInfo id) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -658,47 +880,84 @@ pp_dotdot = ptext SLIT(" .. ") %************************************************************************ \begin{code} -data HsMatchContext id -- Context of a Match or Stmt - = DoCtxt HsDoContext -- Do-stmt or list comprehension - | FunRhs id -- Function binding for f - | CaseAlt -- Guard on a case alternative - | LambdaExpr -- Lambda - | PatBindRhs -- Pattern binding - | RecUpd -- Record update +data HsMatchContext id -- Context of a Match + = FunRhs id -- Function binding for f + | CaseAlt -- Guard on a case alternative + | LambdaExpr -- Pattern of a lambda + | ProcExpr -- Pattern of a proc + | PatBindRhs -- Pattern binding + | RecUpd -- Record update [used only in DsExpr to tell matchWrapper + -- what sort of runtime error message to generate] + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension deriving () -data HsDoContext = ListComp | DoExpr +data HsStmtContext id + = ListComp + | DoExpr + | MDoExpr -- Recursive do-expression + | PArrComp -- Parallel array comprehension + | PatGuard (HsMatchContext id) -- Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt \end{code} \begin{code} -isDoExpr (DoCtxt DoExpr) = True -isDoExpr other = False +isDoExpr :: HsStmtContext id -> Bool +isDoExpr DoExpr = True +isDoExpr MDoExpr = True +isDoExpr other = False \end{code} \begin{code} -matchSeparator (FunRhs _) = SLIT("=") -matchSeparator CaseAlt = SLIT("->") -matchSeparator LambdaExpr = SLIT("->") -matchSeparator PatBindRhs = SLIT("=") -matchSeparator (DoCtxt _) = SLIT("<-") -matchSeparator RecUpd = panic "When is this used?" +matchSeparator (FunRhs _) = ptext SLIT("=") +matchSeparator CaseAlt = ptext SLIT("->") +matchSeparator LambdaExpr = ptext SLIT("->") +matchSeparator ProcExpr = ptext SLIT("->") +matchSeparator PatBindRhs = ptext SLIT("=") +matchSeparator (StmtCtxt _) = ptext SLIT("<-") +matchSeparator RecUpd = panic "unused" \end{code} \begin{code} -pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun) -pprMatchContext CaseAlt = ptext SLIT("In a case alternative") -pprMatchContext RecUpd = ptext SLIT("In a record-update construct") -pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding") -pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction") -pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding") -pprMatchContext (DoCtxt ListComp) = ptext SLIT("In a 'list comprehension' pattern binding") +pprMatchContext (FunRhs fun) = ptext SLIT("the definition of") <+> quotes (ppr fun) +pprMatchContext CaseAlt = ptext SLIT("a case alternative") +pprMatchContext RecUpd = ptext SLIT("a record-update construct") +pprMatchContext PatBindRhs = ptext SLIT("a pattern binding") +pprMatchContext LambdaExpr = ptext SLIT("a lambda abstraction") +pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction") +pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt + +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 RecUpd = panic "pprMatchRhsContext" + +pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c] +pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt +pprStmtContext DoExpr = ptext SLIT("a 'do' expression") +pprStmtContext MDoExpr = ptext SLIT("an 'mdo' expression") +pprStmtContext ListComp = ptext SLIT("a list comprehension") +pprStmtContext PArrComp = ptext SLIT("an array comprehension") + +-- 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 + -- Used to generate the string for a *runtime* error message -matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) -matchContextErrString CaseAlt = "case" -matchContextErrString PatBindRhs = "pattern binding" -matchContextErrString RecUpd = "record update" -matchContextErrString LambdaExpr = "lambda" -matchContextErrString (DoCtxt DoExpr) = "'do' expression" -matchContextErrString (DoCtxt ListComp) = "list comprehension" +matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) +matchContextErrString CaseAlt = "case" +matchContextErrString PatBindRhs = "pattern binding" +matchContextErrString RecUpd = "record update" +matchContextErrString LambdaExpr = "lambda" +matchContextErrString ProcExpr = "proc" +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = "pattern guard" +matchContextErrString (StmtCtxt DoExpr) = "'do' expression" +matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression" +matchContextErrString (StmtCtxt ListComp) = "list comprehension" +matchContextErrString (StmtCtxt PArrComp) = "array comprehension" \end{code}