[project @ 2000-08-17 16:28:44 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcPat.lhs

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 88914ac..e5b8847 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -8,8 +8,6 @@ module TcPat ( tcPat, tcPatBndr_NoSigs, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}  TcExpr( tcExpr )
-
 import HsSyn           ( InPat(..), OutPat(..), HsLit(..), HsExpr(..), Sig(..) )
 import RnHsSyn         ( RenamedPat )
 import TcHsSyn         ( TcPat, TcId )
@@ -26,11 +24,8 @@ import TcEnv         ( tcLookupValue, tcLookupClassByKey,
                        )
 import TcType          ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
 import TcMonoType      ( tcHsSigType )
-import TcUnify                 ( unifyTauTy, unifyListTy,
-                         unifyTupleTy, unifyUnboxedTupleTy
-                       )
+import TcUnify                 ( unifyTauTy, unifyListTy, unifyTupleTy )
 
-import Bag             ( Bag )
 import CmdLineOpts     ( opt_IrrefutableTuples )
 import DataCon         ( DataCon, dataConSig, dataConFieldLabels, 
                          dataConSourceArity
@@ -42,10 +37,10 @@ import TysPrim              ( charPrimTy, intPrimTy, floatPrimTy,
                          doublePrimTy, addrPrimTy
                        )
 import TysWiredIn      ( charTy, stringTy, intTy )
-import SrcLoc          ( SrcLoc )
 import Unique          ( eqClassOpKey, geClassOpKey, minusClassOpKey,
                          cCallableClassKey
                        )
+import BasicTypes      ( isBoxed )
 import Bag
 import Util            ( zipEqual )
 import Outputable
@@ -165,18 +160,15 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
     tcPats tc_bndr pats (repeat elem_ty)       `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
     returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
 
-tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty
+tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
   = tcAddErrCtxt (patCtxt pat_in)      $
 
-    (if boxed
-     then unifyTupleTy        arity pat_ty
-     else unifyUnboxedTupleTy arity pat_ty)    `thenTc` \ arg_tys ->
-
-    tcPats tc_bndr pats arg_tys                        `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+    unifyTupleTy boxity arity pat_ty           `thenTc` \ arg_tys ->
+    tcPats tc_bndr pats arg_tys                `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
 
        -- possibly do the "make all tuple-pats irrefutable" test:
     let
-       unmangled_result = TuplePat pats' boxed
+       unmangled_result = TuplePat pats' boxity
 
        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
        -- so that we can experiment with lazy tuple-matching.
@@ -184,8 +176,8 @@ tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty
        -- it was easy to do.
 
        possibly_mangled_result
-         | opt_IrrefutableTuples && boxed = LazyPat unmangled_result
-         | otherwise                      = unmangled_result
+         | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result
+         | otherwise                               = unmangled_result
     in
     returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail)
   where
@@ -221,9 +213,11 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
        -- Check the constructor itself
     tcConstructor pat name pat_ty      `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
     let
-       field_tys = zipEqual "tcPat" 
-                            (map fieldLabelName (dataConFieldLabels data_con))
-                            arg_tys
+       -- not zipEqual: if the constructor isn't really a record, then
+       -- dataConFieldLabels will be empty (and each field in the pattern
+       -- will generate an error below).
+       field_tys = zip (map fieldLabelName (dataConFieldLabels data_con))
+                       arg_tys
     in
 
        -- Check the fields
@@ -400,7 +394,7 @@ tcConstructor pat con_name pat_ty
 
        -- Instantiate it
     let 
-       (tvs, theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
+       (tvs, _, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
             -- Ignore the theta; overloaded constructors only
             -- behave differently when called, not when used for
             -- matching.
@@ -475,7 +469,7 @@ badFieldCon con field
 
 polyPatSig :: TcType -> SDoc
 polyPatSig sig_ty
-  = hang (ptext SLIT("Polymorphic type signature in pattern"))
+  = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
         4 (ppr sig_ty)
 \end{code}