%
+% (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 (
#include "HsVersions.h"
import IfaceSyn
-import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls )
-import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
- extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
- tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc,
- 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
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
- , md_exports = exports
+ , md_exports = exports
+ , md_modBreaks = emptyModBreaks
}
}
\end{code}
%************************************************************************
\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
= 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))
}
= 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]
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
ifInstCls = cls, ifInstTys = mb_tcs,
ifInstOrph = orph })
= do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $
- tcIfaceExtId (LocalTop dfun_occ)
- ; cls' <- lookupIfaceExt cls
- ; mb_tcs' <- mapM tc_rough mb_tcs
- ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) }
+ tcIfaceExtId dfun_occ
+ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon,
-- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
= do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
tcIfaceTyCon tycon
- ; fam' <- lookupIfaceExt fam
- ; mb_tcs' <- mapM tc_rough mb_tcs
- ; return (mkImportedFamInst fam' mb_tcs' tycon') }
-
-tc_rough Nothing = return Nothing
-tc_rough (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') }
+ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ ; return (mkImportedFamInst fam mb_tcs' tycon') }
\end{code}
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleOrph = orph })
- = do { fn' <- lookupIfaceExt fn
- ; ~(bndrs', args', rhs') <-
+ = do { ~(bndrs', args', rhs') <-
-- Typecheck the payload lazily, in the hope it'll never be looked at
forkM (ptext SLIT("Rule") <+> ftext name) $
bindIfaceBndrs bndrs $ \ bndrs' ->
do { args' <- mappM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
; return (bndrs', args', rhs') }
- ; mb_tcs <- mapM ifTopFreeName args
- ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act,
+ ; let mb_tcs = map ifTopFreeName args
+ ; lcl <- getLclEnv
+ ; 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 = isLocalIfaceExtName fn }) }
+ 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
-- type syononyms at the top of a type arg. Since
-- we can't tell at this point, we are careful not
-- to write them out in coreRuleToIfaceRule
- ifTopFreeName :: IfaceExpr -> IfL (Maybe Name)
- ifTopFreeName (IfaceType (IfaceTyConApp tc _ ))
- = do { n <- lookupIfaceTc tc
- ; return (Just n) }
- ifTopFreeName (IfaceApp f a) = ifTopFreeName f
- ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext
- ; return (Just n) }
- ifTopFreeName other = return Nothing
+ ifTopFreeName :: IfaceExpr -> Maybe Name
+ ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
+ ifTopFreeName (IfaceApp f a) = ifTopFreeName f
+ ifTopFreeName (IfaceExt n) = Just n
+ ifTopFreeName other = Nothing
\end{code}
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
- = do { let tycon_mod = nameModule (tyConName tycon)
- ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
+ = do { con <- tcIfaceDataCon data_occ
; ASSERT2( con `elem` tyConDataCons tycon,
ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
tcIfaceDataAlt con inst_tys arg_strs rhs }
tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
-tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
- ; thing <- tcIfaceGlobal name
+tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
; return (check_tc (tyThingTyCon thing)) }
where
#ifdef DEBUG
- check_tc tc = case toIfaceTyCon (error "urk") tc of
+ check_tc tc = case toIfaceTyCon tc of
IfaceTc _ -> tc
other -> pprTrace "check_tc" (ppr tc) tc
#else
tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc)
; return tc }
-tcIfaceClass :: IfaceExtName -> IfL Class
-tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
- ; thing <- tcIfaceGlobal name
- ; return (tyThingClass thing) }
+tcIfaceClass :: Name -> IfL Class
+tcIfaceClass name = do { thing <- tcIfaceGlobal name
+ ; return (tyThingClass thing) }
-tcIfaceDataCon :: IfaceExtName -> IfL DataCon
-tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
- ; thing <- tcIfaceGlobal name
- ; case thing of
+tcIfaceDataCon :: Name -> IfL DataCon
+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
+ ; case thing of
ADataCon dc -> return dc
- other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
+ other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
-tcIfaceExtId :: IfaceExtName -> IfL Id
-tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
- ; thing <- tcIfaceGlobal name
- ; case thing of
+tcIfaceExtId :: Name -> IfL Id
+tcIfaceExtId name = do { thing <- tcIfaceGlobal name
+ ; case thing of
AnId id -> return id
- other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
+ other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
\end{code}
%************************************************************************
newExtCoreBndr :: IfaceIdBndr -> IfL Id
newExtCoreBndr (var, ty)
= do { mod <- getIfModule
- ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc
+ ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc
; ty' <- tcIfaceType ty
; return (mkLocalId name ty') }
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}
projects / ghc-hetmet.git / blobdiff