projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Initial checkin of HetMet / -XModalTypes modifications
[ghc-hetmet.git] / compiler / hsSyn / HsExpr.lhs
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index a328cee..b7fe6fc 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -3,6 +3,7 @@
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \begin{code}
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \begin{code}
+{-# LANGUAGE DeriveDataTypeable #-}
 
 -- | Abstract Haskell syntax for expressions.
 module HsExpr where
 
 -- | Abstract Haskell syntax for expressions.
 module HsExpr where
@@ -24,6 +25,9 @@ import DataCon
 import SrcLoc
 import Outputable
 import FastString
 import SrcLoc
 import Outputable
 import FastString
+
+-- libraries:
+import Data.Data hiding (Fixity)
 \end{code}
 
 
 \end{code}
 
 
@@ -44,7 +48,7 @@ type LHsExpr id = Located (HsExpr id)
 type PostTcExpr  = HsExpr Id
 -- | We use a PostTcTable where there are a bunch of pieces of evidence, more
 -- than is convenient to keep individually.
 type PostTcExpr  = HsExpr Id
 -- | We use a PostTcTable where there are a bunch of pieces of evidence, more
 -- than is convenient to keep individually.
-type PostTcTable = [(Name, Id)]
+type PostTcTable = [(Name, PostTcExpr)]
 
 noPostTcExpr :: PostTcExpr
 noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
 
 noPostTcExpr :: PostTcExpr
 noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
@@ -58,7 +62,7 @@ noPostTcTable = []
 --
 -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
 --      @(>>=)@, and then instantiated by the type checker with its type args
 --
 -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
 --      @(>>=)@, and then instantiated by the type checker with its type args
---      tec
+--      etc
 
 type SyntaxExpr id = HsExpr id
 
 
 type SyntaxExpr id = HsExpr id
 
@@ -128,7 +132,10 @@ data HsExpr id
   | HsCase      (LHsExpr id)
                 (MatchGroup id)
 
   | HsCase      (LHsExpr id)
                 (MatchGroup id)
 
-  | HsIf        (LHsExpr id)    --  predicate
+  | HsIf        (Maybe (SyntaxExpr id)) -- cond function
+                                       -- Nothing => use the built-in 'if'
+                                       -- See Note [Rebindable if]
+                (LHsExpr id)    --  predicate
                 (LHsExpr id)    --  then part
                 (LHsExpr id)    --  else part
 
                 (LHsExpr id)    --  then part
                 (LHsExpr id)    --  else part
 
@@ -216,6 +223,13 @@ data HsExpr id
                 (LHsCmdTop id)          -- body of the abstraction
                                         -- always has an empty stack
 
                 (LHsCmdTop id)          -- body of the abstraction
                                         -- always has an empty stack
 
+  -----------------------------------------------------------
+  -- Heterogeneous Metaprogramming extension
+
+  | HsHetMetBrak  PostTcType            (LHsExpr id)            -- code type brackets
+  | HsHetMetEsc   PostTcType PostTcType (LHsExpr id)            -- code type escape
+  | HsHetMetCSP   PostTcType            (LHsExpr id)            -- code type cross-stage persistence
+
   ---------------------------------------
   -- The following are commands, not expressions proper
 
   ---------------------------------------
   -- The following are commands, not expressions proper
 
@@ -275,6 +289,7 @@ data HsExpr id
 
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
 
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
+  deriving (Data, Typeable)
 
 -- HsTupArg is used for tuple sections
 --  (,a,) is represented by  ExplicitTuple [Mising ty1, Present a, Missing ty3]
 
 -- HsTupArg is used for tuple sections
 --  (,a,) is represented by  ExplicitTuple [Mising ty1, Present a, Missing ty3]
@@ -282,6 +297,7 @@ data HsExpr id
 data HsTupArg id
   = Present (LHsExpr id)       -- The argument
   | Missing PostTcType         -- The argument is missing, but this is its type
 data HsTupArg id
   = Present (LHsExpr id)       -- The argument
   | Missing PostTcType         -- The argument is missing, but this is its type
+  deriving (Data, Typeable)
 
 tupArgPresent :: HsTupArg id -> Bool
 tupArgPresent (Present {}) = True
 
 tupArgPresent :: HsTupArg id -> Bool
 tupArgPresent (Present {}) = True
@@ -291,11 +307,18 @@ type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                         -- pasted back in by the desugarer
 \end{code}
 
                                         -- pasted back in by the desugarer
 \end{code}
 
-A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
-@ClassDictLam dictvars methods expr@ is, therefore:
-\begin{verbatim}
-\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
-\end{verbatim}
+Note [Rebindable if]
+~~~~~~~~~~~~~~~~~~~~
+The rebindable syntax for 'if' is a bit special, because when
+rebindable syntax is *off* we do not want to treat
+   (if c then t else e)
+as if it was an application (ifThenElse c t e).  Why not?
+Because we allow an 'if' to return *unboxed* results, thus 
+  if blah then 3# else 4#
+whereas that would not be possible using a all to a polymorphic function
+(because you can't call a polymorphic function at an unboxed type).
+
+So we use Nothing to mean "use the old built-in typing rule".
 
 \begin{code}
 instance OutputableBndr id => Outputable (HsExpr id) where
 
 \begin{code}
 instance OutputableBndr id => Outputable (HsExpr id) where
@@ -337,6 +360,9 @@ ppr_expr (HsIPVar v)     = ppr v
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 ppr_expr (HsPar e)       = parens (ppr_lexpr e)
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
 ppr_expr (HsPar e)       = parens (ppr_lexpr e)
+ppr_expr (HsHetMetBrak _   e) = ptext (sLit "<[") <> (ppr_lexpr e) <> ptext (sLit "]>")
+ppr_expr (HsHetMetEsc  _ _ e) = ptext (sLit "~~") <> (ppr_lexpr e)
+ppr_expr (HsHetMetCSP  _   e) = ptext (sLit "%%") <> (ppr_lexpr e)
 
 ppr_expr (HsCoreAnn s e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
 
 ppr_expr (HsCoreAnn s e)
   = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
@@ -408,7 +434,7 @@ ppr_expr exprType@(HsCase expr matches)
           nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
           nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
  where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
-ppr_expr (HsIf e1 e2 e3)
+ppr_expr (HsIf _ e1 e2 e3)
   = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
          nest 4 (ppr e2),
          ptext (sLit "else"),
   = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
          nest 4 (ppr e2),
          ptext (sLit "else"),
@@ -587,6 +613,7 @@ type HsCmd id = HsExpr id
 type LHsCmd id = LHsExpr id
 
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
 type LHsCmd id = LHsExpr id
 
 data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
+  deriving (Data, Typeable)
 \end{code}
 
 The legal constructors for commands are:
 \end{code}
 
 The legal constructors for commands are:
@@ -612,7 +639,8 @@ The legal constructors for commands are:
                 [Match id]      -- bodies are HsCmd's
                 SrcLoc
 
                 [Match id]      -- bodies are HsCmd's
                 SrcLoc
 
-  | HsIf        (HsExpr id)     --  predicate
+  | HsIf        (Maybe (SyntaxExpr id)) --  cond function
+                                        (HsExpr id)     --  predicate
                 (HsCmd id)      --  then part
                 (HsCmd id)      --  else part
                 SrcLoc
                 (HsCmd id)      --  then part
                 (HsCmd id)      --  else part
                 SrcLoc
@@ -640,6 +668,7 @@ data HsCmdTop id
              PostTcType       -- return type of the command
              (SyntaxTable id) -- after type checking:
                               -- names used in the command's desugaring
              PostTcType       -- return type of the command
              (SyntaxTable id) -- after type checking:
                               -- names used in the command's desugaring
+  deriving (Data, Typeable)
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -681,6 +710,7 @@ data MatchGroup id
         PostTcType      -- The type is the type of the entire group
                         --      t1 -> ... -> tn -> tr
                         -- where there are n patterns
         PostTcType      -- The type is the type of the entire group
                         --      t1 -> ... -> tn -> tr
                         -- where there are n patterns
+  deriving (Data, Typeable)
 
 type LMatch id = Located (Match id)
 
 
 type LMatch id = Located (Match id)
 
@@ -690,6 +720,7 @@ data Match id
         (Maybe (LHsType id))    -- A type signature for the result of the match
                                 -- Nothing after typechecking
         (GRHSs id)
         (Maybe (LHsType id))    -- A type signature for the result of the match
                                 -- Nothing after typechecking
         (GRHSs id)
+  deriving (Data, Typeable)
 
 isEmptyMatchGroup :: MatchGroup id -> Bool
 isEmptyMatchGroup (MatchGroup ms _) = null ms
 
 isEmptyMatchGroup :: MatchGroup id -> Bool
 isEmptyMatchGroup (MatchGroup ms _) = null ms
@@ -712,13 +743,14 @@ data GRHSs id
   = GRHSs {
       grhssGRHSs :: [LGRHS id],  -- ^ Guarded RHSs
       grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
   = GRHSs {
       grhssGRHSs :: [LGRHS id],  -- ^ Guarded RHSs
       grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
-    }
+    } deriving (Data, Typeable)
 
 type LGRHS id = Located (GRHS id)
 
 -- | Guarded Right Hand Side.
 data GRHS id = GRHS [LStmt id]   -- Guards
                     (LHsExpr id) -- Right hand side
 
 type LGRHS id = Located (GRHS id)
 
 -- | Guarded Right Hand Side.
 data GRHS id = GRHS [LStmt id]   -- Guards
                     (LHsExpr id) -- Right hand side
+  deriving (Data, Typeable)
 \end{code}
 
 We know the list must have at least one @Match@ in it.
 \end{code}
 
 We know the list must have at least one @Match@ in it.
@@ -737,16 +769,16 @@ pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
            => LPat bndr -> GRHSs id -> SDoc
 pprPatBind pat ty@(grhss)
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
            => LPat bndr -> GRHSs id -> SDoc
 pprPatBind pat ty@(grhss)
- = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
+ = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
 --avoid using PatternSignatures for stage1 code portability
  where idType :: GRHSs id -> HsMatchContext id; idType = undefined
 
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
 pprMatch ctxt (Match pats maybe_ty grhss)
 --avoid using PatternSignatures for stage1 code portability
  where idType :: GRHSs id -> HsMatchContext id; idType = undefined
 
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
 pprMatch ctxt (Match pats maybe_ty grhss)
-  = herald <+> sep [sep (map pprParendLPat other_pats),
-                    ppr_maybe_ty,
-                    nest 2 (pprGRHSs ctxt grhss)]
+  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
+        , nest 2 ppr_maybe_ty
+        , nest 2 (pprGRHSs ctxt grhss) ]
   where
     (herald, other_pats)
         = case ctxt of
   where
     (herald, other_pats)
         = case ctxt of
@@ -818,7 +850,7 @@ data StmtLR idL idR
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
 
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
 
-  | ExprStmt (LHsExpr idR)
+  | ExprStmt (LHsExpr idR)     -- See Note [ExprStmt]
              (SyntaxExpr idR) -- The (>>) operator
              PostTcType       -- Element type of the RHS (used for arrows)
 
              (SyntaxExpr idR) -- The (>>) operator
              PostTcType       -- Element type of the RHS (used for arrows)
 
@@ -845,10 +877,7 @@ data StmtLR idL idR
          [LStmt idL]      -- Stmts to the *left* of the 'group'
                          -- which generates the tuples to be grouped
 
          [LStmt idL]      -- Stmts to the *left* of the 'group'
                          -- which generates the tuples to be grouped
 
-         [(idR, idR)]    -- After renaming, the IDs are the binders
-                         -- occurring within this transform statement that
-                         -- are used after it which are paired with the
-                         -- names which they group over in statements
+         [(idR, idR)]    -- See Note [GroupStmt binder map]
                                
          (Maybe (LHsExpr idR))         -- "by e" (optional)
 
                                
          (Maybe (LHsExpr idR))         -- "by e" (optional)
 
@@ -857,7 +886,7 @@ data StmtLR idL idR
              (SyntaxExpr idR)) --   Right f => implicit; filled in with 'groupWith'
                                                        
 
              (SyntaxExpr idR)) --   Right f => implicit; filled in with 'groupWith'
                                                        
 
