loadInterface, loadInterfaceForName, loadWiredInHomeIface,
loadSrcInterface, loadSysInterface, loadOrphanModules,
findAndReadIface, readIface, -- Used when reading the module's old interface
- loadDecls, ifaceStats, discardDeclPrags,
+ loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
- pprModIface, showIface -- Print the iface in Foo.hi
+ ifaceStats, pprModIface, showIface -- Print the iface in Foo.hi
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst )
+import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
+ tcIfaceFamInst )
import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
- IfaceConDecls(..), IfaceIdInfo(..) )
-import IfaceEnv ( newGlobalBinder )
+ IfaceConDecls(..), IfaceFamInst(..) )
+import IfaceEnv ( newGlobalBinder, lookupIfaceTc )
import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..),
Deprecs(..), Dependencies(..),
emptyModIface, EpsStats(..), GenAvailInfo(..),
import BasicTypes ( Version, initialVersion,
Fixity(..), FixityDirection(..), isMarkedStrict )
import TcRnMonad
+import Type ( TyThing(..) )
import PrelNames ( gHC_PRIM )
import PrelInfo ( ghcPrimExports )
import PrelRules ( builtinRules )
import Rules ( extendRuleBaseList, mkRuleBase )
import InstEnv ( emptyInstEnv, extendInstEnvList )
+import FamInstEnv ( emptyFamInstEnv, extendFamInstEnvList )
import Name ( Name {-instance NamedThing-}, getOccName,
nameModule, nameIsLocalOrFrom, isWiredInName )
import NameEnv
import MkId ( seqId )
import Module
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc,
- mkClassDataConOcc, mkSuperDictSelOcc,
- mkDataConWrapperOcc, mkDataConWorkerOcc,
- mkNewTyCoOcc )
+ mkClassDataConOcc, mkSuperDictSelOcc,
+ mkDataConWrapperOcc, mkDataConWorkerOcc,
+ mkNewTyCoOcc, mkInstTyCoOcc )
import SrcLoc ( importedSrcLoc )
import Maybes ( MaybeErr(..) )
import ErrUtils ( Message )
import Binary ( getBinFileWithDict )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
+import Maybe ( isJust )
import DATA_IOREF ( writeIORef )
\end{code}
loadInterface :: SDoc -> Module -> WhereFrom
-> IfM lcl (MaybeErr Message ModIface)
+-- loadInterface looks in both the HPT and PIT for the required interface
+-- If not found, it loads it, and puts it in the PIT (always).
+
-- If it can't find a suitable interface file, we
-- a) modify the PackageIfaceTable to have an empty entry
-- (to avoid repeated complaints)
-- READ THE MODULE IN
; read_result <- findAndReadIface doc_str mod hi_boot_file
- ; dflags <- getDOpts
; case read_result of {
Failed err -> do
{ let fake_iface = emptyModIface mod
; returnM (Failed err) } ;
-- Found and parsed!
- Succeeded (iface, file_path) -- Sanity check:
+ Succeeded (iface, file_path) -- Sanity check:
| ImportBySystem <- from, -- system-importing...
modulePackageId (mi_module iface) == thisPackage dflags,
-- a home-package module...
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
- ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
- ; new_eps_rules <- if ignore_prags
- then return []
- else mapM tcIfaceRule (mi_rules iface)
+ ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface)
+ ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
+ ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+ ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
mi_rules = panic "No mi_rules in PIT" } }
; updateEps_ $ \ eps ->
- eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
- eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
- eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules,
- eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts,
- eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls)
- (length new_eps_insts) (length new_eps_rules) }
+ eps {
+ eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
+ eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
+ eps_rule_base = extendRuleBaseList (eps_rule_base eps)
+ new_eps_rules,
+ eps_inst_env = extendInstEnvList (eps_inst_env eps)
+ new_eps_insts,
+ eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
+ new_eps_fam_insts,
+ eps_stats = addEpsInStats (eps_stats eps)
+ (length new_eps_decls)
+ (length new_eps_insts) (length new_eps_rules) }
; return (Succeeded final_iface)
}}}}
badDepMsg mod
= hang (ptext SLIT("Interface file inconsistency:"))
- 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"),
- ptext SLIT("but does not appear in the dependencies of the interface")])
+ 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned is needed,"),
+ ptext SLIT("but is not among the dependencies of interfaces directly imported by the module being compiled")])
-----------------------------------------------------
-- Loading type/class/value decls
-- each binder with the right package info in it
-- All subsequent lookups, including crucially lookups during typechecking
-- the declaration itself, will find the fully-glorious Name
+--
+-- We handle ATs specially. They are not main declarations, but also not
+-- implict things (in particular, adding them to `implicitTyThings' would mess
+-- things up in the renaming/type checking of source programs).
-----------------------------------------------------
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
; return (concat thingss)
}
-loadDecl :: Bool -- Don't load pragmas into the decl pool
+loadDecl :: Bool -- Don't load pragmas into the decl pool
-> Module
-> (Version, IfaceDecl)
- -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
- -- TyThings are forkM'd thunks
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
+ -- TyThings are forkM'd thunks
loadDecl ignore_prags mod (_version, decl)
= do { -- Populate the name cache with final versions of all
-- the names associated with the decl
main_name <- mk_new_bndr mod Nothing (ifName decl)
- ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl)
+ ; parent_name <- case ifFamily decl of -- make family the parent
+ Just famTyCon -> lookupIfaceTc famTyCon
+ _ -> return main_name
+ ; implicit_names <- mapM (mk_new_bndr mod (Just parent_name))
+ (ifaceDeclSubBndrs decl)
-- Typecheck the thing, lazily
- -- NB. firstly, the laziness is there in case we never need the
+ -- NB. Firstly, the laziness is there in case we never need the
-- declaration (in one-shot mode), and secondly it is there so that
-- we don't look up the occurrence of a name before calling mk_new_bndr
-- on the binder. This is important because we must get the right name
-- which includes its nameParent.
- ; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl)
+
+ ; thing <- forkM doc $ do { bumpDeclStats main_name
+ ; tcIfaceDecl ignore_prags decl }
+
+ -- Populate the type environment with the implicitTyThings too
; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
lookup n = case lookupOccEnv mini_env (getOccName n) of
Just thing -> thing
- Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (stripped_decl) )
+ Nothing ->
+ pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
- ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
+ ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names]
+ }
-- We build a list from the *known* names, with (lookup n) thunks
-- as the TyThings. That way we can extend the PTE without poking the
-- thunks
where
- stripped_decl | ignore_prags = discardDeclPrags decl
- | otherwise = decl
-
-- mk_new_bndr allocates in the name cache the final canonical
-- name for the thing, with the correct
-- * parent
(importedSrcLoc (showSDoc (ppr (moduleName mod))))
-- ToDo: qualify with the package name if necessary
- doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
+ ifFamily (IfaceData {ifFamInst = Just (famTyCon, _)}) = Just famTyCon
+ ifFamily _ = Nothing
-discardDeclPrags :: IfaceDecl -> IfaceDecl
-discardDeclPrags decl@(IfaceId {ifIdInfo = HasInfo _}) = decl { ifIdInfo = NoInfo }
-discardDeclPrags decl = decl
+ doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
bumpDeclStats name
--
-- If you change this, make sure you change HscTypes.implicitTyThings in sync
-ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt,
- ifName = cls_occ,
- ifSigs = sigs }
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ ifSigs = sigs, ifATs = ats })
= co_occs ++
[tc_occ, dc_occ, dcww_occ] ++
- [op | IfaceClassOp op _ _ <- sigs] ++
+ [op | IfaceClassOp op _ _ <- sigs] ++
+ [ifName at | at <- ats ] ++
[mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
where
n_ctxt = length sc_ctxt
dc_occ = mkClassDataConOcc cls_occ
co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
| otherwise = []
- dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
+ dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
| otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
is_newtype = n_sigs + n_ctxt == 1 -- Sigh
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ,
- ifConFields = fields})})
- = fields ++ [con_occ, mkDataConWrapperOcc con_occ, mkNewTyCoOcc tc_occ]
- -- Wrapper, no worker; see MkId.mkDataConIds
+ ifConFields = fields
+ }),
+ ifFamInst = famInst})
+ = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
+ ++ famInstCo famInst tc_occ
-ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
+ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfDataTyCon cons,
+ ifFamInst = famInst})
= nub (concatMap ifConFields cons) -- Eliminate duplicate fields
++ concatMap dc_occs cons
+ ++ famInstCo famInst tc_occ
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
wrap_occ = mkDataConWrapperOcc con_occ
work_occ = mkDataConWorkerOcc con_occ
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
+ || not (null . ifConEqSpec $ con_decl)
+ || isJust famInst
-- ToDo: may miss strictness in existential dicts
ifaceDeclSubBndrs _other = []
+
+-- coercion for data/newtype family instances
+famInstCo Nothing baseOcc = []
+famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
\end{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
- eps_is_boot = emptyUFM,
- eps_PIT = emptyPackageIfaceTable,
- eps_PTE = emptyTypeEnv,
- eps_inst_env = emptyInstEnv,
- eps_rule_base = mkRuleBase builtinRules,
+ eps_is_boot = emptyUFM,
+ eps_PIT = emptyPackageIfaceTable,
+ eps_PTE = emptyTypeEnv,
+ eps_inst_env = emptyInstEnv,
+ eps_fam_inst_env = emptyFamInstEnv,
+ eps_rule_base = mkRuleBase builtinRules,
-- Initialise the EPS rule pool with the built-in rules
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
-- Show a ModIface
pprModIface iface
= vcat [ ptext SLIT("interface")
- <+> ppr_package (mi_package iface)
<+> ppr (mi_module iface) <+> pp_boot
<+> ppr (mi_mod_vers iface) <+> pp_sub_vers
<+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty)
where
pp_boot | mi_boot iface = ptext SLIT("[boot]")
| otherwise = empty
- ppr_package HomePackage = empty
- ppr_package (ExtPackage id) = doubleQuotes (ppr id)
exp_vers = mi_exp_vers iface
rule_vers = mi_rule_vers iface
projects / ghc-hetmet.git / blobdiff