X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=b3e0d7fdea0b78144fa2efd2ca60dca8cf91309b;hb=ad4a18b179fbe4ad314b3accf32e806cf00f2a0b;hp=497ba235da4b754d889c5220ffa202b360a7b112;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 497ba23..b3e0d7f 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -11,7 +11,7 @@ module TcEnv(
 	tcExtendGlobalEnv, 
 	tcExtendGlobalValEnv,
 	tcLookupLocatedGlobal,	tcLookupGlobal, 
-	tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+	tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
 	tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
 	tcLookupLocatedClass, 
 	
@@ -19,7 +19,7 @@ module TcEnv(
 	tcExtendKindEnv, tcExtendKindEnvTvs,
 	tcExtendTyVarEnv, tcExtendTyVarEnv2, 
 	tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
-	tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe,
+	tcLookup, tcLookupLocated, tcLookupLocalIds, 
 	tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
 	lclEnvElts, getInLocalScope, findGlobals, 
 	wrongThingErr, pprBinders,
@@ -44,7 +44,8 @@ module TcEnv(
 #include "HsVersions.h"
 
 import HsSyn		( LRuleDecl, LHsBinds, LSig, 
-			  LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
+			  LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds,
+		 	  ExprCoFn(..), idCoercion, (<.>) )
 import TcIface		( tcImportDecl )
 import IfaceEnv		( newGlobalBinder )
 import TcRnMonad
@@ -54,6 +55,7 @@ import TcType		( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst,
 			  getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
 			  tidyOpenType, isRefineableTy
 			)
+import TcGadt		( Refinement, refineType )
 import qualified Type	( getTyVar_maybe )
 import Id		( idName, isLocalId, setIdType )
 import Var		( TyVar, Id, idType, tyVarName )
@@ -64,14 +66,11 @@ import InstEnv		( Instance, DFunId, instanceDFunId, instanceHead )
 import DataCon		( DataCon )
 import TyCon		( TyCon )
 import Class		( Class )
-import Name		( Name, NamedThing(..), getSrcLoc, nameModule, isExternalName )
+import Name		( Name, NamedThing(..), getSrcLoc, nameModule )
 import PrelNames	( thFAKE )
 import NameEnv
 import OccName		( mkDFunOcc, occNameString )
-import HscTypes		( extendTypeEnvList, lookupType,
-			  TyThing(..), tyThingId, tyThingDataCon,
-			  ExternalPackageState(..) )
-
+import HscTypes		( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) )
 import SrcLoc		( SrcLoc, Located(..) )
 import Outputable
 \end{code}
@@ -107,7 +106,8 @@ tcLookupGlobal name
 	 
 		-- Try global envt
 	{ (eps,hpt) <- getEpsAndHpt
-	; case lookupType hpt (eps_PTE eps) name of  {
+	; dflags <- getDOpts
+	; case lookupType dflags hpt (eps_PTE eps) name of  {
 	    Just thing -> return thing ;
 	    Nothing    -> do
 
@@ -121,16 +121,19 @@ tcLookupGlobal name
 		tcImportDecl name	-- Go find it in an interface
 	}}}}}
 
-tcLookupGlobalId :: Name -> TcM Id
--- Never used for Haskell-source DataCons, hence no ADataCon case
-tcLookupGlobalId name
+tcLookupField :: Name -> TcM Id		-- Returns the selector Id
+tcLookupField name
   = tcLookupGlobal name		`thenM` \ thing ->
-    return (tyThingId thing)
+    case thing of
+	AnId id -> return id
+	other	-> wrongThingErr "field name" (AGlobal thing) name
 
 tcLookupDataCon :: Name -> TcM DataCon
-tcLookupDataCon con_name
-  = tcLookupGlobal con_name	`thenM` \ thing ->
-    return (tyThingDataCon thing)
+tcLookupDataCon name
+  = tcLookupGlobal name	`thenM` \ thing ->
+    case thing of
+	ADataCon con -> return con
+	other	     -> wrongThingErr "data constructor" (AGlobal thing) name
 
 tcLookupClass :: Name -> TcM Class
 tcLookupClass name
@@ -215,21 +218,16 @@ tcLookupTyVar name
 	other	    -> pprPanic "tcLookupTyVar" (ppr name)
 
 tcLookupId :: Name -> TcM Id
--- Used when we aren't interested in the binding level
--- Never a DataCon. (Why does that matter? see TcExpr.tcId)
+-- Used when we aren't interested in the binding level, nor refinement. 
+-- The "no refinement" part means that we return the un-refined Id regardless
+-- 
+-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
 tcLookupId name
   = tcLookup name	`thenM` \ thing -> 
     case thing of