-  -- Recursive statement (see Note [RecStmt] below)
+  -- Recursive statement (see Note [How RecStmt works] below)
   | RecStmt
      { recS_stmts :: [LStmtLR idL idR]
 
   | RecStmt
      { recS_stmts :: [LStmtLR idL idR]
 
@@ -886,12 +915,30 @@ data StmtLR idL idR
                                      -- because the Id may be *polymorphic*, but
                                      -- the returned thing has to be *monomorphic*, 
                                     -- so they may be type applications
                                      -- because the Id may be *polymorphic*, but
                                      -- the returned thing has to be *monomorphic*, 
                                     -- so they may be type applications
-
-      , recS_dicts :: DictBinds idR  -- Method bindings of Ids bound by the
-                                     -- RecStmt, and used afterwards
       }
       }
+  deriving (Data, Typeable)
 \end{code}
 
 \end{code}
 
+Note [GroupStmt binder map]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The [(idR,idR)] in a GroupStmt behaves as follows:
+
+  * Before renaming: []
+
+  * After renaming: 
+         [ (x27,x27), ..., (z35,z35) ]
+    These are the variables 
+        bound by the stmts to the left of the 'group'
+       and used either in the 'by' clause, 
+                or     in the stmts following the 'group'
+    Each item is a pair of identical variables.
+
+  * After typechecking: 
+         [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]
+    Each pair has the same unique, but different *types*.
+   
+Note [ExprStmt]
+~~~~~~~~~~~~~~~
 ExprStmts are a bit tricky, because what they mean
 depends on the context.  Consider the following contexts:
 
 ExprStmts are a bit tricky, because what they mean
 depends on the context.  Consider the following contexts:
 
