X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=d4cd503ffef282b2c1c9b117732702ca0abf98dd;hp=d3dbd0d4eac9161b84c7729742bffb9b1d41a165;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=a1899edb87b3192f192980f392680df05f50f104

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index d3dbd0d..d4cd503 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -20,8 +20,9 @@ import {-# SOURCE #-}	TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst )
 
 import DynFlags		( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
 import IfaceSyn		( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
-			  IfaceConDecls(..), IfaceIdInfo(..) )
-import IfaceEnv		( newGlobalBinder )
+			  IfaceConDecls(..), IfaceFamInst(..), 
+			  IfaceIdInfo(..) )
+import IfaceEnv		( newGlobalBinder, lookupIfaceTc )
 import HscTypes		( ModIface(..), TyThing, IfaceExport, Usage(..), 
 			  Deprecs(..), Dependencies(..),
 			  emptyModIface, EpsStats(..), GenAvailInfo(..),
@@ -36,7 +37,6 @@ import BasicTypes	( Version, initialVersion,
 			  Fixity(..), FixityDirection(..), isMarkedStrict )
 import TcRnMonad
 import Type             ( TyThing(..) )
-import Class		( classATs )
 
 import PrelNames	( gHC_PRIM )
 import PrelInfo		( ghcPrimExports )
@@ -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, 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}
 
@@ -194,7 +195,6 @@ loadInterface doc_str mod from
 
 	-- 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
@@ -207,7 +207,7 @@ loadInterface doc_str mod from
 		; 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...
@@ -289,18 +289,20 @@ loadDecls ignore_prags ver_decls
 	; 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)) 
+	; 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)
-        ; 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 +319,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,11 +337,10 @@ 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 _            = []
+    ifFamily (IfaceData {
+	        ifFamInst = Just (IfaceFamInst {ifFamInstTyCon = famTyCon})})
+               = Just famTyCon
+    ifFamily _ = Nothing
 
     doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
 
@@ -363,12 +363,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 +387,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 +409,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}