[project @ 1997-06-13 04:11:47 by sof]
[ghc-hetmet.git] / ghc / compiler / deSugar / Match.lhs
index eea7667..a0cdb44 100644 (file)
@@ -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 )
@@ -25,24 +31,26 @@ import DsUtils
 import MatchCon                ( matchConFamily )
 import MatchLit                ( matchLiterals )
 
-import FieldLabel      ( allFieldLabelTags, fieldLabelTag )
-import Id              ( idType, mkTupleCon,
+import FieldLabel      ( FieldLabel {- Eq instance -} )
+import Id              ( idType, dataConFieldLabels,
                          dataConArgTys, recordSelectorFieldLabel,
-                         GenId{-instance-}
+                         GenId{-instance-}, SYN_IE(Id)
                        )
-import PprStyle                ( PprStyle(..) )
-import PprType         ( GenType{-instance-}, GenTyVar{-ditto-} )
+import Name            ( Name {--O only-} )
+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
                        )
 import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
                          charTy, charDataCon, intTy, intDataCon,
-                         floatTy, floatDataCon, doubleTy,
+                         floatTy, floatDataCon, doubleTy, tupleCon,
                          doubleDataCon, stringTy, addrTy,
                          addrDataCon, wordTy, wordDataCon
                        )
@@ -152,31 +160,28 @@ And gluing the ``success expressions'' together isn't quite so pretty.
 
 \begin{code}
 match [] eqns_info shadows
-  = pin_eqns eqns_info         `thenDs` \ match_result@(MatchResult _ _ _ cxt) ->
+  = complete_matches eqns_info (any eqn_cant_fail shadows)
+  where
+    complete_matches [eqn] is_shadowed 
+       = complete_match eqn is_shadowed
+    complete_matches (eqn:eqns) is_shadowed
+       = complete_match eqn is_shadowed                                `thenDs` \ match_result1 ->
+         complete_matches eqns (is_shadowed || eqn_cant_fail eqn)      `thenDs` \ match_result2 ->
+         combineMatchResults match_result1 match_result2
 
        -- 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
-    if not (all shadow_can_fail shadows) then
-       dsShadowError cxt       `thenDs` \ _ ->
-       returnDs match_result
-    else
-       returnDs match_result
-
-  where
-    pin_eqns [EqnInfo [] match_result] = returnDs match_result
-      -- Last eqn... can't have pats ...
-
-    pin_eqns (EqnInfo [] match_result1 : more_eqns)
-      = pin_eqns more_eqns                     `thenDs` \ match_result2 ->
-       combineMatchResults match_result1 match_result2
+    complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed
+       | opt_WarnOverlappedPatterns && is_shadowed = 
+           dsShadowWarn cxt    `thenDs` \ _ ->
+           returnDs match_result
 
-    pin_eqns other_pat = panic "match: pin_eqns"
+       | otherwise   = returnDs match_result
 
-    shadow_can_fail :: EquationInfo -> Bool
-
-    shadow_can_fail (EqnInfo [] (MatchResult CanFail  _ _ _)) = True
-    shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False
-    shadow_can_fail other = panic "match:shadow_can_fail"
+    eqn_cant_fail :: EquationInfo -> Bool
+    eqn_cant_fail (EqnInfo [] (MatchResult CanFail  _ _ _)) = False
+    eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True
 \end{code}
 
 %************************************************************************
@@ -252,6 +257,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
 Removing lazy (irrefutable) patterns (you don't want to know...).
 \item
 Converting explicit tuple- and list-pats into ordinary @ConPats@.
+\item
+Convert the literal pat "" to [].
 \end{itemize}
 
 The result of this tidying is that the column of patterns will include
@@ -317,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]
 
