[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 a708509..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 )
@@ -17,8 +15,7 @@ import TcHsSyn                ( TcPat, TcId )
 import TcMonad
 import Inst            ( Inst, OverloadedLit(..), InstOrigin(..),
                          emptyLIE, plusLIE, LIE,
-                         newMethod, newOverloadedLit, 
-                         newDicts, instToIdBndr
+                         newMethod, newOverloadedLit, newDicts, newClassDicts
                        )
 import Name            ( Name, getOccName, getSrcLoc )
 import FieldLabel      ( fieldLabelName )
@@ -26,27 +23,24 @@ import TcEnv                ( tcLookupValue, tcLookupClassByKey,
                          tcLookupValueByKey, newLocalId, badCon
                        )
 import TcType          ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
-import TcMonoType      ( tcHsType )
-import TcUnify                 ( unifyTauTy, unifyListTy,
-                         unifyTupleTy, unifyUnboxedTupleTy
-                       )
+import TcMonoType      ( tcHsSigType )
+import TcUnify                 ( unifyTauTy, unifyListTy, unifyTupleTy )
 
-import Bag             ( Bag )
 import CmdLineOpts     ( opt_IrrefutableTuples )
 import DataCon         ( DataCon, dataConSig, dataConFieldLabels, 
                          dataConSourceArity
                        )
-import Id              ( Id, idType, isDataConId_maybe )
-import Type            ( Type, isTauTy, mkTyConApp, boxedTypeKind )
-import Subst           ( substTy, substTheta )
+import Id              ( Id, idType, isDataConWrapId_maybe )
+import Type            ( Type, isTauTy, mkTyConApp, mkClassPred, boxedTypeKind )
+import Subst           ( substTy, substClasses )
 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
@@ -143,7 +137,7 @@ tcPat tc_bndr (ParPatIn parend_pat) pat_ty
   = tcPat tc_bndr parend_pat pat_ty
 
 tcPat tc_bndr (SigPatIn pat sig) pat_ty
-  = tcHsType sig                                       `thenTc` \ sig_ty ->
+  = tcHsSigType sig                                    `thenTc` \ sig_ty ->
 
        -- Check that the signature isn't a polymorphic one, which
        -- we don't permit (at present, anyway)
@@ -166,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.
@@ -185,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
@@ -222,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
@@ -291,7 +284,7 @@ tcPat tc_bndr (LitPatIn lit@(HsLitLit s))     pat_ty
        -- cf tcExpr on LitLits
   = tcLookupClassByKey cCallableClassKey               `thenNF_Tc` \ cCallableClass ->
     newDicts (LitLitOrigin (_UNPK_ s))
-            [(cCallableClass, [pat_ty])]               `thenNF_Tc` \ (dicts, _) ->
+            [mkClassPred cCallableClass [pat_ty]]      `thenNF_Tc` \ (dicts, _) ->
     returnTc (LitPat lit pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
 \end{code}
 
@@ -395,27 +388,27 @@ tcOverloadedLitPat pat lit over_lit pat_ty
 tcConstructor pat con_name pat_ty
   =    -- Check that it's a constructor
     tcLookupValue con_name             `thenNF_Tc` \ con_id ->
-    case isDataConId_maybe con_id of {
+    case isDataConWrapId_maybe con_id of {
        Nothing -> failWithTc (badCon con_id);
        Just data_con ->
 
        -- 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.
     in
     tcInstTyVars (ex_tvs ++ tvs)       `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
     let
-       ex_theta' = substTheta tenv ex_theta
+       ex_theta' = substClasses tenv ex_theta
        arg_tys'  = map (substTy tenv) arg_tys
 
        n_ex_tvs  = length ex_tvs
        ex_tvs'   = take n_ex_tvs all_tvs'
        result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
     in
-    newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ (lie_avail, dicts) ->
+    newClassDicts (PatOrigin pat) ex_theta'    `thenNF_Tc` \ (lie_avail, dicts) ->
 
        -- Check overall type matches
     unifyTauTy pat_ty result_ty                `thenTc_`
@@ -476,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}