projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2003-07-24 14:41:48 by simonpj]
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsExpr.lhs
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index ba980ee..5eff473 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -9,21 +9,26 @@ module HsExpr where
 #include "HsVersions.h"
 
 -- friends:
 #include "HsVersions.h"
 
 -- friends:
-import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match )
-
-import HsBinds         ( HsBinds(..) )
-import HsBasic         ( HsLit )
-import BasicTypes      ( Fixity(..), FixityDirection(..) )
-import HsTypes         ( HsType )
+import HsDecls         ( HsGroup )
+import HsBinds         ( HsBinds(..), nullBinds )
+import HsPat           ( Pat )
+import HsLit           ( HsLit, HsOverLit )
+import HsTypes         ( HsType, PostTcType, SyntaxName )
+import HsImpExp                ( isOperator, pprHsVar )
 
 -- others:
 
 -- others:
-import Name            ( Name, isLexId ) 
-import Outputable      
-import PprType         ( pprType, pprParendType )
+import ForeignCall     ( Safety )
+import PprType         ( pprParendType )
 import Type            ( Type )
 import Var             ( TyVar, Id )
 import Type            ( Type )
 import Var             ( TyVar, Id )
+import Name            ( Name )
+import NameSet         ( FreeVars )
 import DataCon         ( DataCon )
 import DataCon         ( DataCon )
+import CStrings                ( CLabelString, pprCLabelString )
+import BasicTypes      ( IPName, Boxity, tupleParens, Fixity(..) )
 import SrcLoc          ( SrcLoc )
 import SrcLoc          ( SrcLoc )
+import Outputable      
+import FastString
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -33,16 +38,15 @@ import SrcLoc               ( SrcLoc )
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-data HsExpr id pat
-  = HsVar      id                              -- variable
-  | HsIPVar    id                              -- implicit parameter
-  | HsLit      HsLit                           -- literal
-  | HsLitOut   HsLit                           -- TRANSLATION
-               Type            -- (with its type)
+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
 
 
-  | 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,113 +54,159 @@ 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
-               (HsExpr id pat) -- the negate id (in a HsVar)
+  | 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)
+  | HsLet      (HsBinds id)    -- let(rec)
+               (HsExpr  id)
 
 
-  | HsWith     (HsExpr id pat) -- implicit parameter binding
-               [(id, HsExpr id pat)]
-
-  | HsDo       StmtCtxt
-               [Stmt id pat]   -- "do":one or more stmts
-               SrcLoc
-
-  | HsDoOut    StmtCtxt
-               [Stmt id pat]   -- "do":one or more stmts
-               id              -- id for return
-               id              -- id for >>=
-               id                              -- id for zero
-               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
-               Bool            -- boxed?
+               Boxity
 
 
-  | HsCon DataCon              -- TRANSLATION; a saturated constructor application
-         [Type]
-         [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
-                Type           -- Type of *result* record (may differ from
-                                               -- type of input record)
-                [id]                           -- Dicts needed for construction
-                (HsRecordBinds id pat)
+  | RecordUpdOut (HsExpr id)   -- TRANSLATION
+                Type                   -- Type of *input* record
+                Type                   -- Type of *result* record (may differ from
+                                       --      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)
-
-  | CCall      FAST_STRING     -- call into the C world; string is
-               [HsExpr id pat] -- the C function; exprs are the
+               (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
+               [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.
 
@@ -164,9 +214,11 @@ 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) -- ~ pattern
 
 
-  | ELazyPat   (HsExpr id pat) -- ~ pattern
+  | HsType      (HsType id)     -- Explicit type argument; e.g  f {| Int |} x y
 \end{code}
 
 Everything from here on appears only in typechecker output.
 \end{code}
 
 Everything from here on appears only in typechecker output.
@@ -174,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
@@ -200,30 +267,26 @@ 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) = 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 (HsLitOut 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
-    (ppr_expr fun) <+> (sep (map ppr_expr args))
+    (ppr_expr fun) <+> (sep (map pprParendExpr args))
   where
     collect_args (HsApp fun arg) args = collect_args fun (arg:args)
     collect_args fun            args = (fun, args)
   where
     collect_args (HsApp fun arg) args = collect_args fun (arg:args)
     collect_args fun            args = (fun, args)
@@ -240,18 +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 = ppr v
-        pp_v_op | isLexId (_PK_ (showSDoc pp_v)) = char '`' <> pp_v <> char '`'
-               | otherwise                      = pp_v 
-       -- Put it in backquotes if it's not an operator already
-       -- We use (showSDoc pp_v), rather than isSymOcc (getOccName v) simply so
-       -- that we don't need NamedThing in the context of all these funcions.
-       -- Gruesome, but simple.
-
-ppr_expr (NegApp e _)
-  = char '-' <+> pprParendExpr e
+      = sep [pp_e1, hsep [pprInfix v, pp_e2]]
+
+ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
 
 ppr_expr (HsPar e) = parens (ppr_expr e)
 
 
 ppr_expr (HsPar e) = parens (ppr_expr e)
 
@@ -280,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")],
@@ -297,27 +351,16 @@ 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)
+ppr_expr (ExplicitList _ exprs)
   = brackets (fsep (punctuate comma (map ppr_expr exprs)))
   = brackets (fsep (punctuate comma (map ppr_expr exprs)))
-ppr_expr (ExplicitListOut ty exprs)
-  = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
-          ifNotPprForUser ((<>) space (parens (pprType ty))) ]
-
-ppr_expr (ExplicitTuple exprs True)
-  = parens (sep (punctuate comma (map ppr_expr exprs)))
 
 
-ppr_expr (ExplicitTuple exprs False)
-  = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)")
+ppr_expr (ExplicitPArr _ exprs)
+  = pa_brackets (fsep (punctuate comma (map ppr_expr exprs)))
 
 
-ppr_expr (HsCon con_id tys args)
-  = ppr con_id <+> sep (map pprParendType tys ++
-                       map pprParendExpr args)
+ppr_expr (ExplicitTuple exprs boxity)
+  = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs)))
 
 ppr_expr (RecordCon con_id rbinds)
   = pp_rbinds (ppr con_id) rbinds
 
 ppr_expr (RecordCon con_id rbinds)
   = pp_rbinds (ppr con_id) rbinds
