X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=c2e4c8adbd3a529d1bba1ce0a8e15feacb354918;hp=2d111eeeec7107abd269993aa6d096d2e74b740e;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=bf40e268d916947786c56ec38db86190854a2d2c diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 2d111ee..c2e4c8a 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1,27 +1,36 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[HsExpr]{Abstract Haskell syntax: expressions} + +HsExpr: Abstract Haskell syntax: expressions \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module HsExpr where #include "HsVersions.h" -- friends: -import HsDecls ( HsGroup ) -import HsPat ( LPat ) -import HsLit ( HsLit(..), HsOverLit ) -import HsTypes ( LHsType, PostTcType ) -import HsImpExp ( isOperator, pprHsVar ) -import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds, - HsWrapper, pprHsWrapper ) +import HsDecls +import HsPat +import HsLit +import HsTypes +import HsImpExp +import HsBinds -- others: -import Var ( Id ) -import Name ( Name ) -import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) ) -import SrcLoc ( Located(..), unLoc ) +import Var +import Name +import BasicTypes +import DataCon +import SrcLoc import Outputable import FastString \end{code} @@ -85,7 +94,8 @@ noSyntaxTable = [] data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter - | HsOverLit (HsOverLit id) -- Overloaded literals + | HsOverLit (HsOverLit id) -- Overloaded literals + | HsLit HsLit -- Simple (non-overloaded) literals | HsLam (MatchGroup id) -- Currently always a single match @@ -157,9 +167,11 @@ data HsExpr id -- Record update | RecordUpd (LHsExpr id) (HsRecordBinds id) - PostTcType -- Type of *input* record - PostTcType -- Type of *result* record (may differ from - -- type of input record) + [DataCon] -- Filled in by the type checker to the *non-empty* + -- list of DataCons that have all the upd'd fields + [PostTcType] -- Argument types of *input* record type + [PostTcType] -- and *output* record type + -- For a type family, the arg types are of the *instance* tycon, not the family tycon | ExprWithTySig -- e :: type (LHsExpr id) @@ -185,6 +197,7 @@ data HsExpr id ----------------------------------------------------------- -- MetaHaskell Extensions + | HsBracket (HsBracket id) | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original* @@ -219,26 +232,44 @@ data HsExpr id (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} -These constructors only appear temporarily in the parser. -The renamer translates them into the Right Thing. + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + Int -- module-local tick number + [id] -- variables in scope + (LHsExpr id) -- sub-expression + + | HsBinTick + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr id) -- sub-expression + + | HsTickPragma -- A pragma introduced tick + (FastString,(Int,Int),(Int,Int)) -- external span for this tick + (LHsExpr id) + + --------------------------------------- + -- These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing. -\begin{code} | EWildPat -- wildcard | EAsPat (Located id) -- as pattern (LHsExpr id) + | EViewPat (LHsExpr id) -- view pattern + (LHsExpr id) + | ELazyPat (LHsExpr id) -- ~ pattern | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y -\end{code} -Everything from here on appears only in typechecker output. + --------------------------------------- + -- Finally, HsWrap appears only in typechecker output -\begin{code} | HsWrap HsWrapper -- TRANSLATION (HsExpr id) @@ -258,16 +289,34 @@ instance OutputableBndr id => Outputable (HsExpr id) where \end{code} \begin{code} -pprExpr :: OutputableBndr id => HsExpr id -> SDoc +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprLExpr (L _ e) = pprExpr e -pprExpr e = pprDeeper (ppr_expr e) - -pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc +pprExpr :: OutputableBndr id => HsExpr id -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar _) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp _ _) = True +isQuietHsExpr (OpApp _ _ _ _) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndr idL, OutputableBndr idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) +----------------------- ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) +ppr_expr :: OutputableBndr id => HsExpr id -> SDoc ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit @@ -289,8 +338,8 @@ ppr_expr (OpApp e1 op fixity e2) HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprParendExpr e1 -- Add parens to make precedence clear - pp_e2 = pprParendExpr e2 + pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr e2 -- to make precedence clear pp_prefixly = hang (ppr op) 2 (sep [pp_e1, pp_e2]) @@ -298,37 +347,37 @@ ppr_expr (OpApp e1 op fixity e2) pp_infixly v = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2] -ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e +ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e ppr_expr (SectionL expr op) = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_expr = pprParendExpr expr + pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext SLIT("x_ )")]) - pp_infixly v = parens (sep [pp_expr, pprInfix v]) + pp_infixly v = (sep [pp_expr, pprInfix v]) ppr_expr (SectionR op expr) = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_expr = pprParendExpr expr + pp_expr = pprDebugParendExpr expr pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")]) 4 ((<>) pp_expr rparen) pp_infixly v - = parens (sep [pprInfix v, pp_expr]) + = (sep [pprInfix v, pp_expr]) -ppr_expr (HsLam matches) - = pprMatches LambdaExpr matches +ppr_expr (HsLam matches :: HsExpr id) + = pprMatches (LambdaExpr :: HsMatchContext id) matches -ppr_expr (HsCase expr matches) +ppr_expr (HsCase expr matches :: HsExpr id) = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], - nest 2 (pprMatches CaseAlt matches) ] + nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ] ppr_expr (HsIf e1 e2 e3) = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")], @@ -348,19 +397,19 @@ ppr_expr (HsLet binds expr) 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_lexpr exprs))) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs))) + = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon con_id con_expr rbinds) - = pp_rbinds (ppr con_id) rbinds + = hang (ppr con_id) 2 (ppr rbinds) -ppr_expr (RecordUpd aexp rbinds _ _) - = pp_rbinds (pprParendExpr aexp) rbinds +ppr_expr (RecordUpd aexp rbinds _ _ _) + = hang (pprParendExpr aexp) 2 (ppr rbinds) ppr_expr (ExprWithTySig expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) @@ -379,7 +428,7 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] -ppr_expr (HsWrap co_fn e) = pprHsWrapper (ppr_expr e) co_fn +ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn ppr_expr (HsType id) = ppr id ppr_expr (HsSpliceE s) = pprSplice s @@ -390,6 +439,18 @@ 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 (HsTick tickId vars exp) + = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), hsep (map pprHsVar vars), ppr exp,ptext SLIT(")")] +ppr_expr (HsBinTick tickIdTrue tickIdFalse exp) + = hcat [ptext SLIT("bintick<"), + ppr tickIdTrue, + ptext SLIT(","), + ppr tickIdFalse, + ptext SLIT(">("), + ppr exp,ptext SLIT(")")] +ppr_expr (HsTickPragma externalSrcLoc exp) + = hcat [ptext SLIT("tickpragma<"), ppr externalSrcLoc,ptext SLIT(">("), ppr exp,ptext SLIT(")")] + ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg] ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) @@ -424,29 +485,53 @@ pa_brackets :: SDoc -> SDoc pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} -Parenthesize unless very simple: +HsSyn records exactly where the user put parens, with HsPar. +So generally speaking we print without adding any parens. +However, some code is internally generated, and in some places +parens are absolutely required; so for these places we use +pprParendExpr (but don't print double parens of course). + +For operator applications we don't add parens, because the oprerator +fixities should do the job, except in debug mode (-dppr-debug) so we +can see the structure of the parse tree. + \begin{code} +pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc +pprDebugParendExpr expr + = getPprStyle (\sty -> + if debugStyle sty then pprParendExpr expr + else pprLExpr expr) + pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprParendExpr expr = let - pp_as_was = ppr_lexpr expr - -- Using ppr_expr here avoids the call to 'deeper' - -- Not sure if that's always right. + pp_as_was = pprLExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right in 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 + HsLit l -> pp_as_was + HsOverLit l -> pp_as_was + 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 + HsDo sc _ _ _ + | isListCompExpr sc -> pp_as_was + _ -> parens pp_as_was + +isAtomicHsExpr :: HsExpr id -> Bool -- A single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr e = False \end{code} %************************************************************************ @@ -526,17 +611,7 @@ data HsCmdTop id %************************************************************************ \begin{code} -type HsRecordBinds id = [(Located id, LHsExpr id)] - -recBindFields :: HsRecordBinds id -> [id] -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 (unLoc v), char '=', ppr e] +type HsRecordBinds id = HsRecFields id (LHsExpr id) \end{code} @@ -605,45 +680,59 @@ data GRHS id = GRHS [LStmt id] -- Guards We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc +pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Don't print the type; it's only -- a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc -pprFunBind fun matches = pprMatches (FunRhs fun) matches +pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc +pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext pprPatBind :: (OutputableBndr bndr, OutputableBndr id) => LPat bndr -> GRHSs id -> SDoc -pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] +pprPatBind pat (grhss :: GRHSs id) = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc +pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) - = pp_name ctxt <+> sep [sep (map ppr pats), - ppr_maybe_ty, - nest 2 (pprGRHSs ctxt grhss)] + = herald <+> sep [sep (map ppr other_pats), + ppr_maybe_ty, + nest 2 (pprGRHSs ctxt grhss)] where - pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will - -- have printed the signature - pp_name LambdaExpr = char '\\' - pp_name other = empty + (herald, other_pats) + = case ctxt of + FunRhs fun is_infix + | not is_infix -> (ppr fun, pats) + -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + + | null pats3 -> (pp_infix, []) + -- x &&& y = e + + | otherwise -> (parens pp_infix, pats3) + -- (x &&& y) z = e + where + (pat1:pat2:pats3) = pats + pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2 + + LambdaExpr -> (char '\\', pats) + other -> (empty, pats) ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty Nothing -> empty -pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc +pprGRHSs :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHSs idR -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) - $$ - (if isEmptyLocalBinds binds then empty - else text "where" $$ nest 4 (pprBinds binds)) + $$ if isEmptyLocalBinds binds then empty + else text "where" $$ nest 4 (pprBinds binds) -pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc +pprGRHS :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> GRHS idR -> SDoc pprGRHS ctxt (GRHS [] expr) = pp_rhs ctxt expr @@ -661,35 +750,38 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -type LStmt id = Located (Stmt id) +type LStmt id = Located (StmtLR id id) +type LStmtLR idL idR = Located (StmtLR idL idR) + +type Stmt id = StmtLR id id -- The SyntaxExprs in here are used *only* for do-notation, which -- has rebindable syntax. Otherwise they are unused. -data Stmt id - = BindStmt (LPat id) - (LHsExpr id) - (SyntaxExpr id) -- The (>>=) operator - (SyntaxExpr id) -- The fail operator +data StmtLR idL idR + = BindStmt (LPat idL) + (LHsExpr idR) + (SyntaxExpr idR) -- The (>>=) operator + (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | ExprStmt (LHsExpr id) - (SyntaxExpr id) -- The (>>) operator + | ExprStmt (LHsExpr idR) + (SyntaxExpr idR) -- The (>>) operator PostTcType -- Element type of the RHS (used for arrows) - | LetStmt (HsLocalBinds id) + | LetStmt (HsLocalBindsLR idL idR) -- ParStmts only occur in a list comprehension - | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders - -- bound by the stmts and used subsequently + | ParStmt [([LStmt idL], [idR])] -- After renaming, the ids are the binders + -- bound by the stmts and used subsequently -- Recursive statement (see Note [RecStmt] below) - | RecStmt [LStmt id] + | RecStmt [LStmtLR idL idR] --- The next two fields are only valid after renaming - [id] -- The ids are a subset of the variables bound by the stmts + [idR] -- 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 + [idR] -- 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 @@ -699,7 +791,7 @@ data Stmt id -- 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, + (DictBinds idR) -- Method bindings of Ids bound by the RecStmt, -- and used afterwards \end{code} @@ -753,9 +845,10 @@ have the same Name. \begin{code} -instance OutputableBndr id => Outputable (Stmt id) where +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt +pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc 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 @@ -763,8 +856,8 @@ pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr 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 = ptext SLIT("do") <+> (vcat (map ppr stmts) $$ ppr body) -pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> (vcat (map ppr stmts) $$ ppr body) +pprDo DoExpr stmts body = ptext SLIT("do") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) +pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body]) pprDo ListComp stmts body = pprComp brackets stmts body pprDo PArrComp stmts body = pprComp pa_brackets stmts body pprDo other stmts body = panic "pprDo" -- PatGuard, ParStmtCxt @@ -791,7 +884,7 @@ 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 +pprSplice (HsSplice n e) = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] @@ -856,7 +949,7 @@ pp_dotdot = ptext SLIT(" .. ") \begin{code} data HsMatchContext id -- Context of a Match - = FunRhs id -- Function binding for f + = FunRhs id Bool -- Function binding for f; True <=> written infix | CaseAlt -- Guard on a case alternative | LambdaExpr -- Pattern of a lambda | ProcExpr -- Pattern of a proc @@ -881,11 +974,16 @@ data HsStmtContext id isDoExpr :: HsStmtContext id -> Bool isDoExpr DoExpr = True isDoExpr (MDoExpr _) = True -isDoExpr other = False +isDoExpr _ = False + +isListCompExpr :: HsStmtContext id -> Bool +isListCompExpr ListComp = True +isListCompExpr PArrComp = True +isListCompExpr _ = False \end{code} \begin{code} -matchSeparator (FunRhs _) = ptext SLIT("=") +matchSeparator (FunRhs {}) = ptext SLIT("=") matchSeparator CaseAlt = ptext SLIT("->") matchSeparator LambdaExpr = ptext SLIT("->") matchSeparator ProcExpr = ptext SLIT("->") @@ -895,7 +993,7 @@ matchSeparator RecUpd = panic "unused" \end{code} \begin{code} -pprMatchContext (FunRhs fun) = ptext SLIT("the definition of") <+> quotes (ppr fun) +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") @@ -926,7 +1024,7 @@ pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext -} -- Used to generate the string for a *runtime* error message -matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) +matchContextErrString (FunRhs fun _) = "function " ++ showSDoc (ppr fun) matchContextErrString CaseAlt = "case" matchContextErrString PatBindRhs = "pattern binding" matchContextErrString RecUpd = "record update"