@@ -968,8 +1015,8 @@ pprStmt (ExprStmt expr _ _)       = ppr expr
 pprStmt (ParStmt stmtss)          = hsep (map doStmts stmtss)
   where doStmts stmts = ptext (sLit "| ") <> ppr stmts
 
 pprStmt (ParStmt stmtss)          = hsep (map doStmts stmtss)
   where doStmts stmts = ptext (sLit "| ") <> ppr stmts
 
-pprStmt (TransformStmt stmts _ using by)
-  = sep (ppr_lc_stmts stmts ++ [pprTransformStmt using by])
+pprStmt (TransformStmt stmts bndrs using by)
+  = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
 
 pprStmt (GroupStmt stmts _ by using) 
   = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
 
 pprStmt (GroupStmt stmts _ by using) 
   = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
@@ -981,8 +1028,11 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
          , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
                             , ptext (sLit "later_ids=") <> ppr later_ids])]
 
          , ifPprDebug (vcat [ ptext (sLit "rec_ids=") <> ppr rec_ids
                             , ptext (sLit "later_ids=") <> ppr later_ids])]
 
-pprTransformStmt :: OutputableBndr id => LHsExpr id -> Maybe (LHsExpr id) -> SDoc
-pprTransformStmt using by = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
+pprTransformStmt :: OutputableBndr id => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc
+pprTransformStmt bndrs using by
+  = sep [ ptext (sLit "then") <+> ifPprDebug (braces (ppr bndrs))
+        , nest 2 (ppr using)
+        , nest 2 (pprBy by)]
 
 pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
                                   -> Either (LHsExpr id) (SyntaxExpr is)
 
 pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
                                   -> Either (LHsExpr id) (SyntaxExpr is)
