X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=b82685bee743eb6be0f534cd937a7eecf61ad522;hp=c16846ec288fa946c59ab588a9ef84c3958ea4bb;hb=cdce647711c0f46f5799b24de087622cb77e647f;hpb=b00b5bc04ff36a551552470060064f0b7d84ca30 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index c16846e..b82685b 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcIfaceSig]{Type checking of type signatures in interface files} + +Type checking of type signatures in interface files \begin{code} module TcIface ( @@ -13,63 +15,45 @@ module TcIface ( #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls ) -import IfaceEnv ( lookupIfaceTop, newGlobalBinder, - extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, - newIfaceName, newIfaceNames, ifaceExportNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, - buildClass, - mkAbstractTyConRhs, mkOpenDataTyConRhs, - mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) +import LoadIface +import IfaceEnv +import BuildTyCl import TcRnMonad -import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, - liftedTypeKindTyCon, unliftedTypeKindTyCon, - openTypeKindTyCon, argTypeKindTyCon, - ubxTupleKindTyCon, ThetaType ) -import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss ) -import HscTypes ( ExternalPackageState(..), - TyThing(..), tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), HomeModInfo(..), - emptyModDetails, lookupTypeEnv, lookupType, - typeEnvIds ) -import InstEnv ( Instance(..), mkImportedInstance ) -import FamInstEnv ( FamInst(..), mkImportedFamInst ) +import Type +import TypeRep +import HscTypes +import InstEnv +import FamInstEnv import CoreSyn -import CoreUtils ( exprType, dataConRepFSInstPat ) +import CoreUtils import CoreUnfold -import CoreLint ( lintUnfolding ) -import WorkWrap ( mkWrapper ) -import Id ( Id, mkVanillaGlobal, mkLocalId ) -import MkId ( mkFCallId ) -import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), - setUnfoldingInfoLazily, setAllStrictnessInfo, setWorkerInfo, - setArityInfo, setInlinePragInfo, setCafInfo, - vanillaIdInfo, newStrictnessInfo ) -import Class ( Class ) -import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId ) -import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) -import Var ( TyVar, mkTyVar ) -import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, - nameOccName, wiredInNameTyThing_maybe ) +import CoreLint +import WorkWrap +import Id +import MkId +import IdInfo +import Class +import TyCon +import DataCon +import TysWiredIn +import Var ( TyVar ) +import qualified Var +import Name import NameEnv -import OccName ( OccName, mkVarOccFS, mkTyVarOcc, occNameSpace, - pprNameSpace, occNameFS ) -import Module ( Module, moduleName ) -import UniqFM ( lookupUFM ) -import UniqSupply ( initUs_, uniqsFromSupply ) +import OccName +import Module +import UniqFM +import UniqSupply import Outputable -import ErrUtils ( Message ) -import Maybes ( MaybeErr(..) ) -import SrcLoc ( noSrcLoc ) -import Util ( zipWithEqual ) -import DynFlags ( DynFlag(..), isOneShot ) -import Control.Monad ( unless ) - -import List ( elemIndex) -import Maybe ( catMaybes ) +import ErrUtils +import Maybes +import SrcLoc +import Util +import DynFlags +import Control.Monad + +import Data.List +import Data.Maybe \end{code} This module takes @@ -225,7 +209,8 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules - , md_exports = exports + , md_exports = exports + , md_modBreaks = emptyModBreaks } } \end{code} @@ -238,11 +223,14 @@ typecheckIface iface %************************************************************************ \begin{code} -tcHiBootIface :: Module -> TcRn ModDetails +tcHiBootIface :: HscSource -> Module -> TcRn ModDetails -- Load the hi-boot iface for the module being compiled, -- if it indeed exists in the transitive closure of imports -- Return the ModDetails, empty if no hi-boot iface -tcHiBootIface mod +tcHiBootIface hsc_src mod + | isHsBoot hsc_src -- Already compiling a hs-boot file + = return emptyModDetails + | otherwise = do { traceIf (text "loadHiBootInterface" <+> ppr mod) ; mode <- getGhcMode @@ -394,7 +382,7 @@ tcIfaceDecl ignore_prags = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_tyki <- tcIfaceType rdr_rhs_ty - ; let rhs = if isOpen then OpenSynTyCon rhs_tyki + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing else SynonymTyCon rhs_tyki ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } @@ -420,8 +408,8 @@ tcIfaceDecl ignore_prags = do { op_name <- lookupIfaceTop occ ; op_ty <- forkM (mk_doc op_name rdr_ty) (tcIfaceType rdr_ty) -- Must be done lazily for just the same reason as the - -- context of a data decl: the type sig might mention the - -- class being defined + -- type of a data con; to avoid sucking in types that + -- it mentions unless it's necessray to do so ; return (op_name, dm, op_ty) } mk_doc op_name op_ty = ptext SLIT("Class op") <+> sep [ppr op_name, ppr op_ty] @@ -463,8 +451,8 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, ifConArgTys = args, ifConFields = field_lbls, ifConStricts = stricts}) - = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do - bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do + = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do + bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { name <- lookupIfaceTop occ ; eq_spec <- tcIfaceEqSpec spec ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here @@ -513,7 +501,7 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) } + ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, @@ -558,12 +546,13 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args ; lcl <- getLclEnv - ; let this_module = if_mod lcl ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', ru_orph = orph, + ru_rhs = rhs', ru_rough = mb_tcs, - ru_local = nameModule fn == this_module }) } + ru_local = False }) } -- An imported RULE is never for a local Id + -- or, even if it is (module loop, perhaps) + -- we'll just leave it in the non-local set where -- This function *must* mirror exactly what Rules.topFreeName does -- We could have stored the ru_rough field in the iface file @@ -1020,14 +1009,17 @@ bindIfaceTyVar (occ,kind) thing_inside bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside = do { names <- newIfaceNames (map mkTyVarOcc occs) - ; tyvars <- zipWithM mk_iface_tyvar names kinds + ; tyvars <- TcRnMonad.zipWithM mk_iface_tyvar names kinds ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } where (occs,kinds) = unzip bndrs mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar -mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind - ; return (mkTyVar name kind) - } +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceType ifKind + ; if isCoercionKind kind then + return (Var.mkCoVar name kind) + else + return (Var.mkTyVar name kind) } \end{code}