X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=7828394b7b2d7e9faf85f6f5d2a0130bc1aabc52;hb=574022a869f3a24f58fc3e55d586773f24c57724;hp=936ec5b5ac36b64a688ec01690111d657c0e5427;hpb=c94408e522e5af3b79a5beadc7e6d15cee553ee7;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 936ec5b..7828394 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -38,26 +38,26 @@ module TcEnv( topIdLvl, -- New Ids - newLocalName, newDFunName + newLocalName, newDFunName, newFamInstTyConName ) where #include "HsVersions.h" import HsSyn ( LRuleDecl, LHsBinds, LSig, LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds, - ExprCoFn(..), idCoercion, (<.>) ) + idCoercion, (<.>) ) import TcIface ( tcImportDecl ) import IfaceEnv ( newGlobalBinder ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) -import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst, - substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, +import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, + substTy, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp, getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, tidyOpenType, isRefineableTy ) import TcGadt ( Refinement, refineType ) import qualified Type ( getTyVar_maybe ) -import Id ( idName, isLocalId, setIdType ) +import Id ( idName, isLocalId ) import Var ( TyVar, Id, idType, tyVarName ) import VarSet import VarEnv @@ -66,11 +66,13 @@ import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, nameModule ) +import Name ( Name, NamedThing(..), getSrcLoc, nameModule, + nameOccName ) import PrelNames ( thFAKE ) import NameEnv -import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), ExternalPackageState(..) ) +import OccName ( mkDFunOcc, occNameString, mkInstTyTcOcc ) +import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), + ExternalPackageState(..) ) import SrcLoc ( SrcLoc, Located(..) ) import Outputable \end{code} @@ -566,7 +568,7 @@ data InstBindings -- specialised instances | NewTypeDerived - (Maybe TyCon) -- maybe a coercion for the newtype + 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 @@ -611,6 +613,19 @@ newDFunName clas (ty:_) 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) Nothing loc } +\end{code} + %************************************************************************ %* *