projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
ATs are now implicitTyThings
[ghc-hetmet.git]
/
compiler
/
iface
/
LoadIface.lhs
diff --git
a/compiler/iface/LoadIface.lhs
b/compiler/iface/LoadIface.lhs
index
599762e
..
21332fa
100644
(file)
--- a/
compiler/iface/LoadIface.lhs
+++ b/
compiler/iface/LoadIface.lhs
@@
-35,6
+35,8
@@
import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..),
import BasicTypes ( Version, initialVersion,
Fixity(..), FixityDirection(..), isMarkedStrict )
import TcRnMonad
import BasicTypes ( Version, initialVersion,
Fixity(..), FixityDirection(..), isMarkedStrict )
import TcRnMonad
+import Type ( TyThing(..) )
+import Class ( classATs )
import PrelNames ( gHC_PRIM )
import PrelInfo ( ghcPrimExports )
import PrelNames ( gHC_PRIM )
import PrelInfo ( ghcPrimExports )
@@
-47,9
+49,9
@@
import NameEnv
import MkId ( seqId )
import Module
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc,
import MkId ( seqId )
import Module
import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc,
- mkClassDataConOcc, mkSuperDictSelOcc,
- mkDataConWrapperOcc, mkDataConWorkerOcc,
- mkNewTyCoOcc )
+ mkClassDataConOcc, mkSuperDictSelOcc,
+ mkDataConWrapperOcc, mkDataConWorkerOcc,
+ mkNewTyCoOcc, mkInstTyTcOcc, mkInstTyCoOcc )
import SrcLoc ( importedSrcLoc )
import Maybes ( MaybeErr(..) )
import ErrUtils ( Message )
import SrcLoc ( importedSrcLoc )
import Maybes ( MaybeErr(..) )
import ErrUtils ( Message )
@@
-62,6
+64,7
@@
import BinIface ( readBinIface, v_IgnoreHiWay )
import Binary ( getBinFileWithDict )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
import Binary ( getBinFileWithDict )
import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
+import Maybe ( isJust )
import DATA_IOREF ( writeIORef )
\end{code}
import DATA_IOREF ( writeIORef )
\end{code}
@@
-269,6
+272,10
@@
badDepMsg mod
-- 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
-- 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
-----------------------------------------------------
addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
@@
-292,7
+299,8
@@
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)
= 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)
+ ; implicit_names <- mapM (mk_new_bndr mod (Just main_name))
+ (ifaceDeclSubBndrs decl)
-- Typecheck the thing, lazily
-- NB. firstly, the laziness is there in case we never need the
-- Typecheck the thing, lazily
-- NB. firstly, the laziness is there in case we never need the
@@
-304,9
+312,12
@@
loadDecl ignore_prags mod (_version, decl)
; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
lookup n = case lookupOccEnv mini_env (getOccName n) of
Just thing -> thing
; 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 (stripped_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
-- 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
@@
-345,12
+356,12
@@
ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
--
-- If you change this, make sure you change HscTypes.implicitTyThings in sync
--
-- 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] ++
= 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
[mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
where
n_ctxt = length sc_ctxt
@@
-359,7
+370,7
@@
ifaceDeclSubBndrs IfaceClass { ifCtxt = sc_ctxt,
dc_occ = mkClassDataConOcc cls_occ
co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
| otherwise = []
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
| otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
is_newtype = n_sigs + n_ctxt == 1 -- Sigh
@@
-369,13
+380,18
@@
ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ,
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
= 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]
where
dc_occs con_decl
| has_wrapper = [con_occ, work_occ, wrap_occ]
@@
-386,9
+402,16
@@
ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
wrap_occ = mkDataConWrapperOcc con_occ
work_occ = mkDataConWorkerOcc con_occ
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
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 = []
-- ToDo: may miss strictness in existential dicts
ifaceDeclSubBndrs _other = []
+
+-- coercion for data/newtype family instances
+famInstCo Nothing baseOcc = []
+famInstCo (Just (_, _, index)) baseOcc = [mkInstTyTcOcc index baseOcc,
+ mkInstTyCoOcc index baseOcc]
\end{code}
\end{code}