X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=c638c04d5e060aef26355946d6870a255c03eb6d;hb=311b1cdfc9b1c311cc53482c461c18cba8885b2a;hp=936ec5b5ac36b64a688ec01690111d657c0e5427;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 936ec5b..c638c04 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -1,3 +1,7 @@ +% +% (c) The University of Glasgow 2006 +% + \begin{code} module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -38,40 +42,34 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName + newLocalName, newDFunName, newFamInstTyConName ) where #include "HsVersions.h" -import HsSyn ( LRuleDecl, LHsBinds, LSig, - LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds, - ExprCoFn(..), idCoercion, (<.>) ) -import TcIface ( tcImportDecl ) -import IfaceEnv ( newGlobalBinder ) +import HsSyn +import TcIface +import IfaceEnv import TcRnMonad -import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) -import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst, - substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, - 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 ) +import TcMType +import TcType +import TcGadt +import qualified Type +import Id +import Var import VarSet import VarEnv -import RdrName ( extendLocalRdrEnv ) -import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) -import DataCon ( DataCon ) -import TyCon ( TyCon ) -import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule ) -import PrelNames ( thFAKE ) +import RdrName +import InstEnv +import DataCon +import TyCon +import Class +import Name +import PrelNames import NameEnv -import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) ) -import SrcLoc ( SrcLoc, Located(..) ) +import OccName +import HscTypes +import SrcLoc import Outputable \end{code} @@ -112,13 +110,15 @@ tcLookupGlobal name Nothing -> do -- Should it have been in the local envt? - { let mod = nameModule name - ; if mod == tcg_mod env || mod == thFAKE then - notFound name -- It should be local, so panic - -- The thFAKE possibility is because it - -- might be in a declaration bracket - else - tcImportDecl name -- Go find it in an interface + { case nameModule_maybe name of + Nothing -> notFound name -- Internal names can happen in GHCi + + Just mod | mod == tcg_mod env -- Names from this module + -> notFound name -- should be in tcg_type_env + | mod == thFAKE -- Names bound in TH declaration brackets + -> notFound name -- should be in tcg_env + | otherwise + -> tcImportDecl name -- Go find it in an interface }}}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id @@ -324,7 +324,7 @@ tcExtendIdEnv2 names_w_ids thing_inside tct_level = th_lvl, tct_type = id_ty, tct_co = if isRefineableTy id_ty - then Just idCoercion + then Just idHsWrapper else Nothing }) | (name,id) <- names_w_ids, let id_ty = idType id] le' = extendNameEnvList (tcl_env env) extra_env @@ -360,7 +360,7 @@ findGlobals tvs tidy_env Just d -> go tidy_env1 (d:acc) things Nothing -> go tidy_env1 acc things - ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty) + ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty ----------------------- find_thing ignore_it tidy_env (ATcId { tct_id = id }) @@ -565,20 +565,26 @@ data InstBindings [LSig Name] -- User pragmas recorded for generating -- specialised instances - | NewTypeDerived - (Maybe TyCon) -- maybe a coercion 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 - -- See notes in TcDeriv + | NewTypeDerived -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument + -- dictionary. Hence no bindings, no pragmas. + (Maybe [PredType]) + -- Nothing => The newtype-derived instance involves type variables, + -- and the dfun has a type like df :: forall a. Eq a => Eq (T a) + -- Just (r:scs) => The newtype-defined instance has no type variables + -- so the dfun is just a constant, df :: Eq T + -- In this case we need to know waht the rep dict, r, and the + -- superclasses, scs, are. (In the Nothing case these are in the + -- dict fun's type.) + -- Invariant: these PredTypes have no free variables + -- NB: In both cases, the representation dict is the *first* dict. 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 @@ -606,11 +612,24 @@ newDFunName clas (ty:_) loc occNameString (getDFunTyKey ty) dfun_occ = mkDFunOcc info_string is_boot index - ; newGlobalBinder mod dfun_occ Nothing loc } + ; newGlobalBinder mod dfun_occ loc } newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} +Make a name for the representation tycon of a data/newtype instance. It's an +*external* name, like otber top-level names, and hence must be made with +newGlobalBinder. + +\begin{code} +newFamInstTyConName :: Name -> SrcLoc -> TcM Name +newFamInstTyConName tc_name loc + = do { index <- nextDFunIndex + ; mod <- getModule + ; let occ = nameOccName tc_name + ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +\end{code} + %************************************************************************ %* *