%
+% (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 (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
- tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal,
+ tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal,
tcExtCoreBindings
) where
#include "HsVersions.h"
import IfaceSyn
-import LoadIface ( loadInterface, loadWiredInHomeIface,
- loadDecls, findAndReadIface )
-import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
- extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
- tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, refineIfaceIdEnv,
- newIfaceName, newIfaceNames, ifaceExportNames )
-import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
- mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
+import LoadIface
+import IfaceEnv
+import BuildTyCl
import TcRnMonad
-import Type ( liftedTypeKind, splitTyConApp, mkTyConApp,
- mkTyVarTys, ThetaType )
-import TypeRep ( Type(..), PredType(..) )
-import TyCon ( TyCon, tyConName )
-import HscTypes ( ExternalPackageState(..),
- TyThing(..), tyThingClass, tyThingTyCon,
- ModIface(..), ModDetails(..), HomeModInfo(..),
- emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
-import InstEnv ( Instance(..), mkImportedInstance )
-import Unify ( coreRefineTys )
+import Type
+import TypeRep
+import HscTypes
+import InstEnv
+import FamInstEnv
import CoreSyn
-import CoreUtils ( exprType )
+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, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
-import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
-import Var ( TyVar, mkTyVar, tyVarKind )
-import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
- wiredInNameTyThing_maybe, nameParent )
+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 )
-import FastString ( FastString )
-import Module ( Module, lookupModuleEnv )
-import UniqSupply ( initUs_ )
+import OccName
+import Module
+import UniqFM
+import UniqSupply
import Outputable
-import ErrUtils ( Message )
-import Maybes ( MaybeErr(..) )
-import SrcLoc ( noSrcLoc )
-import Util ( zipWithEqual, equalLength, splitAtList )
-import DynFlags ( DynFlag(..), isOneShot )
+import ErrUtils
+import Maybes
+import SrcLoc
+import Util
+import DynFlags
+import Control.Monad
+
+import Data.List
+import Data.Maybe
\end{code}
This module takes
= return ()
| otherwise
= do { mod <- getModule
- ; if nameIsLocalOrFrom mod tc_name then
+ ; unless (mod == nameModule tc_name)
+ (initIfaceTcRn (loadWiredInHomeIface tc_name))
-- Don't look for (non-existent) Float.hi when
-- compiling Float.lhs, which mentions Float of course
- return ()
- else -- A bit yukky to call initIfaceTcRn here
- initIfaceTcRn (loadWiredInHomeIface tc_name)
+ -- A bit yukky to call initIfaceTcRn here
}
where
tc_name = tyConName tc
}}}
where
nd_doc = ptext SLIT("Need decl for") <+> ppr name
- not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
+ not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+>
+ pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
\end{code}
-- to handle unboxed tuples, so it must not see unfoldings.
ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- -- Load & typecheck the decls
- ; decl_things <- loadDecls ignore_prags (mi_decls iface)
-
- ; let type_env = mkNameEnv decl_things
+ -- Typecheck the decls. This is done lazily, so that the knot-tying
+ -- within this single module work out right. In the If monad there is
+ -- no global envt for the current interface; instead, the knot is tied
+ -- through the if_rec_types field of IfGblEnv
+ ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
+ ; let type_env = mkNameEnv names_w_things
; writeMutVar tc_env_var type_env
-- Now do those rules and instances
- ; let { rules | ignore_prags = []
- | otherwise = mi_rules iface
- ; dfuns = mi_insts iface
- }
- ; dfuns <- mapM tcIfaceInst dfuns
- ; rules <- mapM tcIfaceRule rules
+ ; insts <- mapM tcIfaceInst (mi_insts iface)
+ ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+ ; rules <- tcIfaceRules ignore_prags (mi_rules iface)
-- Exports
- ; exports <- ifaceExportNames (mi_exports iface)
+ ; exports <- ifaceExportNames (mi_exports iface)
-- Finished
- ; return (ModDetails { md_types = type_env,
- md_insts = dfuns,
- md_rules = rules,
- md_exports = exports })
+ ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
+ text "Type envt:" <+> ppr type_env])
+ ; return $ ModDetails { md_types = type_env
+ , md_insts = insts
+ , md_fam_insts = fam_insts
+ , md_rules = rules
+ , 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
-- And that's fine, because if M's ModInfo is in the HPT, then
-- it's been compiled once, and we don't need to check the boot iface
then do { hpt <- getHpt
- ; case lookupModuleEnv hpt mod of
+ ; case lookupUFM hpt (moduleName mod) of
Just info | mi_boot (hm_iface info)
-> return (hm_details info)
other -> return emptyModDetails }
-- so eps_is_boot will record if any of our imports mention us by
-- way of hi-boot file
{ eps <- getEps
- ; case lookupModuleEnv (eps_is_boot eps) mod of {
+ ; case lookupUFM (eps_is_boot eps) (moduleName mod) of {
Nothing -> return emptyModDetails ; -- The typical case
Just (_, False) -> failWithTc moduleLoop ;
-- Someone below us imported us!
-- This is a loop with no hi-boot in the way
- Just (mod, True) -> -- There's a hi-boot interface below us
+ Just (_mod, True) -> -- There's a hi-boot interface below us
do { read_result <- findAndReadIface
- True -- Explicit import?
need mod
True -- Hi-boot file
\begin{code}
-tcIfaceDecl :: IfaceDecl -> IfL TyThing
+tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings
+ -> IfaceDecl
+ -> IfL TyThing
-tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
+tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info})
= do { name <- lookupIfaceTop occ_name
; ty <- tcIfaceType iface_type
- ; info <- tcIdInfo name ty info
+ ; info <- tcIdInfo ignore_prags name ty info
; return (AnId (mkVanillaGlobal name ty info)) }
-tcIfaceDecl (IfaceData {ifName = occ_name,
+tcIfaceDecl ignore_prags
+ (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs,
- ifCtxt = ctxt,
+ ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
- ifVrcs = arg_vrcs, ifRec = is_rec,
- ifGeneric = want_generic })
+ ifRec = is_rec,
+ ifGeneric = want_generic,
+ ifFamInst = mb_family })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tycon <- fixM ( \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; cons <- tcIfaceDataCons tycon tyvars rdr_cons
+ ; famInst <-
+ case mb_family of
+ Nothing -> return Nothing
+ Just (fam, tys) ->
+ do { famTyCon <- tcIfaceTyCon fam
+ ; insttys <- mapM tcIfaceType tys
+ ; return $ Just (famTyCon, insttys)
+ }
+ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; buildAlgTyCon tc_name tyvars stupid_theta
- cons arg_vrcs is_rec want_generic
+ cons is_rec want_generic gadt_syn famInst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
}}
-tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
- ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
+tcIfaceDecl ignore_prags
+ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
+ ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_ty <- tcIfaceType rdr_rhs_ty
- ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty arg_vrcs))
+ ; rhs_tyki <- tcIfaceType rdr_rhs_ty
+ ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
+ else SynonymTyCon rhs_tyki
+ ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
}
-tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs,
- ifFDs = rdr_fds, ifSigs = rdr_sigs,
- ifVrcs = tc_vrcs, ifRec = tc_isrec })
+tcIfaceDecl ignore_prags
+ (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name,
+ ifTyVars = tv_bndrs, ifFDs = rdr_fds,
+ ifATs = rdr_ats, ifSigs = rdr_sigs,
+ ifRec = tc_isrec })
+-- ToDo: in hs-boot files we should really treat abstract classes specially,
+-- as we do abstract tycons
= bindIfaceTyVars tv_bndrs $ \ tyvars -> do
{ cls_name <- lookupIfaceTop occ_name
; ctxt <- tcIfaceCtxt rdr_ctxt
; sigs <- mappM tc_sig rdr_sigs
; fds <- mappM tc_fd rdr_fds
- ; cls <- buildClass cls_name tyvars ctxt fds sigs tc_isrec tc_vrcs
+ ; ats' <- mappM (tcIfaceDecl ignore_prags) rdr_ats
+ ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
+ ; cls <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
; return (AClass cls) }
where
tc_sig (IfaceClassOp occ dm rdr_ty)
= 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]
; tvs2' <- mappM tcIfaceTyVar tvs2
; return (tvs1', tvs2') }
-tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+ -- For each AT argument compute the position of the corresponding class
+ -- parameter in the class head. This will later serve as a permutation
+ -- vector when checking the validity of instance declarations.
+ setTyThingPoss (ATyCon tycon) atTyVars =
+ let classTyVars = map fst tv_bndrs
+ poss = catMaybes
+ . map ((`elemIndex` classTyVars) . fst)
+ $ atTyVars
+ -- There will be no Nothing, as we already passed renaming
+ in
+ ATyCon (setTyConArgPoss tycon poss)
+ setTyThingPoss _ _ = panic "TcIface.setTyThingPoss"
+
+tcIfaceDecl ignore_prags (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
= do { name <- lookupIfaceTop rdr_name
; return (ATyCon (mkForeignTyCon name ext_name
- liftedTypeKind 0 [])) }
+ liftedTypeKind 0)) }
-tcIfaceDataCons tycon tc_tyvars if_cons
+tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon -> return mkAbstractTyConRhs
+ IfOpenDataTyCon -> return mkOpenDataTyConRhs
+ IfOpenNewTyCon -> return mkOpenNewTyConRhs
IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
- ; return (mkNewTyConRhs tycon data_con) }
+ ; mkNewTyConRhs tycon_name tycon data_con }
where
- tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args,
- ifConStricts = stricts, ifConFields = field_lbls})
- = do { name <- lookupIfaceTop occ
- -- Read the argument types, but lazily to avoid faulting in
- -- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
- ; lbl_names <- mappM lookupIfaceTop field_lbls
- ; buildDataCon name is_infix True {- Vanilla -}
- stricts lbl_names
- tc_tyvars [] arg_tys tycon
- (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
- }
-
- tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
- ifConOcc = occ, ifConCtxt = ctxt,
- ifConArgTys = args, ifConResTys = ress,
- ifConStricts = stricts})
- = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
+ tc_con_decl (IfCon { ifConInfix = is_infix,
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ 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
{ name <- lookupIfaceTop occ
+ ; eq_spec <- tcIfaceEqSpec spec
; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
-- At one stage I thought that this context checking *had*
-- to be lazy, because of possible mutual recursion between the
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
- ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
+ ; lbl_names <- mappM lookupIfaceTop field_lbls
- ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
- stricts [{- No fields -}]
- con_tyvars theta
- arg_tys tycon res_tys
+ ; buildDataCon name is_infix {- Not infix -}
+ stricts lbl_names
+ univ_tyvars ex_tyvars
+ eq_spec theta
+ arg_tys tycon
}
mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
+
+tcIfaceEqSpec spec
+ = mapM do_item spec
+ where
+ do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
+ ; ty <- tcIfaceType if_ty
+ ; return (tv,ty) }
\end{code}
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 do_tc mb_tcs
- ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) }
- where
- do_tc Nothing = return Nothing
- do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') }
+ 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,
+ ifFamInstFam = fam, ifFamInstTys = mb_tcs })
+-- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $
+-- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
+ = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $
+ tcIfaceTyCon tycon
+ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+ ; return (mkImportedFamInst fam mb_tcs' tycon') }
\end{code}
(as a side effect) augment the type envt, and so we may need to iterate the process.
\begin{code}
+tcIfaceRules :: Bool -- True <=> ignore rules
+ -> [IfaceRule]
+ -> IfL [CoreRule]
+tcIfaceRules ignore_prags if_rules
+ | ignore_prags = return []
+ | otherwise = mapM tcIfaceRule if_rules
+
tcIfaceRule :: IfaceRule -> IfL CoreRule
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}
tcIfacePredType :: IfacePredType -> IfL PredType
tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
+tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
where
(bndrs, rhss) = unzip pairs
+tcIfaceExpr (IfaceCast expr co) = do
+ expr' <- tcIfaceExpr expr
+ co' <- tcIfaceType co
+ returnM (Cast expr' co')
+
tcIfaceExpr (IfaceNote note expr)
= tcIfaceExpr expr `thenM` \ expr' ->
case note of
- IfaceCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' ->
- returnM (Note (Coerce to_ty'
- (exprType expr')) expr')
IfaceInlineMe -> returnM (Note InlineMe expr')
IfaceSCC cc -> returnM (Note (SCC cc) expr')
IfaceCoreNote n -> returnM (Note (CoreNote n) expr')
-- 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 }
- if isVanillaDataCon con then
- tcVanillaAlt con inst_tys arg_strs rhs
- else
- do { -- General case
- let (tyvar_strs, id_strs) = splitAtList (dataConTyVars con) arg_strs
- ; tyvar_names <- mapM (newIfaceName . mkTyVarOcc) tyvar_strs
- ; id_names <- mapM (newIfaceName . mkVarOccFS) id_strs
- ; let tyvars = [ mkTyVar name (tyVarKind tv)
- | (name,tv) <- tyvar_names `zip` dataConTyVars con ]
- arg_tys = dataConInstArgTys con (mkTyVarTys tyvars)
- arg_ids = ASSERT2( equalLength id_names arg_tys,
- ppr (con, tyvar_names++id_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
- zipWith mkLocalId id_names arg_tys
-
- Just refine = coreRefineTys con tyvars (mkTyConApp tycon inst_tys)
-
- ; rhs' <- extendIfaceTyVarEnv tyvars $
- extendIfaceIdEnv arg_ids $
- refineIfaceIdEnv refine $
- -- You might think that we don't need to refine the envt here,
- -- but we do: \(x::a) -> case y of
- -- MkT -> case x of { True -> ... }
- -- In the "case x" we need to know x's type, because we use that
- -- to find which module to look for "True" in. Sigh.
- tcIfaceExpr rhs
- ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
-
tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
= ASSERT( isTupleTyCon tycon )
do { let [data_con] = tyConDataCons tycon
- ; tcVanillaAlt data_con inst_tys arg_occs rhs }
-
-tcVanillaAlt data_con inst_tys arg_strs rhs
- = do { arg_names <- newIfaceNames (map mkVarOccFS arg_strs)
- ; let arg_tys = dataConInstArgTys data_con inst_tys
- ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
- ppr data_con <+> ppr inst_tys <+> ppr arg_strs $$ ppr rhs )
- zipWith mkLocalId arg_names arg_tys
- ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
- ; returnM (DataAlt data_con, arg_ids, rhs') }
+ ; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
+
+tcIfaceDataAlt con inst_tys arg_strs rhs
+ = do { us <- newUniqueSupply
+ ; let uniqs = uniqsFromSupply us
+ ; let (ex_tvs, co_tvs, arg_ids)
+ = dataConRepFSInstPat arg_strs uniqs con inst_tys
+ all_tvs = ex_tvs ++ co_tvs
+
+ ; rhs' <- extendIfaceTyVarEnv all_tvs $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs
+ ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
\end{code}
%************************************************************************
\begin{code}
-tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
-tcIdInfo name ty NoInfo = return vanillaIdInfo
-tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
+tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags name ty info
+ | ignore_prags = return vanillaIdInfo
+ | otherwise = case info of
+ NoInfo -> return vanillaIdInfo
+ HasInfo info -> foldlM tcPrag init_info info
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
get_in_scope_ids `thenM` \ in_scope ->
case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> returnM ()
- Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
+ Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
) `thenM_`
returnM core_expr'
tcIfaceGlobal name
| Just thing <- wiredInNameTyThing_maybe name
-- Wired-in things include TyCons, DataCons, and Ids
- = do { loadWiredInHomeIface name; return thing }
- -- Even though we are in an interface file, we want to make
- -- sure its instances are loaded (imagine f :: Double -> Double)
- -- and its RULES are loaded too
+ = do { ifCheckWiredInThing name; return thing }
| otherwise
= do { (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
Succeeded thing -> return thing
}}}}}
+ifCheckWiredInThing :: Name -> IfL ()
+-- Even though we are in an interface file, we want to make
+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
+-- Ditto want to ensure that RULES are loaded too
+ifCheckWiredInThing name
+ = do { mod <- getIfModule
+ -- Check whether we are typechecking the interface for this
+ -- very module. E.g when compiling the base library in --make mode
+ -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
+ -- the HPT, so without the test we'll demand-load it into the PIT!
+ -- C.f. the same test in checkWiredInTyCon above
+ ; unless (mod == nameModule name)
+ (loadWiredInHomeIface name) }
+
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon
tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon
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
check_tc tc = tc
#endif
+-- we should be okay just returning Kind constructors without extra loading
+tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon
+tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon
+tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
+tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon
+tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon
-- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this tycon are loaded
-- Imagine: f :: Double -> Double
tcWiredInTyCon :: TyCon -> IfL TyCon
-tcWiredInTyCon tc = do { loadWiredInHomeIface (tyConName tc)
+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') }
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOcc occ)
- ; let tyvar = mk_iface_tyvar name kind
+ ; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars bndrs thing_inside
= do { names <- newIfaceNames (map mkTyVarOcc occs)
- ; let tyvars = zipWith 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 kind = mkTyVar name kind
+mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
+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