@@ -338,21 +381,28 @@ 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
 
-ppr_expr (CCall fun args _ is_asm result_ty)
+ppr_expr (HsCCall fun args _ is_asm result_ty)
   = hang (if is_asm
   = hang (if is_asm
-         then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
-         else ptext SLIT("_ccall_") <+> ptext fun)
+         then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
+         else ptext SLIT("_ccall_") <+> pprCLabelString fun)
        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])
@@ -363,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])
@@ -373,12 +425,51 @@ ppr_expr (DictApp expr dnames)
   = hang (ppr_expr expr)
         4 (brackets (interpp'SP dnames))
 
   = hang (ppr_expr expr)
         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
@@ -386,12 +477,12 @@ pprParendExpr expr
     in
     case expr of
       HsLit l              -> ppr l
     in
     case expr of
       HsLit l              -> ppr l
-      HsLitOut l _         -> ppr l
+      HsOverLit l          -> ppr l
 
       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
 
@@ -400,89 +491,356 @@ 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 
 
 pp_rbinds thing rbinds
   = hang thing 
-        4 (braces (hsep (punctuate comma (map (pp_rbind) rbinds))))
+        4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
   where
   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}
 
+
+
 %************************************************************************
 %*                                                                     *
 %************************************************************************
 %*                                                                     *
-\subsection{Do stmts and list comprehensions}
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
+@Match@es are sets of pattern bindings and right hand sides for
+functions, patterns or case branches. For example, if a function @g@
+is defined as:
+\begin{verbatim}
+g (x,y) = y
+g ((x:ys),y) = y+1,
+\end{verbatim}
+then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
+
+It is always the case that each element of an @[Match]@ list has the
+same number of @pats@s inside it.  This corresponds to saying that
+a function defined by pattern matching must have the same number of
+patterns in each equation.
+
 \begin{code}
 \begin{code}
-data StmtCtxt  -- Context of a Stmt
-  = DoStmt             -- Do Statment
-  | ListComp           -- List comprehension
-  | CaseAlt            -- Guard on a case alternative
-  | PatBindRhs         -- Guard on a pattern binding
-  | FunRhs Name                -- Guard on a function defn for f
-  | LambdaBody         -- Body of a lambda abstraction
-               
-pprDo DoStmt stmts
-  = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
-pprDo ListComp stmts
-  = brackets $
-    hang (pprExpr expr <+> char '|')
-       4 (interpp'SP quals)
-  where
-    ReturnStmt expr = last stmts       -- Last stmt should be a ReturnStmt for list comps
-    quals          = init stmts
+data Match id
+  = Match
+       [Pat id]                -- The patterns
+       (Maybe (HsType id))     -- A type signature for the result of the match
+                               --      Nothing after typechecking
+
+       (GRHSs id)
+
+-- GRHSs are used both for pattern bindings and for Matches
+data GRHSs id  
+  = GRHSs [GRHS id]            -- Guarded RHSs
+         (HsBinds id)          -- The where clause
+         PostTcType            -- Type of RHS (after type checking)
+
+data GRHS id
+  = GRHS  [Stmt id]            -- The RHS is the final ResultStmt
+         SrcLoc
+
+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]
+
+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}
 
 \end{code}
 
