[project @ 1996-06-26 10:26:00 by partain]

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

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index fd4bb5d..e63d559 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,11 +8,11 @@
 
 module Match ( match, matchWrapper, matchSimply ) where
 
-import Ubiq
-import DsLoop          -- here for paranoia-checking reasons
+IMP_Ubiq()
+IMPORT_DELOOPER(DsLoop)                -- here for paranoia-checking reasons
                        -- and to break dsExpr/dsBinds-ish loop
 
-import HsSyn
+import HsSyn           hiding ( collectBinders{-also from CoreSyn-} )
 import TcHsSyn         ( TypecheckedPat(..), TypecheckedMatch(..),
                          TypecheckedHsBinds(..), TypecheckedHsExpr(..) )
 import DsHsSyn         ( outPatType, collectTypedPatBinders )
@@ -26,25 +26,26 @@ import MatchCon             ( matchConFamily )
 import MatchLit                ( matchLiterals )
 
 import FieldLabel      ( allFieldLabelTags, fieldLabelTag )
-import Id              ( idType, mkTupleCon, dataConSig,
+import Id              ( idType, mkTupleCon,
                          dataConArgTys, recordSelectorFieldLabel,
                          GenId{-instance-}
                        )
 import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType{-instance-}, GenTyVar{-ditto-} )
-import PrelInfo                ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
-                         charTy, charDataCon, intTy, intDataCon,
-                         floatTy, floatDataCon, doubleTy, doubleDataCon,
-                         integerTy, intPrimTy, charPrimTy,
-                         floatPrimTy, doublePrimTy, stringTy,
-                         addrTy, addrPrimTy, addrDataCon,
-                         wordTy, wordPrimTy, wordDataCon,
-                         pAT_ERROR_ID
-                       )
-import Type            ( isPrimType, eqTy, getAppDataTyCon,
+import PrelVals                ( pAT_ERROR_ID )
+import Type            ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
                          instantiateTauTy
                        )
 import TyVar           ( GenTyVar{-instance Eq-} )
+import TysPrim         ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
+                         addrPrimTy, wordPrimTy
+                       )
+import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+                         charTy, charDataCon, intTy, intDataCon,
+                         floatTy, floatDataCon, doubleTy,
+                         doubleDataCon, stringTy, addrTy,
+                         addrDataCon, wordTy, wordDataCon
+                       )
 import Unique          ( Unique{-instance Eq-} )
 import Util            ( panic, pprPanic, assertPanic )
 \end{code}
@@ -208,9 +209,9 @@ match vars@(v:vs) eqns_info shadows
     unmix_eqns []    = []
     unmix_eqns [eqn] = [ [eqn] ]
     unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs)
-      = if (  (unfailablePat p1 && unfailablePat p2)
-          || (isConPat      p1 && isConPat p2)
-          || (isLitPat      p1 && isLitPat p2) ) then
+      = if (  (irrefutablePat p1 && irrefutablePat p2)
+          || (isConPat       p1 && isConPat       p2)
+          || (isLitPat       p1 && isLitPat       p2) ) then
            eq1 `tack_onto` unmixed_rest
        else
            [ eq1 ] : unmixed_rest
@@ -334,7 +335,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result
     pats            = map mk_pat tagged_arg_tys
 
        -- Boring stuff to find the arg-tys of the constructor
-    (_, inst_tys, _) = _trace "getAppDataTyCon.Match" $ getAppDataTyCon pat_ty
+    (_, inst_tys, _) = {-trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
     con_arg_tys'     = dataConArgTys con_id inst_tys 
     tagged_arg_tys   = con_arg_tys' `zip` allFieldLabelTags
 
@@ -513,21 +514,24 @@ matchUnmixedEqns :: [Id]
 matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
 
 matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
-  | unfailablePats column_1_pats       -- Could check just one; we know they've been tidied, unmixed;
-                                       -- this way is (arguably) a sanity-check
-  =    -- Real true variables, just like in matchVar, SLPJ p 94
+  | irrefutablePat first_pat
+  = ASSERT( irrefutablePats column_1_pats )    -- Sanity check
+       -- Real true variables, just like in matchVar, SLPJ p 94
     match vars remaining_eqns_info remaining_shadows
 
-  | patsAreAllCons column_1_pats       -- ToDo: maybe check just one...
-  = matchConFamily all_vars eqns_info shadows
+  | isConPat first_pat
+  = ASSERT( patsAreAllCons column_1_pats )
+    matchConFamily all_vars eqns_info shadows
 
-  | patsAreAllLits column_1_pats       -- ToDo: maybe check just one...
-  =    -- see notes in MatchLiteral
+  | isLitPat first_pat
+  = ASSERT( patsAreAllLits column_1_pats )
+       -- see notes in MatchLiteral
        -- not worried about the same literal more than once in a column
        -- (ToDo: sort this out later)
     matchLiterals all_vars eqns_info shadows
 
   where
+    first_pat          = head column_1_pats
     column_1_pats      = [pat                       | EqnInfo (pat:_)  _            <- eqns_info]
     remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
     remaining_shadows   = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
@@ -603,7 +607,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
 
 matchWrapper kind [(GRHSMatch
                     (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
-  = dsBinds binds      `thenDs` \ core_binds ->
+  = dsBinds False binds        `thenDs` \ core_binds ->
     dsExpr  expr       `thenDs` \ core_expr ->
     returnDs ([], mkCoLetsAny core_binds core_expr)
 
@@ -694,7 +698,7 @@ flattenMatches kind (match : matches)
       = flatten_match (pat:pats_so_far) match
 
     flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty))
-      = dsBinds binds                          `thenDs` \ core_binds ->
+      = dsBinds False binds                    `thenDs` \ core_binds ->
        dsGRHSs ty kind pats grhss              `thenDs` \ match_result ->
        returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
       where