[project @ 2003-12-10 14:15:16 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 54c4eee..5b760ac 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -10,8 +10,10 @@ module TcEnv(
        -- Global environment
        tcExtendGlobalEnv, 
        tcExtendGlobalValEnv,
-       tcLookupGlobal, 
+       tcLookupLocatedGlobal,  tcLookupGlobal, 
        tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+       tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
+       tcLookupLocatedClass, tcLookupLocatedDataCon,
        
        getInGlobalScope,
 
@@ -19,7 +21,7 @@ module TcEnv(
        tcExtendTyVarKindEnv,
        tcExtendTyVarEnv,    tcExtendTyVarEnv2, 
        tcExtendLocalValEnv, tcExtendLocalValEnv2, 
-       tcLookup, tcLookupLocalIds,
+       tcLookup, tcLookupLocated, tcLookupLocalIds,
        tcLookupId, tcLookupTyVar,
        lclEnvElts, getInLocalScope, findGlobals, 
 
@@ -44,8 +46,8 @@ module TcEnv(
 
 #include "HsVersions.h"
 
-import RnHsSyn         ( RenamedMonoBinds, RenamedSig )
-import HsSyn           ( RuleDecl(..), , HsTyVarBndr(..) )
+import HsSyn           ( LRuleDecl, , HsTyVarBndr(..), LHsTyVarBndr, LHsBinds,
+                         LSig )
 import TcIface         ( tcImportDecl )
 import TcRnMonad
 import TcMType         ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
@@ -59,19 +61,18 @@ import Id           ( idName, isLocalId )
 import Var             ( TyVar, Id, mkTyVar, idType )
 import VarSet
 import VarEnv
+import RdrName         ( extendLocalRdrEnv )
 import DataCon         ( DataCon )
 import TyCon           ( TyCon )
 import Class           ( Class )
-import Name            ( Name, NamedThing(..), 
-                         getSrcLoc, mkInternalName, nameIsLocalOrFrom
-                       )
+import Name            ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom )
 import NameEnv
 import OccName         ( mkDFunOcc, occNameString )
 import HscTypes                ( DFunId, extendTypeEnvList, lookupType,
                          TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon,
                          ExternalPackageState(..) )
 
-import SrcLoc          ( SrcLoc )
+import SrcLoc          ( SrcLoc, Located(..) )
 import Outputable
 import Maybe           ( isJust )
 \end{code}
@@ -83,9 +84,17 @@ import Maybe         ( isJust )
 %*                                                                     *
 %************************************************************************
 
+Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
+unless you know that the SrcSpan in the monad is already set to the
+span of the Name.
+
 \begin{code}
-tcLookupGlobal :: Name -> TcM TyThing
+tcLookupLocatedGlobal :: Located Name -> TcM TyThing
 -- c.f. IfaceEnvEnv.tcIfaceGlobal
+tcLookupLocatedGlobal name
+  = addLocM tcLookupGlobal name
+
+tcLookupGlobal :: Name -> TcM TyThing
 tcLookupGlobal name
   = do { env <- getGblEnv
        ; if nameIsLocalOrFrom (tcg_mod env) name
@@ -119,13 +128,25 @@ tcLookupDataCon con_name
 
 tcLookupClass :: Name -> TcM Class
 tcLookupClass name
-  = tcLookupGlobal name        `thenM` \ thing ->
+  = tcLookupGlobal name                `thenM` \ thing ->
     return (tyThingClass thing)
        
 tcLookupTyCon :: Name -> TcM TyCon
 tcLookupTyCon name
-  = tcLookupGlobal name        `thenM` \ thing ->
+  = tcLookupGlobal name                `thenM` \ thing ->
     return (tyThingTyCon thing)
+
+tcLookupLocatedGlobalId :: Located Name -> TcM Id
+tcLookupLocatedGlobalId = addLocM tcLookupId
+
+tcLookupLocatedDataCon :: Located Name -> TcM DataCon
+tcLookupLocatedDataCon = addLocM tcLookupDataCon
+
+tcLookupLocatedClass :: Located Name -> TcM Class
+tcLookupLocatedClass = addLocM tcLookupClass
+
+tcLookupLocatedTyCon :: Located Name -> TcM TyCon
+tcLookupLocatedTyCon = addLocM tcLookupTyCon
 \end{code}
 
 %************************************************************************
@@ -187,6 +208,9 @@ tcExtendRecEnv gbl_stuff lcl_stuff thing_inside
 %************************************************************************
 
 \begin{code}
+tcLookupLocated :: Located Name -> TcM TcTyThing
+tcLookupLocated = addLocM tcLookup
+
 tcLookup :: Name -> TcM TcTyThing
 tcLookup name
   = getLclEnv          `thenM` \ local_env ->
@@ -237,14 +261,14 @@ getInLocalScope = getLclEnv       `thenM` \ env ->
 \end{code}
 
 \begin{code}
-tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r
+tcExtendTyVarKindEnv :: [LHsTyVarBndr Name] -> TcM r -> TcM r
 -- The tyvars are all kinded
 tcExtendTyVarKindEnv tvs thing_inside
   = updLclEnv upd thing_inside
   where
     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
     extend env  = extendNameEnvList env [(n, ATyVar (mkTyVar n k)) 
-                                       | KindedTyVar n k <- tvs]
+                                       | L _ (KindedTyVar n k) <- tvs]
        -- No need to extend global tyvars for kind checking
 
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
@@ -258,9 +282,12 @@ tcExtendTyVarEnv2 tv_pairs thing_inside
                     thing_inside
 
 tc_extend_tv_env binds tyvars thing_inside
-  = getLclEnv     `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
+  = getLclEnv     `thenM` \ env@(TcLclEnv {tcl_env = le, 
+                                           tcl_tyvars = gtvs, 
+                                           tcl_rdr = rdr_env}) ->
     let
        le'        = extendNameEnvList le binds
+       rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
        new_tv_set = mkVarSet tyvars
     in
        -- It's important to add the in-scope tyvars to the global tyvar set
@@ -270,7 +297,7 @@ tc_extend_tv_env binds tyvars thing_inside
        -- class and instance decls, when we mustn't generalise the class tyvars
        -- when typechecking the methods.
     tc_extend_gtvs gtvs new_tv_set             `thenM` \ gtvs' ->
-    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
+    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
 \end{code}
 
 
@@ -284,9 +311,10 @@ tcExtendLocalValEnv ids thing_inside
        proc_lvl            = proc_level (tcl_arrow_ctxt env)
        extra_env           = [(idName id, ATcId id th_lvl proc_lvl) | id <- ids]
        le'                 = extendNameEnvList (tcl_env env) extra_env
+       rdr_env'            = extendLocalRdrEnv (tcl_rdr env) (map idName ids)
     in
     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars        `thenM` \ gtvs' ->
-    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
+    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
 
 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 tcExtendLocalValEnv2 names_w_ids thing_inside
@@ -297,9 +325,10 @@ tcExtendLocalValEnv2 names_w_ids thing_inside
        proc_lvl            = proc_level (tcl_arrow_ctxt env)
        extra_env           = [(name, ATcId id th_lvl proc_lvl) | (name,id) <- names_w_ids]
        le'                 = extendNameEnvList (tcl_env env) extra_env
+       rdr_env'            = extendLocalRdrEnv (tcl_rdr env) (map fst names_w_ids)
     in
     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars        `thenM` \ gtvs' ->
-    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
+    setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
 \end{code}
 
 
@@ -394,7 +423,7 @@ tcGetGlobalTyVars
 %************************************************************************
 
 \begin{code}
-tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
+tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
        -- Just pop the new rules into the EPS and envt resp
        -- All the rules come from an interface file, not soruce
        -- Nevertheless, some may be for this module, if we read
@@ -560,8 +589,8 @@ data InstInfo
 
 data InstBindings
   = VanillaInst                -- The normal case
-       RenamedMonoBinds        -- Bindings
-       [RenamedSig]            -- User pragmas recorded for generating 
+       (LHsBinds Name)         -- Bindings
+       [LSig Name]             -- User pragmas recorded for generating 
                                -- specialised instances
 
   | NewTypeDerived             -- Used for deriving instances of newtypes, where the