[project @ 2000-10-17 09:33:41 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 3ffa6c9..1c9a169 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -19,9 +19,7 @@ import Inst           ( InstOrigin(..),
                        )
 import Name            ( Name, getOccName, getSrcLoc )
 import FieldLabel      ( fieldLabelName )
-import TcEnv           ( tcLookupValue, tcLookupClassByKey,
-                         tcLookupValueByKey, newLocalId, badCon
-                       )
+import TcEnv           ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, newLocalId )
 import TcType          ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
 import TcMonoType      ( tcHsSigType )
 import TcUnify                 ( unifyTauTy, unifyListTy, unifyTupleTy )
@@ -37,9 +35,7 @@ import TysPrim                ( charPrimTy, intPrimTy, floatPrimTy,
                          doublePrimTy, addrPrimTy
                        )
 import TysWiredIn      ( charTy, stringTy, intTy, integerTy )
-import Unique          ( eqClassOpKey, geClassOpKey, 
-                         cCallableClassKey, eqStringIdKey,
-                       )
+import PrelNames       ( eqStringName, eqName, geName, cCallableClassName )
 import BasicTypes      ( isBoxed )
 import Bag
 import Outputable
@@ -71,7 +67,7 @@ tcPatBndr_NoSigs binder_name pat_ty
 %************************************************************************
 
 \begin{code}
-tcPat :: (Name -> TcType -> TcM s TcId)        -- How to construct a suitable (monomorphic)
+tcPat :: (Name -> TcType -> TcM TcId)  -- How to construct a suitable (monomorphic)
                                        -- Id for variables found in the pattern
                                        -- The TcType is the expected type, see note below
       -> RenamedPat
@@ -82,7 +78,7 @@ tcPat :: (Name -> TcType -> TcM s TcId)       -- How to construct a suitable (monomorp
                        --      INVARIANT: if it is, the foralls will always be visible,
                        --      not hidden inside a mutable type variable
 
-      -> TcM s (TcPat, 
+      -> TcM (TcPat, 
                LIE,                    -- Required by n+k and literal pats
                Bag TcTyVar,    -- TyVars bound by the pattern
                                        --      These are just the existentially-bound ones.
@@ -104,6 +100,9 @@ tcPat :: (Name -> TcType -> TcM s TcId)     -- How to construct a suitable (monomorp
 %************************************************************************
 
 \begin{code}
+tcPat tc_bndr pat@(TypePatIn ty) pat_ty
+  = failWithTc (badTypePat pat)
+
 tcPat tc_bndr (VarPatIn name) pat_ty
   = tc_bndr name pat_ty                `thenTc` \ bndr_id ->
     returnTc (VarPat bndr_id, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
@@ -242,7 +241,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
                -- The normal case, when the field comes from the right constructor
           (pat_ty : extras) -> 
                ASSERT( null extras )
-               tcLookupValue field_label                       `thenNF_Tc` \ sel_id ->
+               tcLookupGlobalId field_label                    `thenNF_Tc` \ sel_id ->
                returnTc (sel_id, pat_ty)
        )                                                       `thenTc` \ (sel_id, pat_ty) ->
 
@@ -264,14 +263,14 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
 \begin{code}
 tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty 
        -- cf tcExpr on LitLits
-  = tcLookupClassByKey cCallableClassKey               `thenNF_Tc` \ cCallableClass ->
+  = tcLookupClass cCallableClassName           `thenNF_Tc` \ cCallableClass ->
     newDicts (LitLitOrigin (_UNPK_ s))
             [mkClassPred cCallableClass [pat_ty]]      `thenNF_Tc` \ (dicts, _) ->
     returnTc (LitPat (HsLitLit s pat_ty) pat_ty, dicts, emptyBag, emptyBag, emptyLIE)
 
 tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty
   = unifyTauTy pat_ty stringTy                 `thenTc_` 
-    tcLookupValueByKey eqStringIdKey           `thenNF_Tc` \ eq_id ->
+    tcLookupGlobalId eqStringName              `thenNF_Tc` \ eq_id ->
     returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), 
              emptyLIE, emptyBag, emptyBag, emptyLIE)
 
@@ -281,7 +280,7 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty
 
 tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
   = newOverloadedLit (PatOrigin pat) over_lit pat_ty   `thenNF_Tc` \ (over_lit_expr, lie1) ->
-    tcLookupValueByKey eqClassOpKey                    `thenNF_Tc` \ eq_sel_id ->
+    tcLookupGlobalId eqName                            `thenNF_Tc` \ eq_sel_id ->
     newMethod origin eq_sel_id [pat_ty]                        `thenNF_Tc` \ (lie2, eq_id) ->
 
     returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr),
@@ -303,8 +302,8 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
 \begin{code}
 tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty
   = tc_bndr name pat_ty                                `thenTc` \ bndr_id ->
-    tcLookupValue minus                                `thenNF_Tc` \ minus_sel_id ->
-    tcLookupValueByKey geClassOpKey            `thenNF_Tc` \ ge_sel_id ->
+    tcLookupGlobalId minus                     `thenNF_Tc` \ minus_sel_id ->
+    tcLookupGlobalId geName                    `thenNF_Tc` \ ge_sel_id ->
     newOverloadedLit origin lit pat_ty         `thenNF_Tc` \ (over_lit_expr, lie1) ->
     newMethod origin ge_sel_id    [pat_ty]     `thenNF_Tc` \ (lie2, ge_id) ->
     newMethod origin minus_sel_id [pat_ty]     `thenNF_Tc` \ (lie3, minus_id) ->
@@ -327,9 +326,9 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty
 Helper functions
 
 \begin{code}
-tcPats :: (Name -> TcType -> TcM s TcId)       -- How to deal with variables
+tcPats :: (Name -> TcType -> TcM TcId) -- How to deal with variables
        -> [RenamedPat] -> [TcType]             -- Excess 'expected types' discarded
-       -> TcM s ([TcPat], 
+       -> TcM ([TcPat], 
                 LIE,                           -- Required by n+k and literal pats
                 Bag TcTyVar,
                 Bag (Name, TcId),      -- Ids bound by the pattern
@@ -365,10 +364,7 @@ simpleHsLitTy (HsString str)   = stringTy
 \begin{code}
 tcConstructor pat con_name pat_ty
   =    -- Check that it's a constructor
-    tcLookupValue con_name             `thenNF_Tc` \ con_id ->
-    case isDataConWrapId_maybe con_id of {
-       Nothing -> failWithTc (badCon con_id);
-       Just data_con ->
+    tcLookupDataCon con_name           `thenNF_Tc` \ data_con ->
 
        -- Instantiate it
     let 
@@ -392,7 +388,6 @@ tcConstructor pat con_name pat_ty
     unifyTauTy pat_ty result_ty                `thenTc_`
 
     returnTc (data_con, ex_tvs', dicts, lie_avail, arg_tys')
-    }
 \end{code}           
 
 ------------------------------------------------------
@@ -441,5 +436,7 @@ polyPatSig :: TcType -> SDoc
 polyPatSig sig_ty
   = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
         4 (ppr sig_ty)
+
+badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
 \end{code}