[project @ 1998-04-16 12:06:11 by sof]

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

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index ebdadb4..0504989 100644 (file)
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -5,41 +5,23 @@
 
 \begin{code}
 
-#include "HsVersions.h"
 
-module Check ( check , SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString(..) ) where
+module Check ( check , ExhaustivePat, WarningPat, BoxedString(..) ) where
 
-IMP_Ubiq()
-#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           
-import TcHsSyn         ( SYN_IE(TypecheckedPat), 
-                          SYN_IE(TypecheckedMatch),
-                         SYN_IE(TypecheckedHsBinds), 
-                          SYN_IE(TypecheckedHsExpr)    
-                        )
+import TcHsSyn         ( TypecheckedPat )
 import DsHsSyn         ( outPatType ) 
 import CoreSyn         
 
-import DsMonad         ( DsMatchContext(..),
-                         DsMatchKind(..)
-                        )
 import DsUtils         ( EquationInfo(..),
                          MatchResult(..),
-                         SYN_IE(EqnNo),
-                         SYN_IE(EqnSet),
+                         EqnNo,
+                         EqnSet,
                          CanItFail(..)
                        )
 import Id              ( idType,
-                         GenId{-instance-}, 
-                          SYN_IE(Id),
-                         idName,
+                         Id,
                           isTupleCon,                     
                           getIdArity
                        )
@@ -52,19 +34,11 @@ import Name             ( occNameString,
                           getOccName,
                           getOccString
                         )
-import Outputable      ( PprStyle(..),
-                          Outputable(..)
+import Type            ( Type, 
+                          isUnboxedType, 
+                          splitTyConApp_maybe
                        )
-import PprType         ( GenType{-instance-}, 
-                          GenTyVar{-ditto-} 
-                        )        
-import Pretty          
-import Type            ( isPrimType, 
-                          eqTy, 
-                          SYN_IE(Type), 
-                          getAppTyCon
-                       )
-import TyVar           ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
+import TyVar           ( TyVar )
 import TysPrim         ( intPrimTy, 
                           charPrimTy, 
                           floatPrimTy, 
@@ -84,11 +58,10 @@ import TysWiredIn   ( nilDataCon, consDataCon,
                        )
 import TyCon            ( tyConDataCons )
 import UniqSet
-import Unique          ( Unique{-instance Eq-} )
-import Util            ( pprTrace, 
-                          panic, 
-                          pprPanic 
-                        )
+import Unique          ( Unique )
+import Outputable
+
+#include "HsVersions.h"
 \end{code}
 
 This module perfoms checks about if one list of equations are:
@@ -133,14 +106,14 @@ Pretty Printer are not friends.
  
 \begin{code}
 
-data BoxedString = BS String
+newtype BoxedString = BS String
 
 type WarningPat = InPat BoxedString --Name --String 
 type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
 
 
 instance Outputable BoxedString where
-    ppr sty (BS s) = text s
+    ppr (BS s) = text s
 
 
 check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
@@ -390,7 +363,7 @@ get_unused_cons :: [TypecheckedPat] -> [Id]
 get_unused_cons used_cons = unused_cons
      where
        (ConPat _ ty _) = head used_cons
-       (ty_con,_)      = getAppTyCon ty
+       Just (ty_con,_) = splitTyConApp_maybe ty
        all_cons        = tyConDataCons ty_con
        used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons
        unused_cons     = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
@@ -529,13 +502,14 @@ constraints.
 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 simplify_eqns []                               = []
 simplify_eqns ((EqnInfo n ctx pats result):qs) = 
-    (EqnInfo n ctx(map simplify_pat pats) result) : 
-    simplify_eqns qs
+ (EqnInfo n ctx pats' result) : simplify_eqns qs
+ where
+  pats' = map simplify_pat pats
 
 simplify_pat :: TypecheckedPat -> TypecheckedPat  
-simplify_pat (WildPat gt ) = WildPat gt        
 
-simplify_pat (VarPat id)   = WildPat (idType id) 
+simplify_pat pat@(WildPat gt) = pat
+simplify_pat (VarPat id)      = WildPat (idType id) 
 
 simplify_pat (LazyPat p)   = simplify_pat p
 
@@ -562,32 +536,39 @@ simplify_pat (RecPat id ty idps) = ConPat id ty pats
                                    pats = map (\ (id,p,_)-> simplify_pat p) idps
 
 simplify_pat pat@(LitPat lit lit_ty) 
-  | isPrimType lit_ty = LitPat lit lit_ty
+  | isUnboxedType lit_ty = pat
 
-  | lit_ty `eqTy` charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
+  | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
 
-  | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
+  | otherwise = pprPanic "tidy1:LitPat:" (ppr pat)
   where
     mk_char (HsChar c)    = HsCharPrim c
 
 simplify_pat (NPat lit lit_ty hsexpr) = better_pat
   where
     better_pat
-      | lit_ty `eqTy` charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
-      | lit_ty `eqTy` intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
-      | lit_ty `eqTy` wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
-      | 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]
+      | lit_ty == charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
+      | lit_ty == intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
+      | lit_ty == wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
+      | lit_ty == addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
+      | lit_ty == floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
+      | lit_ty == 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 [] 
+      | null_str_lit lit      = ConPat nilDataCon    lit_ty []
+      | one_str_lit lit       = ConPat consDataCon list_ty 
+                                   [ ConPat charDataCon   lit_ty [LitPat (mk_head_char lit) charPrimTy]
+                                  , ConPat nilDataCon    lit_ty []]
 
       | otherwise             = NPat lit lit_ty hsexpr
 
+    list_ty = mkListTy lit_ty
+
     mk_int    (HsInt i)      = HsIntPrim i
     mk_int    l@(HsLitLit s) = l
 
+    mk_head_char   (HsString s) = HsCharPrim (_HEAD_ s)
+
     mk_char   (HsChar c)     = HsCharPrim c
     mk_char   l@(HsLitLit s) = l
 
@@ -606,6 +587,9 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat
     null_str_lit (HsString s) = _NULL_ s
     null_str_lit other_lit    = False
 
+    one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
+    one_str_lit other_lit    = False
+
 simplify_pat (NPlusKPat        id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2 
      WildPat ty
    where ty = panic "Check.simplify_pat: Never used"