-	ATcId tc_id _ _	  -> returnM tc_id
-	AGlobal (AnId id) -> returnM id
-	other		  -> pprPanic "tcLookupId" (ppr name)
-
-tcLookupLocalId_maybe :: Name -> TcM (Maybe Id)
-tcLookupLocalId_maybe name
-  = getLclEnv 		`thenM` \ local_env ->
-    case lookupNameEnv (tcl_env local_env) name of
-	Just (ATcId tc_id _ _) -> return (Just tc_id)
-	other	 	       -> return Nothing
+	ATcId { tct_id = id} -> returnM id
+	AGlobal (AnId id)    -> returnM id
+	other		     -> pprPanic "tcLookupId" (ppr name)
 
 tcLookupLocalIds :: [Name] -> TcM [TcId]
 -- We expect the variables to all be bound, and all at
@@ -240,8 +238,9 @@ tcLookupLocalIds ns
   where
     lookup lenv lvl name 
 	= case lookupNameEnv lenv name of
-		Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
-		other		       -> pprPanic "tcLookupLocalIds" (ppr name)
+		Just (ATcId { tct_id = id, tct_level = lvl1 }) 
+			-> ASSERT( lvl == lvl1 ) id
+		other	-> pprPanic "tcLookupLocalIds" (ppr name)
 
 lclEnvElts :: TcLclEnv -> [TcTyThing]
 lclEnvElts env = nameEnvElts (tcl_env env)
@@ -321,8 +320,13 @@ tcExtendIdEnv2 names_w_ids thing_inside
     let
 	extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
 	th_lvl		    = thLevel (tcl_th_ctxt   env)
-	extra_env	    = [ (name, ATcId id th_lvl (isRefineableTy (idType id)))
-			      | (name,id) <- names_w_ids]
+	extra_env	    = [ (name, ATcId { tct_id = id, 
+					       tct_level = th_lvl,
+					       tct_type = id_ty, 
+					       tct_co = if isRefineableTy id_ty 
+							then Just idCoercion
+							else Nothing })
+			      | (name,id) <- names_w_ids, let id_ty = idType id]
 	le'		    = extendNameEnvList (tcl_env env) extra_env
 	rdr_env'	    = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
     in
@@ -359,7 +363,7 @@ findGlobals tvs tidy_env
     ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
 
 -----------------------
-find_thing ignore_it tidy_env (ATcId id _ _)
+find_thing ignore_it tidy_env (ATcId { tct_id = id })
   = zonkTcType  (idType id)	`thenM` \ id_ty ->
     if ignore_it id_ty then
 	returnM (tidy_env, Nothing)
@@ -387,19 +391,25 @@ find_thing ignore_it tidy_env (ATyVar tv ty)
 	bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
     in
     returnM (tidy_env1, Just msg)
+
+find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 \end{code}
 
 \begin{code}
-refineEnvironment :: TvSubst -> TcM a -> TcM a
+refineEnvironment :: Refinement -> TcM a -> TcM a
+-- I don't think I have to refine the set of global type variables in scope
+-- Reason: the refinement never increases that set
 refineEnvironment reft thing_inside
   = do	{ env <- getLclEnv
 	; let le' = mapNameEnv refine (tcl_env env)
-	; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env) 
- 	; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside }
+ 	; setLclEnv (env {tcl_env = le'}) thing_inside }
   where
-    refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True
-    refine (ATyVar tv ty)      = ATyVar tv (substTy reft ty)
-    refine elt		       = elt
+    refine elt@(ATcId { tct_co = Just co, tct_type = ty })
+			  = let (co', ty') = refineType reft ty
+			    in elt { tct_co = Just (co' <.> co), tct_type = ty' }
+    refine (ATyVar tv ty) = ATyVar tv (snd (refineType reft ty))
+				-- Ignore the coercion that refineType returns
+    refine elt		  = elt
 \end{code}
 
 %************************************************************************
@@ -412,11 +422,6 @@ refineEnvironment reft thing_inside
 tc_extend_gtvs gtvs extra_global_tvs
   = readMutVar gtvs		`thenM` \ global_tvs ->
     newMutVar (global_tvs `unionVarSet` extra_global_tvs)
-
-refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet)
-refineGlobalTyVars reft gtv_var
-  = readMutVar gtv_var				`thenM` \ gbl_tvs ->
-    newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs)))
 \end{code}
 
 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
@@ -560,7 +565,9 @@ data InstBindings
 	[LSig Name]		-- User pragmas recorded for generating 
 				-- specialised instances
 
-  | NewTypeDerived 		-- Used for deriving instances of newtypes, where the
+  | NewTypeDerived 		
+        TyCon                   -- tycon for the newtype
+                                -- Used for deriving instances of newtypes, where the
 	[Type]			-- witness dictionary is identical to the argument 
 				-- dictionary.  Hence no bindings, no pragmas
 	-- The [Type] are the representation types
@@ -571,7 +578,7 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))
 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
   where
     details (VanillaInst b _)  = pprLHsBinds b
-    details (NewTypeDerived _) = text "Derived from the representation type"
+    details (NewTypeDerived _  _) = text "Derived from the representation type"
 
 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of