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 7930caa..b7fe6fc 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -48,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"))

@@ -62,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
 

@@ -132,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
 

@@ -220,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
 

@@ -297,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

@@ -343,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]

@@ -414,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"),

@@ -619,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

@@ -748,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

@@ -894,9 +915,6 @@ 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}
       }
   deriving (Data, Typeable)
 \end{code}

@@ -997,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])

@@ -1010,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)

@@ -1029,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

@@ -1066,8 +1087,16 @@ instance OutputableBndr id => Outputable (HsSplice id) where
 
 pprSplice :: OutputableBndr id => HsSplice id -> SDoc
 pprSplice (HsSplice n e)
 
 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   |]

@@ -1139,14 +1168,18 @@ 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) |]
   deriving (Data, Typeable)
 
   | ThPatQuote                 -- A Template Haskell pattern quotation [p| (a,b) |]
   deriving (Data, Typeable)
 

@@ -1154,9 +1187,7 @@ data HsStmtContext id
   = ListComp
   | DoExpr
   | GhciStmt                            -- A command-line Stmt in GHCi pat <- rhs
   = 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
   | PArrComp                             -- Parallel array comprehension
   | PatGuard (HsMatchContext id)         -- Pattern guard for specified thing
   | ParStmtCtxt (HsStmtContext id)       -- A branch of a parallel stmt

@@ -1166,9 +1197,9 @@ data HsStmtContext id
 
 \begin{code}
 isDoExpr :: HsStmtContext id -> Bool
 
 \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

@@ -1190,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)

@@ -1210,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")
 

@@ -1243,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}

@@ -1260,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}