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 a2b703f..6969de2 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -9,22 +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 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 Outputable      
+import ForeignCall     ( Safety )
 import PprType         ( pprParendType )
 import Type            ( Type )
 import PprType         ( pprParendType )
 import Type            ( Type )
-import Var             ( TyVar )
+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      ( Boxity, tupleParens )
+import BasicTypes      ( IPName, Boxity, tupleParens, Fixity(..) )
 import SrcLoc          ( SrcLoc )
 import SrcLoc          ( SrcLoc )
+import Outputable      
+import FastString
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -34,15 +38,15 @@ import SrcLoc               ( SrcLoc )
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-data HsExpr id pat
+data HsExpr id
   = HsVar      id              -- variable
   = HsVar      id              -- variable
-  | HsIPVar    id              -- implicit parameter
+  | HsIPVar    (IPName id)     -- implicit parameter
   | HsOverLit  HsOverLit       -- Overloaded literals; eliminated by type checker
   | HsLit      HsLit           -- Simple (non-overloaded) literals
 
   | 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.
@@ -50,58 +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
+  | 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
-               [(id, HsExpr id pat)]
+  | HsLet      (HsBinds id)    -- let(rec)
+               (HsExpr  id)
 
 
-  | HsDo       HsMatchContext
-               [Stmt id pat]   -- "do":one or more stmts
-               SrcLoc
-
-  | HsDoOut    HsMatchContext
-               [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
                SrcLoc
 
   | ExplicitList               -- syntactic list
-               [HsExpr id pat]
-  | ExplicitListOut            -- TRANSLATION
-               Type    -- Gives type of components of list
-               [HsExpr id pat]
+               PostTcType      -- Gives type of components of list
+               [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
@@ -110,50 +110,103 @@ 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                   -- Type of *result* record (may differ from
-                                               -- type of input record)
-                [id]                   -- Dicts needed for construction
-                (HsRecordBinds id pat)
+                                       --      type of input record)
+                (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.
                                -- arguments to pass.
-               Bool            -- True <=> might cause Haskell
+               Safety          -- True <=> might cause Haskell
                                -- garbage-collection (must generate
                                -- more paranoid code)
                Bool            -- True <=> it's really a "casm"
                                -- NOTE: this CCall is the *boxed*
                                -- version; the desugarer will convert
                                -- it into the unboxed "ccall#".
                                -- garbage-collection (must generate
                                -- more paranoid code)
                Bool            -- True <=> it's really a "casm"
                                -- NOTE: this CCall is the *boxed*
                                -- version; the desugarer will convert
                                -- it into the unboxed "ccall#".
-               Type    -- The result type; will be *bottom*
+               PostTcType      -- The result type; will be *bottom*
                                -- until the typechecker gets ahold of it
 
                                -- 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.
 
@@ -161,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}
@@ -173,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
@@ -199,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 (HsIPVar v)     = {- char '?' <> -} 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 (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 
-ppr_expr (HsLam match)
-  = hsep [char '\\', nest 2 (pprMatch (True,empty) 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
@@ -242,13 +303,9 @@ 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
 
 ppr_expr (HsPar e) = parens (ppr_expr e)
 
 
 ppr_expr (HsPar e) = parens (ppr_expr e)
 
@@ -277,7 +334,7 @@ ppr_expr (SectionR op expr)
 
 ppr_expr (HsCase expr matches _)
   = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
 
 ppr_expr (HsCase expr matches _)
   = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
-           nest 2 (pprMatches (True, empty) matches) ]
+           nest 2 (pprMatches CaseAlt matches) ]
 
 ppr_expr (HsIf e1 e2 e3 _)
   = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
 
 ppr_expr (HsIf e1 e2 e3 _)
   = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
@@ -294,17 +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"), ppr binds]
+ppr_expr (HsDo 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 (HsDoOut 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 (ExplicitListOut ty exprs)
+ppr_expr (ExplicitList _ exprs)
   = brackets (fsep (punctuate comma (map ppr_expr 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)))
 
@@ -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
@@ -381,8 +481,8 @@ pprParendExpr expr
 
       HsVar _              -> pp_as_was
       HsIPVar _                    -> pp_as_was
 
       HsVar _              -> pp_as_was
       HsIPVar _                    -> pp_as_was
-      ExplicitList _       -> pp_as_was
-      ExplicitListOut _ _   -> 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
 
@@ -391,25 +491,90 @@ 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}
 
 
@@ -435,34 +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
-       [id]                    -- Tyvars wrt which this match is universally quantified
-                               -- empty after typechecking
-       [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
-         (Maybe Type)          -- Just rhs_ty after type checking
-
-data GRHS id pat
-  = GRHS  [Stmt id pat]                -- The RHS is the final ExprStmt
-                               -- I considered using a RetunStmt, but
-                               -- it printed 'wrong' in error messages 
+data GRHSs id  
+  = GRHSs [GRHS id]            -- Guarded RHSs
+         (HsBinds id)          -- The where clause
+         PostTcType            -- Type of RHS (after type checking)
+
+data GRHS id
+  = GRHS  [Stmt id]            -- The RHS is the final ResultStmt
          SrcLoc
 
          SrcLoc
 
-mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat
-mkSimpleMatch pats rhs maybe_rhs_ty locn
-  = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty)
+mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id
+mkSimpleMatch pats rhs rhs_ty locn
+  = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
+
+unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id]
+unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
 
 
-unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
-unguardedRHS rhs loc = [GRHS [ExprStmt 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
@@ -470,54 +636,62 @@ 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 _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
+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}
 \end{code}
 
 We know the list must have at least one @Match@ in it.
 
 \begin{code}
-pprMatches :: (Outputable id, Outputable pat)
-          => (Bool, SDoc) -> [Match id pat] -> SDoc
-pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
+pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc
+pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)
 
 
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc
+pprFunBind fun matches = pprMatches (FunRhs fun) matches
 
 
-pprMatch :: (Outputable id, Outputable pat)
-          => (Bool, SDoc) -> Match id pat -> SDoc
-pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
-  = maybe_name <+> sep [sep (map ppr pats), 
-                       ppr_maybe_ty,
-                       nest 2 (pprGRHSs is_case grhss)]
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprPatBind :: (OutputableBndr id)
+          => Pat id -> GRHSs id -> SDoc
+pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
+
+
+pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
+pprMatch ctxt (Match pats maybe_ty grhss)
+  = pp_name ctxt <+> sep [sep (map ppr pats), 
+                    ppr_maybe_ty,
+                    nest 2 (pprGRHSs ctxt grhss)]
   where
   where
-    maybe_name | is_case   = empty
-              | otherwise = name
+    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
 
 
     ppr_maybe_ty = case maybe_ty of
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
 
 
-pprGRHSs :: (Outputable id, Outputable pat)
-        => Bool -> GRHSs id pat -> SDoc
-pprGRHSs is_case (GRHSs grhss binds maybe_ty)
-  = vcat (map (pprGRHS is_case) grhss)
+pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
+pprGRHSs ctxt (GRHSs grhss binds ty)
+  = vcat (map (pprGRHS ctxt) grhss)
     $$
     (if nullBinds binds then empty
      else text "where" $$ nest 4 (pprDeeper (ppr binds)))
 
 
     $$
     (if nullBinds binds then empty
      else text "where" $$ nest 4 (pprDeeper (ppr binds)))
 
 
-pprGRHS :: (Outputable id, Outputable pat)
-       => Bool -> GRHS id pat -> SDoc
+pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
 
 
-pprGRHS is_case (GRHS [ExprStmt expr _] locn)
- =  text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
+pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
+ =  pp_rhs ctxt expr
 
 
-pprGRHS is_case (GRHS guarded locn)
- = sep [char '|' <+> interpp'SP guards,
-       text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
-   ]
+pprGRHS ctxt (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
  where
  where
-    ExprStmt expr _ = last guarded     -- Last stmt should be a ExprStmt for guards
-    guards         = init guarded
+    ResultStmt expr _ = last guarded   -- Last stmt should be a ResultStmt for guards
+    guards           = init guarded
+
+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
 \end{code}
 
 
 \end{code}
 
 
@@ -529,79 +703,144 @@ pprGRHS is_case (GRHS guarded locn)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-data Stmt id pat
-  = BindStmt   pat (HsExpr id pat) SrcLoc
-  | LetStmt    (HsBinds id pat)
-  | ExprStmt   (HsExpr id pat) SrcLoc  -- See notes that follow
-  | ParStmt    [[Stmt id pat]]         -- List comp only: parallel set of quals
-  | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming
+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
+
+       -- 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}
 
 \end{code}
 
-ExprStmts are a bit tricky, because what 
-they mean depends on the context.  Consider 
-               ExprStmt E
-in the following contexts:
+ExprStmts and ResultStmts are a bit tricky, because what they mean
+depends on the context.  Consider the following contexts:
 
        A do expression of type (m res_ty)
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
        A do expression of type (m res_ty)
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-       * Non-last stmt in list:   do { ....; E; ... }
+       * ExprStmt E any_ty:   do { ....; E; ... }
                E :: m any_ty
          Translation: E >> ...
        
                E :: m any_ty
          Translation: E >> ...
        
-       * Last stmt in list:   do { ....; E }
+       * ResultStmt E:   do { ....; E }
                E :: m res_ty
          Translation: E
        
        A list comprehensions of type [elt_ty]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                E :: m res_ty
          Translation: E
        
        A list comprehensions of type [elt_ty]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-       * Non-last stmt in list:   [ .. | ..., E, ... ]
+       * ExprStmt E Bool:   [ .. | .... E ]
+                       [ .. | ..., E, ... ]
+                       [ .. | .... | ..., E | ... ]
                E :: Bool
          Translation: if E then fail else ...
                E :: Bool
          Translation: if E then fail else ...
-       
-       * Last stmt in list:   [ E | ... ]
+
+       * ResultStmt E:   [ E | ... ]
                E :: elt_ty
          Translation: return E
        
        A guard list, guarding a RHS of type rhs_ty
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                E :: elt_ty
          Translation: return E
        
        A guard list, guarding a RHS of type rhs_ty
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-       * Non-last stmt in list:   f x | ..., E, ... = ...rhs...
+       * ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
                E :: Bool
          Translation: if E then fail else ...
        
                E :: Bool
          Translation: if E then fail else ...
        
-       * Last stmt in list:   f x | ...guards... = E
+       * ResultStmt E:   f x | ...guards... = E
                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 (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
-
-pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> 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
+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 => 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
-                      ExprStmt expr _ = last stmts     -- Last stmt should
-                      quals           = init stmts     -- be an ExprStmt
+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}
 
 %************************************************************************
@@ -611,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]
@@ -642,48 +880,84 @@ pp_dotdot = ptext SLIT(" .. ")
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-data HsMatchContext    -- Context of a Match or Stmt
-  = ListComp           -- List comprehension
-  | DoExpr             -- Do Statment
-
-  | FunRhs Name                -- 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 ()
 
--- It's convenient to have FunRhs as a Name
--- throughout so that HsMatchContext doesn't
--- need to be parameterised.
--- In the RdrName world we never use the FunRhs variant.
+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 DoExpr = True
-isDoExpr other  = False
-
-isDoOrListComp ListComp = True
-isDoOrListComp DoExpr   = True
-isDoOrListComp 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 DoExpr       = SLIT("<-")  
-matchSeparator ListComp     = 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 function") <+> quotes (ppr fun)
-pprMatchContext CaseAlt             = ptext SLIT("in a group of case alternatives beginning")
-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 DoExpr       = ptext SLIT("in a `do' expression pattern binding")
-pprMatchContext ListComp     = ptext SLIT("in a `list comprension' 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 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)