Get of fam inst index in ifaces

[ghc-hetmet.git] / compiler / iface / LoadIface.lhs

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index d3dbd0d..ba72c25 100644 (file)
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -49,9 +49,9 @@ import NameEnv
 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 )
@@ -64,6 +64,7 @@ import BinIface               ( readBinIface, v_IgnoreHiWay )
 import Binary          ( getBinFileWithDict )
 import Panic           ( ghcError, tryMost, showException, GhcException(..) )
 import List            ( nub )
+import Maybe            ( isJust )
 import DATA_IOREF      ( writeIORef )
 \end{code}
 
@@ -300,7 +301,6 @@ loadDecl ignore_prags mod (_version, decl)
          main_name      <- mk_new_bndr mod Nothing (ifName decl)
        ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) 
                                 (ifaceDeclSubBndrs decl)
-        ; at_names       <- mapM (mk_new_bndr mod Nothing) (atNames decl)
 
        -- Typecheck the thing, lazily
        -- NB. firstly, the laziness is there in case we never need the
@@ -317,7 +317,6 @@ loadDecl ignore_prags mod (_version, decl)
                                                  ppr n $$ ppr (stripped_decl))
 
        ; returnM $ (main_name, thing) :  [(n, lookup n) | n <- implicit_names]
-                                      ++ zip at_names (atThings thing)
        }
                -- 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
@@ -336,12 +335,6 @@ loadDecl ignore_prags mod (_version, decl)
                          (importedSrcLoc (showSDoc (ppr (moduleName mod))))
                        -- ToDo: qualify with the package name if necessary
 
-    atNames (IfaceClass {ifATs = ats}) = [ifName at | at <- ats]
-    atNames _                          = []
-
-    atThings (AClass cla) = [ATyCon at | at <- classATs cla]
-    atThings _            = []
-
     doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
 
 discardDeclPrags :: IfaceDecl -> IfaceDecl
@@ -363,12 +356,12 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
 --
 -- 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
@@ -387,12 +380,18 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
                              ifCons = IfNewTyCon (
                                         IfCon { ifConOcc = con_occ, 
-                                                ifConFields = fields})})
-  = fields ++ [con_occ, mkDataConWrapperOcc con_occ, mkNewTyCoOcc tc_occ]
+                                                          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]
@@ -403,9 +402,15 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons})
          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}