[project @ 2003-07-29 10:15:31 by simonpj]
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsExpr.lhs
index 838fbe0..cf6b424 100644 (file)
@@ -9,7 +9,7 @@ module HsExpr where
 #include "HsVersions.h"
 
 -- friends:
-import HsDecls         ( HsDecl )
+import HsDecls         ( HsGroup )
 import HsBinds         ( HsBinds(..), nullBinds )
 import HsPat           ( Pat )
 import HsLit           ( HsLit, HsOverLit )
@@ -22,6 +22,7 @@ import PprType                ( pprParendType )
 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, Fixity(..) )
@@ -55,7 +56,7 @@ data HsExpr id
 
   | OpApp      (HsExpr id)     -- left operand
                (HsExpr id)     -- operator
-               Fixity                          -- Renamer adds fixity; bottom until then
+               Fixity          -- Renamer adds fixity; bottom until then
                (HsExpr id)     -- right operand
 
   -- We preserve prefix negation and parenthesis for the precedence parser.
@@ -83,17 +84,12 @@ data HsExpr id
   | HsLet      (HsBinds id)    -- let(rec)
                (HsExpr  id)
 
-  | HsWith     (HsExpr id)     -- implicit parameter binding
-               [(IPName id, HsExpr id)]
-               Bool            -- True <=> this was a 'with' binding
-                               --  (tmp, until 'with' is removed)
-
-  | HsDo       HsDoContext
-               [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
+  | 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
@@ -160,17 +156,54 @@ data HsExpr id
 
   | 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)
+  | 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 )           -- $z  or $(f 4)
+  | 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}
 
 
@@ -210,6 +243,22 @@ 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, <expression>)]
+--     where <expression> is the evidence for the method
+\end{code}
 
 A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
 @ClassDictLam dictvars methods expr@ is, therefore:
@@ -233,12 +282,11 @@ 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
-    (ppr_expr fun) <+> (sep (map ppr_expr args))
+    (ppr_expr fun) <+> (sep (map pprParendExpr args))
   where
     collect_args (HsApp fun arg) args = collect_args fun (arg:args)
     collect_args fun            args = (fun, args)
@@ -252,15 +300,10 @@ ppr_expr (OpApp e1 op fixity e2)
     pp_e2 = pprParendExpr e2
 
     pp_prefixly
-      = hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
+      = hang (ppr_expr 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
 
@@ -302,16 +345,12 @@ ppr_expr (HsIf e1 e2 e3 _)
 -- special case: let ... in let ...
 ppr_expr (HsLet binds expr@(HsLet _ _))
   = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
-        pprExpr expr]
+        ppr_expr expr]
 
 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 is_with)
-  = sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds),
-        hang (ptext SLIT("in"))  2 (ppr expr)]
-
 ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
 
 ppr_expr (ExplicitList _ exprs)
@@ -388,9 +427,39 @@ ppr_expr (DictApp expr 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 (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 [ppr_expr arrow, ptext SLIT("-<"), ppr_expr arg]
+ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False _)
+  = hsep [ppr_expr arg, ptext SLIT(">-"), ppr_expr arrow]
+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True _)
+  = hsep [ppr_expr arrow, ptext SLIT("-<<"), ppr_expr arg]
+ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False _)
+  = hsep [ppr_expr arg, ptext SLIT(">>-"), ppr_expr 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("(|") <> ppr_expr op)
+        4 (sep (map pprCmdArg args) <> ptext SLIT("|)"))
+
+pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
+pprCmdArg (HsCmdTop cmd@(HsArrForm _ Nothing [] _) _ _ _) = ppr_expr cmd
+pprCmdArg (HsCmdTop cmd _ _ _) = parens (ppr_expr 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
 --
@@ -404,20 +473,89 @@ pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc
 
 pprParendExpr expr
   = let
-       pp_as_was = pprExpr expr
+       pp_as_was = ppr_expr 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
+      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
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\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
 
-      HsVar _              -> pp_as_was
-      HsIPVar _                    -> pp_as_was
-      ExplicitList _ _      -> pp_as_was
-      ExplicitPArr _ _      -> pp_as_was
-      ExplicitTuple _ _            -> pp_as_was
-      HsPar _              -> pp_as_was
+  | HsArrForm ...              -- as above
 
-      _                            -> parens pp_as_was
+  | 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}
 
 %************************************************************************
@@ -441,12 +579,6 @@ pp_rbinds thing rbinds
     pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e]
 \end{code}
 
-\begin{code}
-pp_ipbinds :: OutputableBndr id => [(IPName id, HsExpr id)] -> SDoc
-pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs))
-                where
-                  pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> ppr_expr rhs
-\end{code}
 
 
 %************************************************************************
@@ -494,6 +626,11 @@ mkSimpleMatch pats rhs rhs_ty locn
 
 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
@@ -529,7 +666,9 @@ pprMatch ctxt (Match pats maybe_ty 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
+
     ppr_maybe_ty = case maybe_ty of
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
@@ -572,9 +711,27 @@ data Stmt 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]]                             -- List comp only: parallel set of quals
-  | ParStmtOut [([id], [Stmt id])]                     -- 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
@@ -624,17 +781,16 @@ consLetStmt binds      stmts = LetStmt binds : stmts
 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 :: OutputableBndr id => HsDoContext -> [Stmt id] -> SDoc
+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
 
@@ -656,7 +812,7 @@ pprComp brack stmts = brack $
 \begin{code}
 data HsBracket id = ExpBr (HsExpr id)
                  | PatBr (Pat id)
-                 | DecBr [HsDecl id]
+                 | DecBr (HsGroup id)
                  | TypBr (HsType id)
 
 instance OutputableBndr id => Outputable (HsBracket id) where
@@ -665,12 +821,28 @@ instance OutputableBndr id => Outputable (HsBracket id) where
 
 pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
 pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBr d) = thBrackets (char 'd') (vcat (map ppr d))
+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}
 
 %************************************************************************
@@ -710,53 +882,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 
-                | PArrComp     -- parallel array comprehension
+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 _)   = ptext SLIT("=")
 matchSeparator CaseAlt      = ptext SLIT("->") 
 matchSeparator LambdaExpr   = ptext SLIT("->") 
+matchSeparator ProcExpr     = ptext SLIT("->") 
 matchSeparator PatBindRhs   = ptext SLIT("=") 
-matchSeparator (DoCtxt _)   = ptext SLIT("<-")  
-matchSeparator RecUpd       = panic "When is this used?"
+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 (DoCtxt PArrComp) = 
-  ptext SLIT("In an 'array 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 (DoCtxt PArrComp) = "array 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}