@@ -1000,7 +1050,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e
 pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
 pprDo DoExpr      stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
 pprDo GhciStmt    stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
 pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
 pprDo DoExpr      stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
 pprDo GhciStmt    stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
-pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
+pprDo MDoExpr     stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
 pprDo ListComp    stmts body = brackets    $ pprComp stmts body
 pprDo PArrComp    stmts body = pa_brackets $ pprComp stmts body
 pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
 pprDo ListComp    stmts body = brackets    $ pprComp stmts body
 pprDo PArrComp    stmts body = pa_brackets $ pprComp stmts body
 pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
@@ -1030,14 +1080,23 @@ pprComp quals body        -- Prints:  body | qual1, ..., qualn
 data HsSplice id  = HsSplice            --  $z  or $(f 4)
                         id              -- The id is just a unique name to
                         (LHsExpr id)    -- identify this splice point
 data HsSplice id  = HsSplice            --  $z  or $(f 4)
                         id              -- The id is just a unique name to
                         (LHsExpr id)    -- identify this splice point
+  deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsSplice id) where
   ppr = pprSplice
 
 pprSplice :: OutputableBndr id => HsSplice id -> SDoc
 pprSplice (HsSplice n e)
 
 instance OutputableBndr id => Outputable (HsSplice id) where
   ppr = pprSplice
 
 pprSplice :: OutputableBndr id => HsSplice id -> SDoc
 pprSplice (HsSplice n e)
