X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsExpr.lhs;h=8ea0c4fbf57fe9c06e1fa2cc7f417d0d455f9dc9;hp=6dd1381611e9444ec088d03f2de12fd6da53b7c9;hb=e5c3b478b3cd1707cf122833822f44b2ac09b8e9;hpb=e01036f89a0d3949ea642dd42b29bc8e31658f0f

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 6dd1381..8ea0c4f 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -106,6 +106,10 @@ data HsExpr id
 
   | HsApp     (LHsExpr id) (LHsExpr id) -- Application
 
+  | HsKappa    (MatchGroup id)
+
+  | HsKappaApp (LHsExpr id) (LHsExpr id)
+
   -- Operator applications:
   -- NB Bracketed ops such as (+) come out as Vars.
 
@@ -223,6 +227,13 @@ data HsExpr id
                 (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
 
@@ -353,10 +364,15 @@ 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 (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 (HsKappaApp e1 e2) = ppr_expr $ HsApp e1 e2
+ppr_expr (HsKappa    e) = ppr_expr $ HsLam e
 ppr_expr (HsApp e1 e2)
   = let (fun, args) = collect_args e1 [e2] in
     hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
@@ -1116,6 +1132,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e
 pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc
 pprDo DoExpr      stmts = ptext (sLit "do")  <+> ppr_do_stmts stmts
 pprDo GhciStmt    stmts = ptext (sLit "do")  <+> ppr_do_stmts stmts
+pprDo ArrowExpr   stmts = ptext (sLit "do")  <+> ppr_do_stmts stmts
 pprDo MDoExpr     stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
 pprDo ListComp    stmts = brackets    $ pprComp stmts
 pprDo PArrComp    stmts = pa_brackets $ pprComp stmts
@@ -1261,32 +1278,30 @@ data HsStmtContext id
 
   | DoExpr				 -- do { ... }
   | MDoExpr                              -- mdo { ... }  ie recursive do-expression 
+  | ArrowExpr				 -- do-notation in an arrow-command context
 
   | GhciStmt				 -- A command-line Stmt in GHCi pat <- rhs
   | 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
+  | TransStmtCtxt (HsStmtContext id)     -- A branch of a transform stmt
   deriving (Data, Typeable)
 \end{code}
 
 \begin{code}
-isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr   = True
-isDoExpr MDoExpr  = True
-isDoExpr GhciStmt = True
-isDoExpr _        = False
-
 isListCompExpr :: HsStmtContext id -> Bool
-isListCompExpr ListComp  = True
-isListCompExpr PArrComp  = True
-isListCompExpr MonadComp = True
-isListCompExpr _         = False
+-- Uses syntax [ e | quals ]
+isListCompExpr ListComp  	 = True
+isListCompExpr PArrComp  	 = True
+isListCompExpr MonadComp 	 = True  
+isListCompExpr (ParStmtCtxt c)   = isListCompExpr c
+isListCompExpr (TransStmtCtxt c) = isListCompExpr c
+isListCompExpr _                 = False
 
 isMonadCompExpr :: HsStmtContext id -> Bool
-isMonadCompExpr MonadComp                = True
-isMonadCompExpr (ParStmtCtxt ctxt)       = isMonadCompExpr ctxt
-isMonadCompExpr (TransformStmtCtxt ctxt) = isMonadCompExpr ctxt
-isMonadCompExpr _                        = False
+isMonadCompExpr MonadComp            = True
+isMonadCompExpr (ParStmtCtxt ctxt)   = isMonadCompExpr ctxt
+isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr _                    = False
 \end{code}
 
 \begin{code}
@@ -1340,6 +1355,7 @@ pprAStmtContext ctxt = article <+> pprStmtContext ctxt
 pprStmtContext GhciStmt        = ptext (sLit "interactive GHCi command")
 pprStmtContext DoExpr          = ptext (sLit "'do' block")
 pprStmtContext MDoExpr         = ptext (sLit "'mdo' block")
+pprStmtContext ArrowExpr       = ptext (sLit "'do' block in an arrow command")
 pprStmtContext ListComp        = ptext (sLit "list comprehension")
 pprStmtContext MonadComp       = ptext (sLit "monad comprehension")
 pprStmtContext PArrComp        = ptext (sLit "array comprehension")
@@ -1353,7 +1369,7 @@ pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchCon
 pprStmtContext (ParStmtCtxt c)
  | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
  | otherwise          = pprStmtContext c
-pprStmtContext (TransformStmtCtxt c)
+pprStmtContext (TransStmtCtxt c)
  | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
  | otherwise          = pprStmtContext c
 
@@ -1367,15 +1383,16 @@ matchContextErrString RecUpd                     = ptext (sLit "record update")
 matchContextErrString LambdaExpr                 = ptext (sLit "lambda")
 matchContextErrString ProcExpr                   = ptext (sLit "proc")
 matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime
-matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-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 ListComp)        = ptext (sLit "list comprehension")
-matchContextErrString (StmtCtxt MonadComp)       = ptext (sLit "monad comprehension")
-matchContextErrString (StmtCtxt PArrComp)        = ptext (sLit "array comprehension")
+matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (PatGuard _))      = ptext (sLit "pattern guard")
+matchContextErrString (StmtCtxt GhciStmt)          = ptext (sLit "interactive GHCi command")
+matchContextErrString (StmtCtxt DoExpr)            = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt ArrowExpr)         = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt MDoExpr)           = ptext (sLit "'mdo' block")
+matchContextErrString (StmtCtxt ListComp)          = ptext (sLit "list comprehension")
+matchContextErrString (StmtCtxt MonadComp)         = ptext (sLit "monad comprehension")
+matchContextErrString (StmtCtxt PArrComp)          = ptext (sLit "array comprehension")
 \end{code}
 
 \begin{code}