@@ -335,14 +339,14 @@ 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` allFieldLabelTags
+    tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels con_id)
 
        -- mk_pat picks a WildPat of the appropriate type for absent fields,
        -- and the specified pattern for present fields
-    mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats,
-                                       fieldLabelTag (recordSelectorFieldLabel sel_id) == tag 
+    mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats,
+                                       recordSelectorFieldLabel sel_id == lbl
                                ] of
                                (pat:pats) -> ASSERT( null pats )
                                              pat
@@ -362,7 +366,7 @@ tidy1 v (TuplePat pats) match_result
   where
     arity = length pats
     tuple_ConPat
-      = ConPat (mkTupleCon arity)
+      = ConPat (tupleCon arity)
               (mkTupleTy arity (map outPatType pats))
               pats
 
@@ -394,6 +398,7 @@ tidy1 v pat@(LitPat lit lit_ty) match_result
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 
+
 tidy1 v pat@(NPat lit lit_ty _) match_result
   = returnDs (better_pat, match_result)
   where
@@ -404,6 +409,10 @@ tidy1 v pat@(NPat lit lit_ty _) match_result
       | lit_ty `eqTy` addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
       | lit_ty `eqTy` floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
       | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy]
+
+               -- Convert the literal pattern "" to the constructor pattern [].
+      | null_str_lit lit       = ConPat nilDataCon    lit_ty [] 
+
       | otherwise         = pat
 
     mk_int    (HsInt i)      = HsIntPrim i
@@ -424,6 +433,9 @@ tidy1 v pat@(NPat lit lit_ty _) match_result
     mk_double (HsFrac f)     = HsDoublePrim f
     mk_double l@(HsLitLit s) = l
 
+    null_str_lit (HsString s) = _NULL_ s
+    null_str_lit other_lit    = False
+
 -- and everything else goes through unchanged...
 
 tidy1 v non_interesting_pat match_result
@@ -601,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 False 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)
 
 ----------------------------------------------------------------------------
@@ -621,8 +633,16 @@ matchWrapper kind matches error_string
     match new_vars eqns_info []                                `thenDs` \ match_result ->
 
     mkErrorAppDs pAT_ERROR_ID result_ty error_string   `thenDs` \ fail_expr ->
-    extractMatchResult match_result fail_expr          `thenDs` \ result_expr ->
 
+       -- Check for incomplete pattern match
+    (case match_result of
+       MatchResult CanFail result_ty match_fn cxt 
+               | opt_WarnIncompletePatterns
+               -> dsIncompleteWarn cxt
+       other   -> returnDs ()
+    )                                                  `thenDs` \ _ ->
+
+    extractMatchResult match_result fail_expr          `thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
 \end{code}
 
@@ -663,8 +683,8 @@ matchSimply scrut_expr pat result_ty result_expr msg
 extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr
   = returnDs (match_fn (error "It can't fail!"))
 
-extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr
-  = mkFailurePair result_ty    `thenDs` \ (fail_bind_fn, if_it_fails) ->
+extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr
+  = mkFailurePair result_ty            `thenDs` \ (fail_bind_fn, if_it_fails) ->
     returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails))
 \end{code}
 
@@ -698,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 False 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
@@ -706,12 +726,15 @@ flattenMatches kind (match : matches)
 
     flatten_match pats_so_far (SimpleMatch expr) 
       = dsExpr expr            `thenDs` \ core_expr ->
+       getSrcLocDs             `thenDs` \ locn ->
        returnDs (EqnInfo pats
                    (MatchResult CantFail (coreExprType core_expr) 
                              (\ ignore -> core_expr)
-                             NoMatchContext))
-       -- The NoMatchContext is just a place holder.  In a simple match,
-       -- the matching can't fail, so we won't generate an error message.
-      where
-       pats = reverse pats_so_far      -- They've accumulated in reverse order
+                             (DsMatchContext kind pats locn)))
+
+        -- the matching can't fail, so we won't generate an error message.
+        where
+        pats = reverse pats_so_far     -- They've accumulated in reverse order
+
 \end{code}
+