-    = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
-
+    = char '$' <> ifPprDebug (brackets (ppr n)) <> eDoc
+    where
+          -- We use pprLExpr to match pprParendExpr:
+          --     Using pprLExpr makes sure that we go 'deeper'
+          --     I think that is usually (always?) right
+          pp_as_was = pprLExpr e
+          eDoc = case unLoc e of
+                 HsPar _ -> pp_as_was
+                 HsVar _ -> pp_as_was
+                 _ -> parens pp_as_was
 
 data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | PatBr (LPat id)      -- [p| pat   |]
 
 data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | PatBr (LPat id)      -- [p| pat   |]
@@ -1045,6 +1104,7 @@ data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
                   | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer
                   | TypBr (LHsType id)   -- [t| type  |]
                   | VarBr id             -- 'x, ''T
                   | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer
                   | TypBr (LHsType id)   -- [t| type  |]
                   | VarBr id             -- 'x, ''T
+  deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsBracket id) where
   ppr = pprHsBracket
 
 instance OutputableBndr id => Outputable (HsBracket id) where
   ppr = pprHsBracket
@@ -1083,6 +1143,7 @@ data ArithSeqInfo id
   | FromThenTo      (LHsExpr id)
                     (LHsExpr id)
                     (LHsExpr id)
   | FromThenTo      (LHsExpr id)
                     (LHsExpr id)
                     (LHsExpr id)
+  deriving (Data, Typeable)
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
@@ -1107,35 +1168,38 @@ pp_dotdot = ptext (sLit " .. ")
 \begin{code}
 data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
 \begin{code}
 data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
-  | CaseAlt                     -- Patterns and guards on a case alternative
   | LambdaExpr                  -- Patterns of a lambda
   | LambdaExpr                  -- Patterns of a lambda
+  | CaseAlt                     -- Patterns and guards on a case alternative
   | ProcExpr                    -- Patterns of a proc
   | ProcExpr                    -- Patterns of a proc
-  | PatBindRhs                  -- Patterns in the *guards* of a pattern binding
+  | PatBindRhs                  -- A pattern binding  eg [y] <- e = e
+
   | RecUpd                      -- Record update [used only in DsExpr to
                                 --    tell matchWrapper what sort of
                                 --    runtime error message to generate]
   | 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
+
+  | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, 
+                               -- pattern guard, etc
+
   | ThPatQuote                 -- A Template Haskell pattern quotation [p| (a,b) |]
   | ThPatQuote                 -- A Template Haskell pattern quotation [p| (a,b) |]
-  deriving ()
+  deriving (Data, Typeable)
 
 data HsStmtContext id
   = ListComp
   | DoExpr
   | GhciStmt                            -- A command-line Stmt in GHCi pat <- rhs
 
 data HsStmtContext id
   = ListComp
   | DoExpr
   | GhciStmt                            -- A command-line Stmt in GHCi pat <- rhs
-  | MDoExpr PostTcTable                  -- Recursive do-expression
-                                         -- (tiresomely, it needs table
-                                         --  of its return/bind ops)
+  | 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
   | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
   | PArrComp                             -- Parallel array comprehension
   | PatGuard (HsMatchContext id)         -- Pattern guard for specified thing
   | ParStmtCtxt (HsStmtContext id)       -- A branch of a parallel stmt
   | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
+  deriving (Data, Typeable)
 \end{code}
 
 \begin{code}
 isDoExpr :: HsStmtContext id -> Bool
 \end{code}
 
 \begin{code}
 isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr      = True
-isDoExpr (MDoExpr _) = True
-isDoExpr _           = False
+isDoExpr DoExpr  = True
+isDoExpr MDoExpr = True
+isDoExpr _       = False
 
 isListCompExpr :: HsStmtContext id -> Bool
 isListCompExpr ListComp = True
 
 isListCompExpr :: HsStmtContext id -> Bool
 isListCompExpr ListComp = True
@@ -1157,16 +1221,25 @@ matchSeparator ThPatQuote   = panic "unused"
 
 \begin{code}
 pprMatchContext :: Outputable id => HsMatchContext id -> SDoc
 
 \begin{code}
 pprMatchContext :: Outputable id => HsMatchContext id -> SDoc
