X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=cf86e56718eebfe79ffc5b1ca3fa0d34bc8d9198;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=21fecddae5b704c34c7127c12a481f1772ac288c;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 21fecdd..cf86e56 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -10,18 +10,21 @@ module TcEnv(
 	-- Global environment
 	tcExtendGlobalEnv, 
 	tcExtendGlobalValEnv,
-	tcLookupGlobal, 
+	tcLookupLocatedGlobal,	tcLookupGlobal, 
 	tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+	tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
+	tcLookupLocatedClass, tcLookupLocatedDataCon,
 	
 	getInGlobalScope,
 
 	-- Local environment
-	tcExtendTyVarKindEnv,
+	tcExtendKindEnv,
 	tcExtendTyVarEnv,    tcExtendTyVarEnv2, 
 	tcExtendLocalValEnv, tcExtendLocalValEnv2, 
-	tcLookup, tcLookupLocalIds,
+	tcLookup, tcLookupLocated, tcLookupLocalIds,
 	tcLookupId, tcLookupTyVar,
 	lclEnvElts, getInLocalScope, findGlobals, 
+	wrongThingErr,
 
 	tcExtendRecEnv,    	-- For knot-tying
 
@@ -44,34 +47,32 @@ module TcEnv(
 
 #include "HsVersions.h"
 
-import RnHsSyn		( RenamedMonoBinds, RenamedSig )
-import HsSyn		( RuleDecl(..), , HsTyVarBndr(..) )
+import HsSyn		( LRuleDecl, LHsBinds, LSig )
 import TcIface		( tcImportDecl )
 import TcRnMonad
 import TcMType		( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
-import TcType		( Type, TcTyVar, TcTyVarSet, 
+import TcType		( Type, TcKind, TcTyVar, TcTyVarSet, 
 			  tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
 			  getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo, 
 			  tidyOpenType, tidyOpenTyVar
 			)
 import qualified Type	( getTyVar_maybe )
 import Id		( idName, isLocalId )
-import Var		( TyVar, Id, mkTyVar, idType )
+import Var		( TyVar, Id, 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,
+			  TyThing(..), tyThingId, 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,29 @@ tcLookupDataCon con_name
 
 tcLookupClass :: Name -> TcM Class
 tcLookupClass name
-  = tcLookupGlobal name	`thenM` \ thing ->
-    return (tyThingClass thing)
+  = tcLookupGlobal name		`thenM` \ thing ->
+    case thing of
+	AClass cls -> return cls
+	other	   -> wrongThingErr "class" (AGlobal thing) name
 	
 tcLookupTyCon :: Name -> TcM TyCon
 tcLookupTyCon name
-  = tcLookupGlobal name	`thenM` \ thing ->
-    return (tyThingTyCon thing)
+  = tcLookupGlobal name		`thenM` \ thing ->
+    case thing of
+	ATyCon tc -> return tc
+	other	  -> wrongThingErr "type constructor" (AGlobal thing) name
+
+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}
 
 %************************************************************************
@@ -167,16 +192,13 @@ getInGlobalScope
 
 
 \begin{code}
-tcExtendRecEnv :: [(Name,TyThing)]	-- Global bindings
-	       -> [(Name,TcTyThing)] 	-- Local bindings
-	       -> TcM r -> TcM r
--- Extend both local and global environments for the type/class knot tying game
-tcExtendRecEnv gbl_stuff lcl_stuff thing_inside
- = do { (gbl_env, lcl_env) <- getEnvs
-      ; let { ge' = extendNameEnvList (tcg_type_env gbl_env) gbl_stuff
-	    ; le' = extendNameEnvList (tcl_env lcl_env)      lcl_stuff }
-      ; setEnvs (gbl_env {tcg_type_env = ge'}, lcl_env {tcl_env = le'}) 
-		thing_inside }
+tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
+-- Extend the global environments for the type/class knot tying game
+tcExtendRecEnv gbl_stuff thing_inside
+ = updGblEnv upd thing_inside
+ where
+   upd env = env { tcg_type_env = extend (tcg_type_env env) }
+   extend env = extendNameEnvList env gbl_stuff
 \end{code}
 
 
@@ -187,6 +209,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,15 +262,12 @@ getInLocalScope = getLclEnv	`thenM` \ env ->
 \end{code}
 
 \begin{code}
-tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r
--- The tyvars are all kinded
-tcExtendTyVarKindEnv tvs thing_inside
+tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
+tcExtendKindEnv things 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]
-	-- No need to extend global tyvars for kind checking
+    extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
 
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
@@ -258,9 +280,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 +295,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 +309,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 +323,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 +421,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 +587,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
@@ -572,8 +599,10 @@ data InstBindings
 
 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
 
-pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
-pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
+pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
+  where
+    details (VanillaInst b _)  = ppr b
+    details (NewTypeDerived _) = text "Derived from the representation type"
 
 simpleInstInfoTy :: InstInfo -> Type
 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
@@ -595,4 +624,15 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 \begin{code}
 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> 
 				  ptext SLIT("is not in scope"))
+
+wrongThingErr expected thing name
+  = failWithTc (pp_thing thing <+> quotes (ppr name) <+> 
+		ptext SLIT("used as a") <+> text expected)
+  where
+    pp_thing (AGlobal (ATyCon _))   = ptext SLIT("Type constructor")
+    pp_thing (AGlobal (AClass _))   = ptext SLIT("Class")
+    pp_thing (AGlobal (AnId   _))   = ptext SLIT("Identifier")
+    pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor")
+    pp_thing (ATyVar _) 	    = ptext SLIT("Type variable")
+    pp_thing (ATcId _ _ _)  	    = ptext SLIT("Local identifier")
 \end{code}