[project @ 2003-02-21 13:25:17 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsExpr.lhs

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 8818229..46e63e3 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -15,16 +15,15 @@ import DsBinds              ( dsMonoBinds, AutoScc(..) )
 import DsGRHSs         ( dsGuarded )
 import DsCCall         ( dsCCall )
 import DsListComp      ( dsListComp, dsPArrComp )
-import DsUtils         ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr)
+import DsUtils         ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, selectMatchVar )
 import DsMonad
 
 #ifdef GHCI
        -- Template Haskell stuff iff bootstrapped
-import DsMeta          ( dsBracket )
+import DsMeta          ( dsBracket, dsReify )
 #endif
 
-import HsSyn           ( failureFreePat,
-                         HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
+import HsSyn           ( HsExpr(..), Pat(..), ArithSeqInfo(..),
                          Stmt(..), HsMatchContext(..), HsStmtContext(..), 
                          Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
                          mkSimpleMatch, isDoExpr
@@ -88,6 +87,13 @@ dsLet (ThenBinds b1 b2) body
   = dsLet b2 body      `thenDs` \ body' ->
     dsLet b1 body'
   
+dsLet (IPBinds binds is_with) body
+  = foldlDs dsIPBind body binds
+  where
+    dsIPBind body (n, e)
+        = dsExpr e     `thenDs` \ e' ->
+         returnDs (Let (NonRec (ipNameName n) e') body)
+
 -- Special case for bindings which bind unlifted variables
 -- We need to do a case right away, rather than building
 -- a tuple and doing selections.
@@ -234,6 +240,13 @@ dsExpr (HsSCC cc expr)
     getModuleDs                        `thenDs` \ mod_name ->
     returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
 
+
+-- hdaume: core annotation
+
+dsExpr (HsCoreAnn fs expr)
+  = dsExpr expr        `thenDs` \ core_expr ->
+    returnDs (Note (CoreNote $ unpackFS fs) core_expr)
+
 -- special case to handle unboxed tuple patterns.
 
 dsExpr (HsCase discrim matches src_loc)
@@ -259,14 +272,6 @@ dsExpr (HsLet binds body)
   = dsExpr body                `thenDs` \ body' ->
     dsLet binds body'
 
-dsExpr (HsWith expr binds is_with)
-  = dsExpr expr                `thenDs` \ expr' ->
-    foldlDs dsIPBind expr' binds
-    where
-      dsIPBind body (n, e)
-        = dsExpr e     `thenDs` \ e' ->
-         returnDs (Let (NonRec (ipNameName n) e') body)
-
 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 -- because the interpretation of `stmts' depends on what sort of thing it is.
 --
@@ -550,7 +555,8 @@ Here is where we desugar the Template Haskell brackets and escapes
 
 #ifdef GHCI    /* Only if bootstrapping */
 dsExpr (HsBracketOut x ps) = dsBracket x ps
-dsExpr (HsSplice n e)      = pprPanic "dsExpr:splice" (ppr e)
+dsExpr (HsReify r)        = dsReify r
+dsExpr (HsSplice n e _)    = pprPanic "dsExpr:splice" (ppr e)
 #endif
 
 \end{code}
@@ -615,37 +621,32 @@ dsDo do_or_lc stmts ids result_ty
            dsLet binds rest
            
        go (BindStmt pat expr locn : stmts)
-         = putSrcLocDs locn $
-           dsExpr expr            `thenDs` \ expr2 ->
+         = go stmts                    `thenDs` \ body -> 
+           putSrcLocDs locn            $       -- Rest is associated with this location
+           dsExpr expr                 `thenDs` \ rhs ->
+           mkStringLit (mk_msg locn)   `thenDs` \ core_msg ->
            let
+               -- In a do expression, pattern-match failure just calls
+               -- the monadic 'fail' rather than throwing an exception
+               fail_expr  = mkApps (Var fail_id) [Type b_ty, core_msg]
                a_ty       = hsPatType pat
-               fail_expr  = HsApp (TyApp (HsVar fail_id) [b_ty])
-                                   (HsLit (HsString (mkFastString msg)))
-               msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
-               main_match = mkSimpleMatch [pat] 
-                                          (HsDo do_or_lc stmts ids result_ty locn)
-                                          result_ty locn
-               the_matches
-                 | failureFreePat pat = [main_match]
-                 | otherwise          =
-                     [ main_match
-                     , mkSimpleMatch [WildPat a_ty] fail_expr result_ty locn
-                     ]
            in
-           matchWrapper (StmtCtxt do_or_lc) the_matches        `thenDs` \ (binders, matching_code) ->
-           returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
-                                           mkLams binders matching_code])
+           selectMatchVar pat                                  `thenDs` \ var ->
+           matchSimply (Var var) (StmtCtxt do_or_lc) pat
+                       body fail_expr                          `thenDs` \ match_code ->
+           returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, rhs, Lam var match_code])
 
-       go (RecStmt rec_vars rec_stmts : stmts)
+       go (RecStmt rec_vars rec_stmts rec_rets : stmts)
          = go (bind_stmt : stmts)
          where
-           bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts
+           bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
            
     in
     go stmts
 
   where
     do_expr expr locn = putSrcLocDs locn (dsExpr expr)
+    mk_msg locn = "Pattern match failure in do expression at " ++ showSDoc (ppr locn)
 \end{code}
 
 Translation for RecStmt's: 
@@ -658,19 +659,21 @@ We turn (RecStmt [v1,..vn] stmts) into:
 \begin{code}
 dsRecStmt :: Type              -- Monad type constructor :: * -> *
          -> [Id]               -- Ids for: [return,fail,>>=,>>,mfix]
-         -> [Id] -> [TypecheckedStmt]  -- Guts of the RecStmt
+         -> [Id] -> [TypecheckedStmt]  -> [TypecheckedHsExpr]  -- Guts of the RecStmt
          -> TypecheckedStmt
-dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts
-  = BindStmt tup_pat mfix_app noSrcLoc
+dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
+  = ASSERT( length vars == length rets )
+    BindStmt tup_pat mfix_app noSrcLoc
   where 
        (var1:rest) = vars              -- Always at least one
+       (ret1:_)    = rets
        one_var     = null rest
 
        mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
        mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
 
-       tup_expr | one_var   = HsVar var1
-                | otherwise = ExplicitTuple (map HsVar vars) Boxed
+       tup_expr | one_var   = ret1
+                | otherwise = ExplicitTuple rets Boxed
        tup_ty   | one_var   = idType var1
                 | otherwise = mkTupleTy Boxed (length vars) (map idType vars)
        tup_pat  | one_var   = VarPat var1