X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=dbdd24c3c5b75e2e5cf19bddded19d5fc061d17f;hb=ac10f8408520a30e8437496d320b8b86afda2e8f;hp=64eb26dc814d0443df4a821838967d62dc8dcb7a;hpb=203a687fbdb9bf54592f907302d8e47e174bb549;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 64eb26d..dbdd24c 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -10,26 +10,23 @@ module HsExpr where -- friends: import HsDecls ( HsGroup ) -import HsBinds ( HsBinds(..), nullBinds ) -import HsPat ( Pat ) -import HsLit ( HsLit, HsOverLit ) -import HsTypes ( HsType, PostTcType, SyntaxName ) +import HsPat ( LPat ) +import HsLit ( HsLit(..), HsOverLit ) +import HsTypes ( LHsType, PostTcType ) import HsImpExp ( isOperator, pprHsVar ) +import HsBinds ( HsLocalBinds, DictBinds, ExprCoFn, isEmptyLocalBinds ) -- others: -import ForeignCall ( Safety ) -import PprType ( pprParendType ) -import Type ( Type, TyThing ) +import Type ( Type, pprParendType ) import Var ( TyVar, Id ) import Name ( Name ) -import DataCon ( DataCon ) -import CStrings ( CLabelString, pprCLabelString ) -import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) -import SrcLoc ( SrcLoc ) +import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) ) +import SrcLoc ( Located(..), unLoc ) import Outputable import FastString \end{code} + %************************************************************************ %* * \subsection{Expressions proper} @@ -37,15 +34,64 @@ import FastString %************************************************************************ \begin{code} +type LHsExpr id = Located (HsExpr id) + +------------------------- +-- PostTcExpr is an evidence expression attached to the +-- syntax tree by the type checker (c.f. postTcType) +-- We use a PostTcTable where there are a bunch of pieces of +-- evidence, more than is convenient to keep individually +type PostTcExpr = HsExpr Id +type PostTcTable = [(Name, Id)] + +noPostTcExpr :: PostTcExpr +noPostTcExpr = HsLit (HsString FSLIT("noPostTcExpr")) + +noPostTcTable :: PostTcTable +noPostTcTable = [] + +------------------------- +-- SyntaxExpr is like PostTcExpr, but it's filled in a little earlier, +-- by the renamer. It's used for rebindable syntax. +-- E.g. (>>=) is filled in before the renamer by the appropriate Name +-- for (>>=), and then instantiated by the type checker with its +-- type args tec + +type SyntaxExpr id = HsExpr id + +noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, + -- (if the syntax slot makes no sense) +noSyntaxExpr = HsLit (HsString FSLIT("noSyntaxExpr")) + + +type SyntaxTable id = [(Name, SyntaxExpr id)] +-- *** Currently used only for CmdTop (sigh) *** +-- * Before the renamer, this list is noSyntaxTable +-- +-- * 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 + +noSyntaxTable :: SyntaxTable id +noSyntaxTable = [] + + +------------------------- data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter - | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker + | HsOverLit (HsOverLit id) -- Overloaded literals | HsLit HsLit -- Simple (non-overloaded) literals - | HsLam (Match id) -- lambda - | HsApp (HsExpr id) -- application - (HsExpr id) + | HsLam (MatchGroup id) -- Currently always a single match + + | HsApp (LHsExpr id) -- Application + (LHsExpr id) -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -53,56 +99,49 @@ data HsExpr id -- 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) -- 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. + | OpApp (LHsExpr id) -- left operand + (LHsExpr id) -- operator + Fixity -- Renamer adds fixity; bottom until then + (LHsExpr id) -- right operand - | NegApp (HsExpr id) -- negated expr - SyntaxName -- Name of 'negate' (see RnEnv.lookupSyntaxName) + | NegApp (LHsExpr id) -- negated expr + (SyntaxExpr id) -- Name of 'negate' - | HsPar (HsExpr id) -- parenthesised expr + | HsPar (LHsExpr id) -- parenthesised expr - | SectionL (HsExpr id) -- operand - (HsExpr id) -- operator - | SectionR (HsExpr id) -- operator - (HsExpr id) -- operand + | SectionL (LHsExpr id) -- operand + (LHsExpr id) -- operator + | SectionR (LHsExpr id) -- operator + (LHsExpr id) -- operand - | HsCase (HsExpr id) - [Match id] - SrcLoc + | HsCase (LHsExpr id) + (MatchGroup id) - | HsIf (HsExpr id) -- predicate - (HsExpr id) -- then part - (HsExpr id) -- else part - SrcLoc + | HsIf (LHsExpr id) -- predicate + (LHsExpr id) -- then part + (LHsExpr id) -- else part - | HsLet (HsBinds id) -- let(rec) - (HsExpr id) + | HsLet (HsLocalBinds id) -- let(rec) + (LHsExpr id) | 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 - [id] -- Ids for [return,fail,>>=,>>] - -- Brutal but simple - -- Before type checking, used for rebindable syntax - PostTcType -- Type of the whole expression - SrcLoc + [LStmt id] -- "do":one or more stmts + (LHsExpr id) -- The body; the last expression in the 'do' + -- of [ body | ... ] in a list comp + PostTcType -- Type of the whole expression | ExplicitList -- syntactic list PostTcType -- Gives type of components of list - [HsExpr id] + [LHsExpr id] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] PostTcType -- type of elements of the parallel array - [HsExpr id] + [LHsExpr id] | ExplicitTuple -- tuple - [HsExpr id] + [LHsExpr id] -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components @@ -110,66 +149,76 @@ data HsExpr id -- Record construction - | RecordCon id -- The constructor + | RecordCon (Located id) -- The constructor. After type checking + -- it's the dataConWrapId of the constructor + PostTcExpr -- Data con Id applied to type args (HsRecordBinds id) - | RecordConOut DataCon - (HsExpr id) -- Data con Id applied to type args - (HsRecordBinds id) - - -- Record update - | RecordUpd (HsExpr id) + | RecordUpd (LHsExpr id) (HsRecordBinds id) - - | RecordUpdOut (HsExpr id) -- TRANSLATION - Type -- Type of *input* record - Type -- Type of *result* record (may differ from + PostTcType -- Type of *input* record + PostTcType -- Type of *result* record (may differ from -- type of input record) - (HsRecordBinds id) - | ExprWithTySig -- signature binding - (HsExpr id) - (HsType id) - | ArithSeqIn -- arithmetic sequence - (ArithSeqInfo id) - | ArithSeqOut - (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) + | ExprWithTySig -- e :: type + (LHsExpr id) + (LHsType id) + + | ExprWithTySigOut -- TRANSLATION + (LHsExpr id) + (LHsType Name) -- Retain the signature for round-tripping purposes + + | ArithSeq -- arithmetic sequence + PostTcExpr (ArithSeqInfo id) - | HsCCall CLabelString -- call into the C world; string is - [HsExpr id] -- the C function; exprs are the - -- arguments to pass. - Safety -- True <=> might cause Haskell - -- garbage-collection (must generate - -- more paranoid code) - Bool -- True <=> it's really a "casm" - -- NOTE: this CCall is the *boxed* - -- version; the desugarer will convert - -- it into the unboxed "ccall#". - PostTcType -- The result type; will be *bottom* - -- until the typechecker gets ahold of it + | PArrSeq -- arith. sequence for parallel array + PostTcExpr -- [:e1..e2:] or [:e1, e2..e3:] + (ArithSeqInfo id) | HsSCC FastString -- "set cost centre" (_scc_) annotation - (HsExpr id) -- expr whose cost is to be measured + (LHsExpr id) -- expr whose cost is to be measured + + | HsCoreAnn FastString -- hdaume: core annotation + (LHsExpr id) + ----------------------------------------------------------- -- MetaHaskell Extensions - | HsBracket (HsBracket id) SrcLoc + | HsBracket (HsBracket id) | 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 + | HsSpliceE (HsSplice id) + + ----------------------------------------------------------- + -- Arrow notation extension + + | HsProc (LPat id) -- arrow abstraction, proc + (LHsCmdTop id) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- The following are commands, not expressions proper + + | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr 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) + + | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr 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 + [LHsCmdTop id] -- argument commands \end{code} @@ -179,12 +228,12 @@ The renamer translates them into the Right Thing. \begin{code} | EWildPat -- wildcard - | EAsPat id -- as pattern - (HsExpr id) + | EAsPat (Located id) -- as pattern + (LHsExpr id) - | ELazyPat (HsExpr id) -- ~ pattern + | ELazyPat (LHsExpr id) -- ~ pattern - | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y + | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y \end{code} Everything from here on appears only in typechecker output. @@ -192,24 +241,26 @@ Everything from here on appears only in typechecker output. \begin{code} | TyLam -- TRANSLATION [TyVar] - (HsExpr id) + (LHsExpr id) | TyApp -- TRANSLATION - (HsExpr id) -- generated by Spec + (LHsExpr id) -- generated by Spec [Type] -- DictLam and DictApp are "inverses" | DictLam [id] - (HsExpr id) + (LHsExpr id) | DictApp - (HsExpr id) + (LHsExpr id) [id] -type PendingSplice = (Name, HsExpr Id) -- Typechecked splices, waiting to be + | HsCoerce ExprCoFn -- TRANSLATION + (HsExpr id) + +type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be -- pasted back in by the desugarer \end{code} - A @Dictionary@, unless of length 0 or 1, becomes a tuple. A @ClassDictLam dictvars methods expr@ is, therefore: \begin{verbatim} @@ -225,24 +276,27 @@ instance OutputableBndr id => Outputable (HsExpr id) where pprExpr :: OutputableBndr id => HsExpr id -> SDoc pprExpr e = pprDeeper (ppr_expr e) + +pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc pprBinds b = pprDeeper (ppr b) +ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + 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) = pprMatch LambdaExpr match - -ppr_expr expr@(HsApp e1 e2) - = let (fun, args) = collect_args expr [] in - (ppr_expr fun) <+> (sep (map ppr_expr args)) +ppr_expr (HsApp e1 e2) + = let (fun, args) = collect_args e1 [e2] in + (ppr_lexpr fun) <+> (sep (map pprParendExpr args)) where - collect_args (HsApp fun arg) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) + collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) ppr_expr (OpApp e1 op fixity e2) - = case op of + = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where @@ -250,22 +304,17 @@ ppr_expr (OpApp e1 op fixity e2) pp_e2 = pprParendExpr e2 pp_prefixly - = hang (pprExpr op) 4 (sep [pp_e1, pp_e2]) + = hang (ppr op) 4 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, hsep [pp_v_op, pp_e2]] - where - ppr_v = ppr v - pp_v_op | isOperator ppr_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 -ppr_expr (HsPar e) = parens (ppr_expr e) +ppr_expr (HsPar e) = parens (ppr_lexpr e) ppr_expr (SectionL expr op) - = case op of + = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where @@ -273,10 +322,10 @@ ppr_expr (SectionL expr op) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext SLIT("x_ )")]) - pp_infixly v = parens (sep [pp_expr, ppr v]) + pp_infixly v = parens (sep [pp_expr, pprInfix v]) ppr_expr (SectionR op expr) - = case op of + = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where @@ -285,72 +334,61 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) 4 ((<>) pp_expr rparen) pp_infixly v - = parens (sep [ppr v, pp_expr]) + = parens (sep [pprInfix v, pp_expr]) -ppr_expr (HsCase expr matches _) - = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")], +ppr_expr (HsLam matches) + = pprMatches LambdaExpr matches + +ppr_expr (HsCase expr matches) + = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], nest 2 (pprMatches CaseAlt matches) ] -ppr_expr (HsIf e1 e2 e3 _) - = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")], - nest 4 (pprExpr e2), +ppr_expr (HsIf e1 e2 e3) + = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")], + nest 4 (ppr e2), ptext SLIT("else"), - nest 4 (pprExpr e3)] + nest 4 (ppr e3)] -- special case: let ... in let ... -ppr_expr (HsLet binds expr@(HsLet _ _)) +ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]), - pprExpr expr] + ppr_lexpr expr] ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), hang (ptext SLIT("in")) 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts +ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body ppr_expr (ExplicitList _ exprs) - = brackets (fsep (punctuate comma (map ppr_expr exprs))) + = brackets (fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (fsep (punctuate comma (map ppr_expr exprs))) + = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitTuple exprs boxity) - = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) + = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) -ppr_expr (RecordCon con_id rbinds) +ppr_expr (RecordCon con_id con_expr rbinds) = pp_rbinds (ppr con_id) rbinds -ppr_expr (RecordConOut data_con con rbinds) - = pp_rbinds (ppr con) rbinds -ppr_expr (RecordUpd aexp rbinds) - = pp_rbinds (pprParendExpr aexp) rbinds -ppr_expr (RecordUpdOut aexp _ _ rbinds) +ppr_expr (RecordUpd aexp rbinds _ _) = pp_rbinds (pprParendExpr aexp) rbinds ppr_expr (ExprWithTySig expr sig) - = hang (nest 2 (ppr_expr expr) <+> dcolon) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) +ppr_expr (ExprWithTySigOut expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) -ppr_expr (ArithSeqIn info) - = brackets (ppr 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 (ArithSeq expr info) = brackets (ppr info) +ppr_expr (PArrSeq expr info) = pa_brackets (ppr info) -ppr_expr EWildPat = char '_' +ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e -ppr_expr (HsCCall fun args _ is_asm result_ty) - = hang (if is_asm - then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''") - else ptext SLIT("_ccall_") <+> pprCLabelString fun) - 4 (sep (map pprParendExpr args)) - ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] @@ -358,34 +396,67 @@ ppr_expr (TyLam tyvars expr) = hang (hsep [ptext SLIT("/\\"), hsep (map (pprBndr LambdaBind) tyvars), ptext SLIT("->")]) - 4 (ppr_expr expr) + 4 (ppr_lexpr expr) ppr_expr (TyApp expr [ty]) - = hang (ppr_expr expr) 4 (pprParendType ty) + = hang (ppr_lexpr expr) 4 (pprParendType ty) ppr_expr (TyApp expr tys) - = hang (ppr_expr expr) + = hang (ppr_lexpr expr) 4 (brackets (interpp'SP tys)) ppr_expr (DictLam dictvars expr) = hang (hsep [ptext SLIT("\\{-dict-}"), hsep (map (pprBndr LambdaBind) dictvars), ptext SLIT("->")]) - 4 (ppr_expr expr) + 4 (ppr_lexpr expr) ppr_expr (DictApp expr [dname]) - = hang (ppr_expr expr) 4 (ppr dname) + = hang (ppr_lexpr expr) 4 (ppr dname) ppr_expr (DictApp expr dnames) - = hang (ppr_expr expr) + = hang (ppr_lexpr expr) 4 (brackets (interpp'SP dnames)) +ppr_expr (HsCoerce co_fn e) = ppr_expr e + 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 (HsSpliceE s) = pprSplice s +ppr_expr (HsBracket b) = pprHsBracket b +ppr_expr (HsBracketOut e []) = ppr e +ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps + +ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) + = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd] + +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, ptext SLIT(">-"), ppr_lexpr arrow] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, ptext SLIT("-<<"), ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, ptext SLIT(">>-"), ppr_lexpr arrow] + +ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]] +ppr_expr (HsArrForm op _ args) + = hang (ptext SLIT("(|") <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> ptext SLIT("|)")) + +pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc +pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _) + = ppr_lexpr cmd +pprCmdArg (HsCmdTop cmd _ _ _) + = parens (ppr_lexpr 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 -- @@ -395,24 +466,97 @@ pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") Parenthesize unless very simple: \begin{code} -pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc - +pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprParendExpr expr = let - pp_as_was = pprExpr expr + pp_as_was = ppr_lexpr expr + -- Using ppr_expr here avoids the call to 'deeper' + -- Not sure if that's always right. in - case expr of - HsLit l -> ppr l - HsOverLit l -> ppr l - - HsVar _ -> pp_as_was - HsIPVar _ -> pp_as_was - ExplicitList _ _ -> pp_as_was - ExplicitPArr _ _ -> pp_as_was - ExplicitTuple _ _ -> pp_as_was - HsPar _ -> pp_as_was - - _ -> parens pp_as_was + case unLoc expr of + HsLit l -> ppr l + HsOverLit l -> ppr l + + HsVar _ -> pp_as_was + HsIPVar _ -> pp_as_was + ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was + ExplicitTuple _ _ -> pp_as_was + HsPar _ -> pp_as_was + HsBracket _ -> pp_as_was + HsBracketOut _ [] -> pp_as_was + + _ -> parens pp_as_was +\end{code} + +%************************************************************************ +%* * +\subsection{Commands (in arrow abstractions)} +%* * +%************************************************************************ + +We re-use HsExpr to represent these. + +\begin{code} +type HsCmd id = HsExpr id + +type LHsCmd id = LHsExpr 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 (HsLocalBinds 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 + 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} +type LHsCmdTop id = Located (HsCmdTop id) + +data HsCmdTop id + = HsCmdTop (LHsCmd id) + [PostTcType] -- types of inputs on the command's stack + PostTcType -- return type of the command + (SyntaxTable id) + -- after type checking: + -- names used in the command's desugaring \end{code} %************************************************************************ @@ -422,18 +566,17 @@ pprParendExpr expr %************************************************************************ \begin{code} -type HsRecordBinds id = [(id, HsExpr id)] +type HsRecordBinds id = [(Located id, LHsExpr id)] recBindFields :: HsRecordBinds id -> [id] -recBindFields rbinds = [field | (field,_) <- rbinds] +recBindFields rbinds = [unLoc 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) = hsep [pprBndr LetBind v, char '=', ppr e] + pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e] \end{code} @@ -459,61 +602,64 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} +data MatchGroup id + = MatchGroup + [LMatch id] -- The alternatives + PostTcType -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + +type LMatch id = Located (Match id) + data Match id = Match - [Pat id] -- The patterns - (Maybe (HsType id)) -- A type signature for the result of the match + [LPat id] -- The patterns + (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking - (GRHSs id) --- GRHSs are used both for pattern bindings and for Matches -data GRHSs id - = GRHSs [GRHS id] -- Guarded RHSs - (HsBinds id) -- The where clause - PostTcType -- Type of RHS (after type checking) - -data GRHS id - = GRHS [Stmt id] -- The RHS is the final ResultStmt - SrcLoc +matchGroupArity :: MatchGroup id -> Arity +matchGroupArity (MatchGroup (match:matches) _) + = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches ) + -- Assertion just checks that all the matches have the same number of pats + n_pats + where + n_pats = length (hsLMatchPats match) -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) +hsLMatchPats :: LMatch id -> [LPat id] +hsLMatchPats (L _ (Match pats _ _)) = pats -unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] -unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] -\end{code} +-- GRHSs are used both for pattern bindings and for Matches +data GRHSs id + = GRHSs [LGRHS id] -- Guarded RHSs + (HsLocalBinds id) -- The where clause -@getMatchLoc@ takes a @Match@ and returns the -source-location gotten from the GRHS inside. -THis is something of a nuisance, but no more. +type LGRHS id = Located (GRHS id) -\begin{code} -getMatchLoc :: Match id -> SrcLoc -getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc +data GRHS id = GRHS [LStmt id] -- Guards + (LHsExpr id) -- Right hand side \end{code} We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc -pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches) +pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc +pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc +pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc pprFunBind fun matches = pprMatches (FunRhs fun) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: (OutputableBndr id) - => Pat id -> GRHSs id -> SDoc +pprPatBind :: (OutputableBndr bndr, OutputableBndr id) + => LPat bndr -> GRHSs id -> SDoc pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] 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, + ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] where pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will @@ -527,29 +673,23 @@ pprMatch ctxt (Match pats maybe_ty grhss) pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc -pprGRHSs ctxt (GRHSs grhss binds ty) - = vcat (map (pprGRHS ctxt) grhss) +pprGRHSs ctxt (GRHSs grhss binds) + = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ - (if nullBinds binds then empty - else text "where" $$ nest 4 (pprDeeper (ppr binds))) - + (if isEmptyLocalBinds binds then empty + else text "where" $$ nest 4 (pprBinds binds)) pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc -pprGRHS ctxt (GRHS [ResultStmt expr _] locn) +pprGRHS ctxt (GRHS [] expr) = pp_rhs ctxt expr -pprGRHS ctxt (GRHS guarded locn) +pprGRHS ctxt (GRHS guards expr) = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] - where - ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards - guards = init guarded pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} - - %************************************************************************ %* * \subsection{Do stmts and list comprehensions} @@ -557,32 +697,49 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} +type LStmt id = Located (Stmt id) + +-- The SyntaxExprs in here are used *only* for do-notation, which +-- has rebindable syntax. Otherwise they are unused. 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 + = BindStmt (LPat id) + (LHsExpr id) + (SyntaxExpr id) -- The (>>=) operator + (SyntaxExpr id) -- The fail operator + -- The fail operator is noSyntaxExpr + -- if the pattern match can't fail + + | ExprStmt (LHsExpr id) + (SyntaxExpr id) -- The (>>) operator + PostTcType -- Element type of the RHS (used for arrows) + + | LetStmt (HsLocalBinds id) -- ParStmts only occur in a list comprehension - | ParStmt [[Stmt id]] -- List comp only: parallel set of quals - | ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders - -- bound by the stmts - - -- mdo-notation (only exists after renamer) - -- The ids are a subset of the variables bound by the stmts that - -- either (a) are used before they are bound in the stmts - -- or (b) are used in stmts that follow the RecStmt - | RecStmt [id] - [Stmt id] - [HsExpr id] -- Post type-checking only; these expressions correspond - -- 1-to-1 with the [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. + | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders + -- bound by the stmts and used subsequently + + -- Recursive statement (see Note [RecStmt] below) + | RecStmt [LStmt 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 + + --- These fields are only valid after typechecking + [PostTcExpr] -- 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*. + (DictBinds id) -- Method bindings of Ids bound by the RecStmt, + -- and used afterwards \end{code} -ExprStmts and ResultStmts are a bit tricky, because what they mean +ExprStmts are a bit tricky, because what they mean depends on the context. Consider the following contexts: A do expression of type (m res_ty) @@ -591,10 +748,6 @@ depends on the context. Consider the following contexts: E :: m any_ty Translation: E >> ... - * ResultStmt E: do { ....; E } - E :: m res_ty - Translation: E - A list comprehensions of type [elt_ty] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * ExprStmt E Bool: [ .. | .... E ] @@ -603,55 +756,59 @@ depends on the context. Consider the following contexts: E :: Bool Translation: if E then fail else ... - * ResultStmt E: [ E | ... ] - E :: elt_ty - Translation: return E - A guard list, guarding a RHS of type rhs_ty ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * ExprStmt E Bool: f x | ..., E, ... = ...rhs... E :: Bool Translation: if E then fail else ... - * ResultStmt E: f x | ...guards... = E - E :: rhs_ty - Translation: E - Array comprehensions are handled like list comprehensions -=chak -\begin{code} -consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id] -consLetStmt EmptyBinds stmts = stmts -consLetStmt binds stmts = LetStmt binds : stmts -\end{code} +Note [RecStmt] +~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt [a::forall a. a -> a, b] + [a::Int -> Int, c] + [ BindStmt b (return x) + , LetStmt a = ea + , BindStmt c ec ] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + This 'a' is *polymorphic' + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + This 'a' is monomorphic + +Nota Bene: the two a's have different types, even though they +have the same Name. + \begin{code} 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 (RecStmt _ segment _) = vcat (map ppr segment) - -pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc -pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) -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 +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 (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) +pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) + +pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc +pprDo DoExpr stmts body = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts) $$ ppr body) +pprDo (MDoExpr _) stmts body = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts) $$ ppr body) +pprDo ListComp stmts body = pprComp brackets stmts body +pprDo PArrComp stmts body = pprComp pa_brackets stmts body + +pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc +pprComp brack quals body + = brack $ + hang (ppr body <+> char '|') + 4 (interpp'SP quals) \end{code} %************************************************************************ @@ -661,10 +818,22 @@ pprComp brack stmts = brack $ %************************************************************************ \begin{code} -data HsBracket id = ExpBr (HsExpr id) - | PatBr (Pat id) - | DecBr (HsGroup id) - | TypBr (HsType id) +data HsSplice id = HsSplice -- $z or $(f 4) + id -- The id is just a unique name to + (LHsExpr id) -- identify this splice point + +instance OutputableBndr id => Outputable (HsSplice id) where + ppr = pprSplice + +pprSplice :: OutputableBndr id => HsSplice id -> SDoc +pprSplice (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e + + +data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] + | PatBr (LPat id) -- [p| pat |] + | DecBr (HsGroup id) -- [d| decls |] + | TypBr (LHsType id) -- [t| type |] + | VarBr id -- 'x, ''T instance OutputableBndr id => Outputable (HsBracket id) where ppr = pprHsBracket @@ -674,26 +843,14 @@ 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) - +pprHsBracket (VarBr n) = char '\'' <> ppr n + -- Infelicity: can't show ' vs '', because + -- we can't ask n what its OccName is, because the + -- pretty-printer for HsExpr doesn't ask for NamedThings + -- But the pretty-printer for names will show the OccName class 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} %************************************************************************ @@ -704,14 +861,14 @@ instance Outputable ReifyFlavour where \begin{code} data ArithSeqInfo id - = From (HsExpr id) - | FromThen (HsExpr id) - (HsExpr id) - | FromTo (HsExpr id) - (HsExpr id) - | FromThenTo (HsExpr id) - (HsExpr id) - (HsExpr id) + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) \end{code} \begin{code} @@ -737,6 +894,7 @@ 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] @@ -746,7 +904,9 @@ data HsMatchContext id -- Context of a Match data HsStmtContext id = ListComp | DoExpr - | MDoExpr -- Recursive do-expression + | MDoExpr PostTcTable -- Recursive do-expression + -- (tiresomely, it needs table + -- of its return/bind ops) | PArrComp -- Parallel array comprehension | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt @@ -754,15 +914,16 @@ data HsStmtContext id \begin{code} isDoExpr :: HsStmtContext id -> Bool -isDoExpr DoExpr = True -isDoExpr MDoExpr = True -isDoExpr other = False +isDoExpr DoExpr = True +isDoExpr (MDoExpr _) = True +isDoExpr other = False \end{code} \begin{code} 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" @@ -774,18 +935,20 @@ 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 (MDoExpr _) = ptext SLIT("an 'mdo' expression") pprStmtContext ListComp = ptext SLIT("a list comprehension") pprStmtContext PArrComp = ptext SLIT("an array comprehension") @@ -802,10 +965,11 @@ 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 (MDoExpr _)) = "'mdo' expression" matchContextErrString (StmtCtxt ListComp) = "list comprehension" matchContextErrString (StmtCtxt PArrComp) = "array comprehension" \end{code}