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

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

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 7fb28b1..a0cdb44 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -9,10 +9,16 @@
 module Match ( match, matchWrapper, matchSimply ) where
 
 IMP_Ubiq()
-IMPORT_DELOOPER(DsLoop)                -- here for paranoia-checking reasons
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
+IMPORT_DELOOPER(DsLoop)        -- here for paranoia-checking reasons
                        -- and to break dsExpr/dsBinds-ish loop
+#else
+import {-# SOURCE #-} DsExpr  ( dsExpr  )
+import {-# SOURCE #-} DsBinds ( dsBinds )
+#endif
 
-import HsSyn           hiding ( collectBinders{-also from CoreSyn-} )
+import CmdLineOpts     ( opt_WarnIncompletePatterns, opt_WarnOverlappedPatterns )
+import HsSyn           
 import TcHsSyn         ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch),
                          SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) )
 import DsHsSyn         ( outPatType, collectTypedPatBinders )
@@ -28,16 +34,17 @@ import MatchLit             ( matchLiterals )
 import FieldLabel      ( FieldLabel {- Eq instance -} )
 import Id              ( idType, dataConFieldLabels,
                          dataConArgTys, recordSelectorFieldLabel,
-                         GenId{-instance-}
+                         GenId{-instance-}, SYN_IE(Id)
                        )
 import Name            ( Name {--O only-} )
-import PprStyle                ( PprStyle(..) )
-import PprType         ( GenType{-instance-}, GenTyVar{-ditto-} )
+import Outputable      ( PprStyle(..), Outputable(..) )
+import PprType         ( GenType{-instance-}, GenTyVar{-ditto-} )        
+import Pretty          ( Doc )
 import PrelVals                ( pAT_ERROR_ID )
 import Type            ( isPrimType, eqTy, getAppDataTyConExpandingDicts,
-                         instantiateTauTy
+                         instantiateTauTy, SYN_IE(Type)
                        )
-import TyVar           ( GenTyVar{-instance Eq-} )
+import TyVar           ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
 import TysPrim         ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
                          addrPrimTy, wordPrimTy
                        )
@@ -166,8 +173,9 @@ match [] eqns_info shadows
        -- If at this stage we find that at least one of the shadowing
        -- equations is guaranteed not to fail, then warn of an overlapping pattern
     complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed
-       | is_shadowed = dsShadowWarn cxt        `thenDs` \ _ ->
-                       returnDs match_result
+       | opt_WarnOverlappedPatterns && is_shadowed = 
+           dsShadowWarn cxt    `thenDs` \ _ ->
+           returnDs match_result
 
        | otherwise   = returnDs match_result
 
@@ -316,12 +324,9 @@ tidy1 v (WildPat ty) match_result
 -}
 
 tidy1 v (LazyPat pat) match_result
-  = mkSelectorBinds [] pat l_to_l (Var v)      `thenDs` \ sel_binds ->
+  = mkSelectorBinds pat (Var v)                `thenDs` \ sel_binds ->
     returnDs (WildPat (idType v),
              mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
-  where
-    l_to_l = binders `zip` binders     -- Boring
-    binders = collectTypedPatBinders pat
 
 -- re-express <con-something> as (ConPat ...) [directly]
 
@@ -334,7 +339,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 "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty
+    (_, inst_tys, _) = getAppDataTyConExpandingDicts pat_ty
     con_arg_tys'     = dataConArgTys con_id inst_tys 
     tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels con_id)
 
@@ -608,14 +613,14 @@ matchWrapper kind [(PatMatch (VarPat var) match)] error_string
     returnDs (var:vars, core_expr)
 
 matchWrapper kind [(PatMatch (WildPat ty) match)] error_string
-  = newSysLocalDs ty                 `thenDs` \ var ->
+  = newSysLocalDs ty                      `thenDs` \ var ->
     matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) ->
     returnDs (var:vars, core_expr)
 
 matchWrapper kind [(GRHSMatch
                     (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string
-  = dsBinds binds      `thenDs` \ core_binds ->
-    dsExpr  expr       `thenDs` \ core_expr ->
+  = dsBinds False{-don't auto-scc-} binds            `thenDs` \ core_binds ->
+    dsExpr  expr                                    `thenDs` \ core_expr ->
     returnDs ([], mkCoLetsAny core_binds core_expr)
 
 ----------------------------------------------------------------------------
@@ -631,8 +636,10 @@ matchWrapper kind matches error_string
 
        -- Check for incomplete pattern match
     (case match_result of
-       MatchResult CanFail result_ty match_fn cxt -> dsIncompleteWarn cxt
-       other                                      -> returnDs ()
+       MatchResult CanFail result_ty match_fn cxt 
+               | opt_WarnIncompletePatterns
+               -> dsIncompleteWarn cxt
+       other   -> returnDs ()
     )                                                  `thenDs` \ _ ->
 
     extractMatchResult match_result fail_expr          `thenDs` \ result_expr ->
@@ -711,7 +718,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{-don't auto-scc-} binds  `thenDs` \ core_binds ->
        dsGRHSs ty kind pats grhss              `thenDs` \ match_result ->
        returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
       where
@@ -730,3 +737,4 @@ flattenMatches kind (match : matches)
         pats = reverse pats_so_far     -- They've accumulated in reverse order
 
 \end{code}
+