[project @ 2001-11-26 09:20:25 by simonpj]

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

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index dd4c9ae..17e0e52 100644 (file)
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -11,8 +11,8 @@ module Check ( check , ExhaustivePat ) where
 
 
 import HsSyn           
-import TcHsSyn         ( TypecheckedPat )
-import DsHsSyn         ( outPatType ) 
+import TcHsSyn         ( TypecheckedPat, outPatType )
+import TcType          ( tcTyConAppTyCon, tcTyConAppArgs )
 import DsUtils         ( EquationInfo(..), MatchResult(..), EqnSet, 
                          CanItFail(..),  tidyLitPat, tidyNPat, 
                        )
@@ -20,7 +20,7 @@ import Id             ( idType )
 import DataCon         ( DataCon, dataConTyCon, dataConArgTys,
                          dataConSourceArity, dataConFieldLabels )
 import Name             ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc )
-import Type            ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
+import TcType          ( mkTyVarTys )
 import TysPrim         ( charPrimTy )
 import TysWiredIn
 import PrelNames       ( unboundKey )
@@ -28,6 +28,7 @@ import TyCon            ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( noSrcLoc )
 import UniqSet
+import Util             ( takeList, splitAtList )
 import Outputable
 
 #include "HsVersions.h"
@@ -187,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 check' []                                              = ([([],[])],emptyUniqSet)
 
 check' [EqnInfo n ctx ps (MatchResult CanFail _)] 
-   | all_vars ps  = ([(take (length ps) (repeat new_wild_pat),[])],  unitUniqSet n)
+   | all_vars ps  = ([(takeList ps (repeat new_wild_pat),[])],  unitUniqSet n)
 
 check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
    | all_vars ps  = (pats,  addOneToUniqSet indexs n)
@@ -244,8 +245,8 @@ must be one Variable to be complete.
 
 process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 process_literals used_lits qs 
-  | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
-  | otherwise                = (pats_default,indexs_default)
+  | null default_eqns  = ([make_row_vars used_lits (head qs)]++pats,indexs)
+  | otherwise          = (pats_default,indexs_default)
      where
        (pats,indexs)   = process_explicit_literals used_lits qs
        default_eqns    = (map remove_var (filter is_var qs))
@@ -283,8 +284,9 @@ same constructor.
 
 split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
 
-split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs 
-                        | otherwise               = no_need_default_case used_cons qs 
+split_by_constructor qs 
+  | not (null unused_cons) = need_default_case used_cons unused_cons qs 
+  | otherwise              = no_need_default_case used_cons qs 
                        where 
                           used_cons   = get_used_cons qs 
                           unused_cons = get_unused_cons used_cons 
@@ -319,8 +321,8 @@ no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
 
 need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 need_default_case used_cons unused_cons qs 
-  | length default_eqns == 0 = (pats_default_no_eqns,indexs)
-  | otherwise                = (pats_default,indexs_default)
+  | null default_eqns  = (pats_default_no_eqns,indexs)
+  | otherwise          = (pats_default,indexs_default)
      where
        (pats,indexs)   = no_need_default_case used_cons qs
        default_eqns    = (map remove_var (filter is_var qs))
@@ -368,7 +370,7 @@ remove_first_column (ConPat con _ _ _ con_pats) qs =
 
 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
 make_row_vars used_lits (EqnInfo _ _ pats _ ) = 
-   (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
+   (VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
   where new_var = hash_x
 
 hash_x = mkLocalName unboundKey {- doesn't matter much -}
@@ -376,7 +378,7 @@ hash_x = mkLocalName unboundKey {- doesn't matter much -}
                     noSrcLoc
 
 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
-make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
+make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat)
 
 compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
 compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2  
@@ -413,17 +415,12 @@ get_unused_cons :: [TypecheckedPat] -> [DataCon]
 get_unused_cons used_cons = unused_cons
      where
        (ConPat _ ty _ _ _) = head used_cons
-       Just (ty_con,_)            = sTyConApp_maybe used_cons ty
+       ty_con             = tcTyConAppTyCon ty         -- Newtype observable
        all_cons                   = tyConDataCons ty_con
        used_cons_as_id            = map (\ (ConPat d _ _ _ _) -> d) used_cons
        unused_cons                = uniqSetToList
                 (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 
 
-sTyConApp_maybe used_cons ty =
-    case splitTyConApp_maybe ty of
-    Just x -> Just x
-    Nothing -> pprTrace "splitTyConApp_maybe" (ppr (used_cons, ty)) $ Nothing
-
 all_vars :: [TypecheckedPat] -> Bool
 all_vars []              = True
 all_vars (WildPat _:ps)  = all_vars ps
@@ -529,10 +526,8 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
 make_con (ConPat id _ _ _ pats) (ps,constraints) 
       | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) 
       | otherwise       = (ConPatIn name pats_con                   : rest_pats, constraints)
-    where num_args  = length pats
-          name      = getName id
-          pats_con  = take num_args ps
-          rest_pats = drop num_args ps
+    where name      = getName id
+         (pats_con, rest_pats) = splitAtList pats ps
          tc        = dataConTyCon id
          
 
@@ -543,7 +538,7 @@ make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wi
                   fixity = panic "Check.make_whole_con: Guessing fixity"
                   name   = getName con
                   arity  = dataConSourceArity con 
-                  pats   = take arity (repeat new_wild_pat)
+                  pats   = replicate arity new_wild_pat
 
 
 new_wild_pat :: WarningPat
@@ -569,8 +564,9 @@ simplify_pat :: TypecheckedPat -> TypecheckedPat
 simplify_pat pat@(WildPat gt) = pat
 simplify_pat (VarPat id)      = WildPat (idType id) 
 
-simplify_pat (LazyPat p)    = simplify_pat p
-simplify_pat (AsPat id p)   = simplify_pat p
+simplify_pat (LazyPat p)      = simplify_pat p
+simplify_pat (AsPat id p)     = simplify_pat p
+simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right
 
 simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)
 
@@ -592,9 +588,9 @@ simplify_pat (RecPat dc ty ex_tvs dicts [])
   where
     all_wild_pats = map WildPat con_arg_tys
 
-      -- identical to machinations in Match.tidy1:
-    (_, inst_tys, _) = splitAlgTyConApp ty
-    con_arg_tys      = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
+      -- Identical to machinations in Match.tidy1:
+    inst_tys    = tcTyConAppArgs ty    -- Newtype is observable
+    con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)
 
 simplify_pat (RecPat dc ty ex_tvs dicts idps) 
   = ConPat dc ty ex_tvs dicts pats
@@ -640,5 +636,4 @@ simplify_pat (DictPat dicts methods) =
     where
        num_of_d_and_ms  = length dicts + length methods
        dict_and_method_pats = map VarPat (dicts ++ methods)
-
 \end{code}