[project @ 2001-10-23 14:46:25 by rrt]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 2ed45be..e3a7fc3 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -15,22 +15,21 @@ import TcHsSyn              ( TcPat, TcId )
 import TcMonad
 import Inst            ( InstOrigin(..),
                          emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId,
-                         newMethod, newOverloadedLit, newDicts, newClassDicts
+                         newMethod, newOverloadedLit, newDicts
                        )
-import Id              ( mkVanillaId )
+import Id              ( mkLocalId )
 import Name            ( Name )
 import FieldLabel      ( fieldLabelName )
-import TcEnv           ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId )
-import TcType          ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
-import TcMonoType      ( tcHsSigType )
-import TcUnify                 ( unifyTauTy, unifyListTy, unifyTupleTy )
+import TcEnv           ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
+import TcMType                 ( tcInstTyVars, newTyVarTy, unifyTauTy, unifyListTy, unifyTupleTy )
+import TcType          ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind )
+import TcMonoType      ( tcHsSigType, UserTypeCtxt(..) )
 
 import CmdLineOpts     ( opt_IrrefutableTuples )
 import DataCon         ( dataConSig, dataConFieldLabels, 
                          dataConSourceArity
                        )
-import Type            ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind )
-import Subst           ( substTy, substClasses )
+import Subst           ( substTy, substTheta )
 import TysPrim         ( charPrimTy, intPrimTy, floatPrimTy,
                          doublePrimTy, addrPrimTy
                        )
@@ -52,7 +51,7 @@ import Outputable
 -- This is the right function to pass to tcPat when 
 -- we're looking at a lambda-bound pattern, 
 -- so there's no polymorphic guy to worry about
-tcMonoPatBndr binder_name pat_ty = returnTc (mkVanillaId binder_name pat_ty)
+tcMonoPatBndr binder_name pat_ty = returnTc (mkLocalId binder_name pat_ty)
 \end{code}
 
 
@@ -121,7 +120,7 @@ tcPat tc_bndr (ParPatIn parend_pat) pat_ty
   = tcPat tc_bndr parend_pat pat_ty
 
 tcPat tc_bndr (SigPatIn pat sig) pat_ty
-  = tcHsSigType sig                                    `thenTc` \ sig_ty ->
+  = tcHsSigType PatSigCtxt sig                         `thenTc` \ sig_ty ->
 
        -- Check that the signature isn't a polymorphic one, which
        -- we don't permit (at present, anyway)
@@ -285,7 +284,7 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
   where
     origin = PatOrigin pat
     lit' = case over_lit of
-               HsIntegral i   _ -> HsInteger i
+               HsIntegral i _   -> HsInteger i
                HsFractional f _ -> HsRat f pat_ty
 \end{code}
 
@@ -296,9 +295,10 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty
 %************************************************************************
 
 \begin{code}
-tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty
+tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty
   = tc_bndr name pat_ty                                `thenTc` \ bndr_id ->
-    tcLookupGlobalId minus                     `thenNF_Tc` \ minus_sel_id ->
+       -- The '-' part is re-mappable syntax
+    tcLookupId minus_name                      `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` \ ge ->
@@ -371,14 +371,14 @@ tcConstructor pat con_name pat_ty
     in
     tcInstTyVars (ex_tvs ++ tvs)       `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
     let
-       ex_theta' = substClasses tenv ex_theta
+       ex_theta' = substTheta 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
-    newClassDicts (PatOrigin pat) ex_theta'    `thenNF_Tc` \ dicts ->
+    newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
 
        -- Check overall type matches
     unifyTauTy pat_ty result_ty                `thenTc_`