[project @ 1997-06-13 04:11:47 by sof]

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

diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs
index fd8bec3..63c41d7 100644 (file)
--- a/ghc/compiler/deSugar/DsGRHSs.lhs
+++ b/ghc/compiler/deSugar/DsGRHSs.lhs
@@ -9,23 +9,37 @@
 module DsGRHSs ( dsGuarded, dsGRHSs ) where
 
 IMP_Ubiq()
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
 IMPORT_DELOOPER(DsLoop)                -- break dsExpr/dsBinds-ish loop
+#else
+import {-# SOURCE #-} DsExpr  ( dsExpr )
+import {-# SOURCE #-} DsBinds ( dsBinds )
+import {-# SOURCE #-} Match   ( match )
+#endif
 
 import HsSyn           ( GRHSsAndBinds(..), GRHS(..),
-                         HsExpr, HsBinds )
-import TcHsSyn         ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
-                         TypecheckedPat(..), TypecheckedHsBinds(..),
-                         TypecheckedHsExpr(..) )
-import CoreSyn         ( CoreBinding(..), CoreExpr(..), mkCoLetsAny )
+                         HsExpr(..), HsBinds, Stmt(..), 
+                         HsLit, Match, Fixity, DoOrListComp, HsType, ArithSeqInfo
+                        )
+import TcHsSyn         ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS),
+                         SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds),
+                         SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedStmt)
+                       )
+import CoreSyn         ( SYN_IE(CoreBinding), GenCoreBinding(..), SYN_IE(CoreExpr), mkCoLetsAny )
 
 import DsMonad
 import DsUtils
 
-import CoreUtils       ( mkCoreIfThenElse )
+#if __GLASGOW_HASKELL__ < 200
+import Id              ( GenId )
+#endif
+import CoreUtils       ( coreExprType, mkCoreIfThenElse )
 import PrelVals                ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
-import PprStyle                ( PprStyle(..) )
-import Pretty          ( ppShow )
+import Outputable      ( PprStyle(..) )
 import SrcLoc          ( SrcLoc{-instance-} )
+import Type             ( SYN_IE(Type) )
+import Unique          ( Unique, otherwiseIdKey )
+import UniqFM           ( Uniquable(..) )
 import Util            ( panic )
 \end{code}
 
@@ -45,7 +59,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds
          -> DsM CoreExpr
 
 dsGuarded (GRHSsAndBindsOut grhss binds err_ty)
-  = dsBinds binds                              `thenDs` \ core_binds ->
+  = dsBinds False{-don't auto scc-} binds       `thenDs` \ core_binds ->
     dsGRHSs err_ty PatBindMatch [] grhss       `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) ->
     case can_it_fail of
        CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail")))
@@ -78,23 +92,60 @@ dsGRHSs ty kind pats (grhs:grhss)
     combineGRHSMatchResults match_result1 match_result2
 
 dsGRHS ty kind pats (OtherwiseGRHS expr locn)
-  = putSrcLocDs locn            (
+  = putSrcLocDs locn $
     dsExpr expr        `thenDs` \ core_expr ->
     let
        expr_fn = \ ignore -> core_expr
     in
     returnDs (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
-    )
 
 dsGRHS ty kind pats (GRHS guard expr locn)
-  = putSrcLocDs locn            (
-    dsExpr guard       `thenDs` \ core_guard ->
-    dsExpr expr        `thenDs` \ core_expr  ->
+  = putSrcLocDs locn $
+    dsExpr expr        `thenDs` \ core_expr ->
     let
-       expr_fn = \ fail -> mkCoreIfThenElse core_guard core_expr fail
+       expr_fn = \ ignore -> core_expr
     in
-    returnDs (MatchResult CanFail ty expr_fn (DsMatchContext kind pats locn))
-    )
+    matchGuard guard (MatchResult CantFail ty expr_fn (DsMatchContext kind pats locn))
 \end{code}
 
 
+
+
+%************************************************************************
+%*                                                                     *
+%*  matchGuard : make a MatchResult from a guarded RHS                 *
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+matchGuard :: [TypecheckedStmt]        -- Guard
+          -> MatchResult               -- What to do if the guard succeeds
+          -> DsM MatchResult
+
+matchGuard [] body_result = returnDs body_result
+
+       -- Turn an "otherwise" guard is a no-op
+matchGuard (GuardStmt (HsVar v) _ : stmts) body_result
+  | uniqueOf v == otherwiseIdKey
+  = matchGuard stmts body_result
+
+matchGuard (GuardStmt expr _ : stmts) body_result
+  = matchGuard stmts body_result       `thenDs` \ (MatchResult _ ty body_fn cxt) ->
+    dsExpr expr                                `thenDs` \ core_expr ->
+    let
+       expr_fn = \ fail -> mkCoreIfThenElse core_expr (body_fn fail) fail
+    in
+    returnDs (MatchResult CanFail ty expr_fn cxt)
+
+matchGuard (LetStmt binds : stmts) body_result
+  = matchGuard stmts body_result         `thenDs` \ match_result ->
+    dsBinds False{-don't auto scc-} binds `thenDs` \ core_binds ->
+    returnDs (mkCoLetsMatchResult core_binds match_result)
+
+matchGuard (BindStmt pat rhs _ : stmts) body_result
+  = matchGuard stmts body_result                       `thenDs` \ match_result ->
+    dsExpr rhs                                         `thenDs` \ core_rhs ->
+    newSysLocalDs (coreExprType core_rhs)              `thenDs` \ scrut_var ->
+    match [scrut_var] [EqnInfo [pat] match_result] []  `thenDs` \ match_result' ->
+    returnDs (mkCoLetsMatchResult [NonRec scrut_var core_rhs] match_result')
+\end{code}