projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2003-07-16 08:49:01 by ross]
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsExpr.lhs
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 91ddad3..6969de2 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -9,24 +9,26 @@ module HsExpr where
 #include "HsVersions.h"
 
 -- friends:
 #include "HsVersions.h"
 
 -- friends:
+import HsDecls         ( HsGroup )
 import HsBinds         ( HsBinds(..), nullBinds )
 import HsBinds         ( HsBinds(..), nullBinds )
-import HsTypes         ( PostTcType )
+import HsPat           ( Pat )
 import HsLit           ( HsLit, HsOverLit )
 import HsLit           ( HsLit, HsOverLit )
-import BasicTypes      ( Fixity(..) )
-import HsTypes         ( HsType )
-import HsImpExp                ( isOperator )
+import HsTypes         ( HsType, PostTcType, SyntaxName )
+import HsImpExp                ( isOperator, pprHsVar )
 
 -- others:
 
 -- others:
-import Name            ( Name )
 import ForeignCall     ( Safety )
 import ForeignCall     ( Safety )
-import Outputable      
 import PprType         ( pprParendType )
 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 DataCon         ( DataCon )
 import CStrings                ( CLabelString, pprCLabelString )
-import BasicTypes      ( IPName, Boxity, tupleParens )
+import BasicTypes      ( IPName, Boxity, tupleParens, Fixity(..) )
 import SrcLoc          ( SrcLoc )
 import SrcLoc          ( SrcLoc )
+import Outputable      
+import FastString
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -36,15 +38,15 @@ import SrcLoc               ( SrcLoc )
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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
 
   = 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.
 
   -- 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.
 
   -- 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.
 
 
   -- 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
 
                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
 
                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
                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
 
   | ExplicitTuple              -- tuple
-               [HsExpr id pat]
+               [HsExpr id]
                                -- NB: Unit is ExplicitTuple []
                                -- for tuples, we can get the types
                                -- direct from the components
                                -- 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
 
        -- Record construction
   | RecordCon  id                              -- The constructor
-               (HsRecordBinds id pat)
+               (HsRecordBinds id)
 
   | RecordConOut DataCon
 
   | 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
 
 
        -- 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)
                 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
 
   | ExprWithTySig                      -- signature binding
-               (HsExpr id pat)
+               (HsExpr id)
                (HsType id)
   | ArithSeqIn                         -- arithmetic sequence
                (HsType id)
   | ArithSeqIn                         -- arithmetic sequence
-               (ArithSeqInfo id pat)
+               (ArithSeqInfo id)
   | ArithSeqOut
   | 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
 
   | 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
                                -- 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
 
                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}
 
 
 \end{code}
 
+
 These constructors only appear temporarily in the parser.
 The renamer translates them into the Right Thing.
 
 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
   | 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}
 
   | 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]
 \begin{code}
   | TyLam                      -- TRANSLATION
                [TyVar]
-               (HsExpr id pat)
+               (HsExpr id)
   | TyApp                      -- TRANSLATION
   | TyApp                      -- TRANSLATION
-               (HsExpr id pat) -- generated by Spec
+               (HsExpr id) -- generated by Spec
                [Type]
 
   -- DictLam and DictApp are "inverses"
   |  DictLam
                [id]
                [Type]
 
   -- DictLam and DictApp are "inverses"
   |  DictLam
                [id]
-               (HsExpr id pat)
+               (HsExpr id)
   |  DictApp
   |  DictApp
-               (HsExpr id pat)
+               (HsExpr id)
                [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, <expression>)]
+--     where <expression> is the evidence for the method
 \end{code}
 
 A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
 \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}
 \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}
     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)
 
 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 (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 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
       = 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
 
 
 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)]
 
   = 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 (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)))
 
 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 (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)
   = 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 (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
 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)
        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)
 
 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])
         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)
         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])
         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
         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}
 \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
 
 pprParendExpr expr
   = let
@@ -382,6 +482,7 @@ pprParendExpr expr
       HsVar _              -> pp_as_was
       HsIPVar _                    -> pp_as_was
       ExplicitList _ _      -> 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
 
       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}
 \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_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}
 
 \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}
 patterns in each equation.
 
 \begin{code}
-data Match id pat
+data Match id
   = Match
   = Match
-       [pat]                   -- The patterns
+       [Pat id]                -- The patterns
        (Maybe (HsType id))     -- A type signature for the result of the match
                                --      Nothing after typechecking
 
        (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
 
 -- 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)
 
          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
 
          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)
 
 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]
 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
 \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}
 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}
 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
 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
 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)]
 
 
 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
 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
     pp_name other       = empty
+
     ppr_maybe_ty = case maybe_ty of
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> 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)
     $$
 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)))
 
 
      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
 
 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
 
     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}
 
 
 \end{code}
 
 
@@ -543,15 +703,33 @@ pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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
        -- 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
 \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
 
                E :: rhs_ty
          Translation: E
 
+Array comprehensions are handled like list comprehensions -=chak
 
 \begin{code}
 
 \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}
 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
 
     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 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}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -627,20 +850,19 @@ pprDo ListComp stmts = brackets $
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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}
 \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]
     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}
 %************************************************************************
 
 \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 ()
 
   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}
 \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}
 \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}
 \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
 
 -- 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}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)