-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 ThPatQuote        = ptext (sLit "a Template Haskell pattern quotation")
-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
+pprMatchContext ctxt 
+  | want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt
+  | otherwise    = ptext (sLit "a")  <+> pprMatchContextNoun ctxt
+  where
+    want_an (FunRhs {}) = True -- Use "an" in front
+    want_an ProcExpr    = True
+    want_an _           = False
+                 
+pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
+pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for")
+                                      <+> quotes (ppr fun)
+pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative")
+pprMatchContextNoun RecUpd          = ptext (sLit "record-update construct")
+pprMatchContextNoun ThPatQuote      = ptext (sLit "Template Haskell pattern quotation")
+pprMatchContextNoun PatBindRhs      = ptext (sLit "pattern binding")
+pprMatchContextNoun LambdaExpr      = ptext (sLit "lambda abstraction")
+pprMatchContextNoun ProcExpr        = ptext (sLit "arrow abstraction")
+pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
+                                      $$ pprStmtContext ctxt
 
 pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
 pprStmtContext (ParStmtCtxt c)
 
 pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
 pprStmtContext (ParStmtCtxt c)
@@ -1177,7 +1250,7 @@ pprStmtContext (PatGuard ctxt)
  = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
 pprStmtContext GhciStmt        = ptext (sLit "an interactive GHCi command")
 pprStmtContext DoExpr          = ptext (sLit "a 'do' expression")
  = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
 pprStmtContext GhciStmt        = ptext (sLit "an interactive GHCi command")
 pprStmtContext DoExpr          = ptext (sLit "a 'do' expression")
-pprStmtContext (MDoExpr _)     = ptext (sLit "an 'mdo' expression")
+pprStmtContext MDoExpr         = ptext (sLit "an 'mdo' expression")
 pprStmtContext ListComp        = ptext (sLit "a list comprehension")
 pprStmtContext PArrComp        = ptext (sLit "an array comprehension")
 
 pprStmtContext ListComp        = ptext (sLit "a list comprehension")
 pprStmtContext PArrComp        = ptext (sLit "an array comprehension")
 
@@ -1210,7 +1283,7 @@ matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (
 matchContextErrString (StmtCtxt (PatGuard _))    = ptext (sLit "pattern guard")
 matchContextErrString (StmtCtxt GhciStmt)        = ptext (sLit "interactive GHCi command")
 matchContextErrString (StmtCtxt DoExpr)          = ptext (sLit "'do' expression")
 matchContextErrString (StmtCtxt (PatGuard _))    = ptext (sLit "pattern guard")
 matchContextErrString (StmtCtxt GhciStmt)        = ptext (sLit "interactive GHCi command")
 matchContextErrString (StmtCtxt DoExpr)          = ptext (sLit "'do' expression")
-matchContextErrString (StmtCtxt (MDoExpr _))     = ptext (sLit "'mdo' expression")
+matchContextErrString (StmtCtxt MDoExpr)         = ptext (sLit "'mdo' expression")
 matchContextErrString (StmtCtxt ListComp)        = ptext (sLit "list comprehension")
 matchContextErrString (StmtCtxt PArrComp)        = ptext (sLit "array comprehension")
 \end{code}
 matchContextErrString (StmtCtxt ListComp)        = ptext (sLit "list comprehension")
 matchContextErrString (StmtCtxt PArrComp)        = ptext (sLit "array comprehension")
 \end{code}
@@ -1227,7 +1300,7 @@ pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext c
                          4 (ppr_stmt stmt)
   where
     -- For Group and Transform Stmts, don't print the nested stmts!
                          4 (ppr_stmt stmt)
   where
     -- For Group and Transform Stmts, don't print the nested stmts!
-    ppr_stmt (GroupStmt _ _ by using)     = pprGroupStmt by using
-    ppr_stmt (TransformStmt _ _ using by) = pprTransformStmt using by
-    ppr_stmt stmt                         = pprStmt stmt
+    ppr_stmt (GroupStmt _ _ by using)         = pprGroupStmt by using
+    ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by
+    ppr_stmt stmt                             = pprStmt stmt
 \end{code}
 \end{code}
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)