+@getMatchLoc@ takes a @Match@ and returns the
+source-location gotten from the GRHS inside.
+THis is something of a nuisance, but no more.
+
 \begin{code}
 \begin{code}
-data Stmt id pat
-  = BindStmt   pat
-               (HsExpr id pat)
-               SrcLoc
+getMatchLoc :: Match id -> SrcLoc
+getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
+\end{code}
 
 
-  | LetStmt    (HsBinds id pat)
+We know the list must have at least one @Match@ in it.
 
 
-  | GuardStmt  (HsExpr id pat)         -- List comps only
-               SrcLoc
+\begin{code}
+pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc
+pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)
 
 
-  | ExprStmt   (HsExpr id pat)         -- Do stmts; and guarded things at the end
-               SrcLoc
+-- 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
+
+-- 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
+    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
+
+
+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)))
+
+
+pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
+
+pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
+ =  pp_rhs ctxt expr
 
 
-  | ReturnStmt (HsExpr id pat)         -- List comps only, at the end
+pprGRHS ctxt (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
+ where
+    ResultStmt expr _ = last guarded   -- Last stmt should be a ResultStmt for guards
+    guards           = init guarded
 
 
-consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat]
+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
+\end{code}
+
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Do stmts and list comprehensions}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+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}
+
+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)
+       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       * ExprStmt E any_ty:   do { ....; E; ... }
+               E :: m any_ty
+         Translation: E >> ...
+       
+       * ResultStmt E:   do { ....; E }
+               E :: m res_ty
+         Translation: E
+       
+       A list comprehensions of type [elt_ty]
+       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       * ExprStmt E Bool:   [ .. | .... E ]
+                       [ .. | ..., E, ... ]
+                       [ .. | .... | ..., E | ... ]
+               E :: Bool
+         Translation: if E then fail else ...
+
+       * ResultStmt E:   [ E | ... ]
+               E :: elt_ty
+         Translation: return E
+       
+       A guard list, guarding a RHS of type rhs_ty
+       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+       * ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
+               E :: Bool
+         Translation: if E then fail else ...
+       
+       * ResultStmt E:   f x | ...guards... = E
+               E :: rhs_ty
+         Translation: E
+
+Array comprehensions are handled like list comprehensions -=chak
+
+\begin{code}
+consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id]
 consLetStmt EmptyBinds stmts = stmts
 consLetStmt binds      stmts = LetStmt binds : stmts
 \end{code}
 
 \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 (GuardStmt expr _)
- = ppr expr
-pprStmt (ReturnStmt expr)
- = hsep [ptext SLIT("return"), ppr expr]    
+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 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}
 
 %************************************************************************
@@ -492,20 +850,19 @@ pprStmt (ReturnStmt expr)
 %************************************************************************
 
 \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]
@@ -514,3 +871,93 @@ instance (Outputable id, Outputable pat) =>
 
 pp_dotdot = ptext SLIT(" .. ")
 \end{code}
 
 pp_dotdot = ptext SLIT(" .. ")
 \end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{HsMatchCtxt}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+data HsMatchContext id -- Context of a Match
+  = FunRhs id                  -- Function binding for f
+  | CaseAlt                    -- Guard on a case alternative
+  | LambdaExpr                 -- Pattern of a lambda
+  | ProcExpr                   -- Pattern of a proc
+  | PatBindRhs                 -- Pattern binding
+  | RecUpd                     -- Record update [used only in DsExpr to tell matchWrapper
+                               --      what sort of runtime error message to generate]
+  | StmtCtxt (HsStmtContext id)        -- Pattern of a do-stmt or list comprehension
+  deriving ()
+
+data HsStmtContext id
+  = ListComp 
+  | DoExpr 
+  | MDoExpr                            -- Recursive do-expression
+  | PArrComp                           -- Parallel array comprehension
+  | PatGuard (HsMatchContext id)       -- Pattern guard for specified thing
+  | ParStmtCtxt (HsStmtContext id)     -- A branch of a parallel stmt 
+\end{code}
+
+\begin{code}
+isDoExpr :: HsStmtContext id -> Bool
+isDoExpr DoExpr  = True
+isDoExpr MDoExpr = True
+isDoExpr other   = False
+\end{code}
+
+\begin{code}
+matchSeparator (FunRhs _)   = ptext SLIT("=")
+matchSeparator CaseAlt      = ptext SLIT("->") 
+matchSeparator LambdaExpr   = ptext SLIT("->") 
+matchSeparator ProcExpr     = ptext SLIT("->") 
+matchSeparator PatBindRhs   = ptext SLIT("=") 
+matchSeparator (StmtCtxt _) = ptext SLIT("<-")  
+matchSeparator RecUpd       = panic "unused"
+\end{code}
+
+\begin{code}
+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}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)