[project @ 2000-09-28 13:04:14 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 821332a..a86a832 100644 (file)
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -13,28 +13,20 @@ module Check ( check , ExhaustivePat ) where
 import HsSyn           
 import TcHsSyn         ( TypecheckedPat )
 import DsHsSyn         ( outPatType ) 
-import CoreSyn         
-
-import DsUtils         ( EquationInfo(..),
-                         MatchResult(..),
-                         EqnSet,
-                         CanItFail(..),
+import DsUtils         ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..),
                          tidyLitPat
                        )
 import Id              ( idType )
-import DataCon         ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys,
+import DataCon         ( DataCon, dataConTyCon, dataConArgTys,
                          dataConSourceArity, dataConFieldLabels )
 import Name             ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc )
-import Type            ( Type, splitAlgTyConApp, mkTyVarTys,
-                          isUnboxedType, splitTyConApp_maybe
-                       )
+import Type            ( splitAlgTyConApp, mkTyVarTys, splitTyConApp_maybe )
 import TysWiredIn      ( nilDataCon, consDataCon, 
-                          mkListTy, 
-                          mkTupleTy, tupleCon,
-                         mkUnboxedTupleTy, unboxedTupleCon
+                          mkListTy, mkTupleTy, tupleCon
                        )
-import Unique          ( unboundKey )
-import TyCon            ( tyConDataCons )
+import PrelNames       ( unboundKey )
+import TyCon            ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( noSrcLoc )
 import UniqSet
 import Outputable
@@ -152,13 +144,7 @@ untidy b (ConOpPatIn pat1 name fixity pat2) =
 untidy _ (ListPatIn pats)  = ListPatIn (map untidy_no_pars pats) 
 untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed
 
-untidy _ (SigPatIn pat ty)      = panic "Check.untidy: SigPatIn"
-untidy _ (LazyPatIn pat)        = panic "Check.untidy: LazyPatIn"
-untidy _ (AsPatIn name pat)     = panic "Check.untidy: AsPatIn"
-untidy _ (NPlusKPatIn name lit) = panic "Check.untidy: NPlusKPatIn"
-untidy _ (NegPatIn ipat)        = panic "Check.untidy: NegPatIn"
-untidy _ (ParPatIn pat)         = panic "Check.untidy: ParPatIn"
-untidy _ (RecPatIn name fields) = panic "Check.untidy: RecPatIn"
+untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat)
 
 pars :: NeedPars -> WarningPat -> WarningPat
 pars True p = ParPatIn p
@@ -538,13 +524,13 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
           fixity = panic "Check.make_con: Guessing fixity"
 
 make_con (ConPat id _ _ _ pats) (ps,constraints) 
-      | isTupleCon id        = (TuplePatIn pats_con True : rest_pats,    constraints) 
-      | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints)
-      | otherwise     = (ConPatIn name pats_con : rest_pats, 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
+         tc        = dataConTyCon id
          
 
 make_whole_con :: DataCon -> WarningPat
@@ -591,15 +577,9 @@ simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty []
                              where list_ty = mkListTy ty
 
 
-simplify_pat (TuplePat ps True) = ConPat (tupleCon arity)
-                                   (mkTupleTy arity (map outPatType ps)) [] []
-                                   (map simplify_pat ps)
-                           where
-                              arity = length ps
-
-simplify_pat (TuplePat ps False) 
-  = ConPat (unboxedTupleCon arity)
-          (mkUnboxedTupleTy arity (map outPatType ps)) [] []
+simplify_pat (TuplePat ps boxity)
+  = ConPat (tupleCon boxity arity)
+          (mkTupleTy boxity arity (map outPatType ps)) [] []
           (map simplify_pat ps)
   where
     arity = length ps
@@ -632,8 +612,8 @@ simplify_pat (RecPat dc ty ex_tvs dicts idps)
       | nm == n    = (nm,p):xs
       | otherwise  = x : insertNm nm p xs
 
-simplify_pat pat@(LitPat lit lit_ty)        = tidyLitPat lit lit_ty pat
-simplify_pat pat@(NPat   lit lit_ty hsexpr) = tidyLitPat lit lit_ty pat
+simplify_pat pat@(LitPat lit lit_ty)        = tidyLitPat lit pat
+simplify_pat pat@(NPat   lit lit_ty hsexpr) = tidyLitPat lit pat
 
 simplify_pat (NPlusKPat        id hslit ty hsexpr1 hsexpr2) = 
      WildPat ty
@@ -641,9 +621,9 @@ simplify_pat (NPlusKPat     id hslit ty hsexpr1 hsexpr2) =
 
 simplify_pat (DictPat dicts methods) = 
     case num_of_d_and_ms of
-       0 -> simplify_pat (TuplePat [] True) 
+       0 -> simplify_pat (TuplePat [] Boxed) 
        1 -> simplify_pat (head dict_and_method_pats) 
-       _ -> simplify_pat (TuplePat dict_and_method_pats True)
+       _ -> simplify_pat (TuplePat dict_and_method_pats Boxed)
     where
        num_of_d_and_ms  = length dicts + length methods
        dict_and_method_pats = map VarPat (dicts ++ methods)