X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=f1a0d5728cee5a7b69f71822da8ffbc98d5ed5e8;hp=d4548db55a7f469f6d5b598c1e20ccecbfb2f3bc;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=bb106f283663e9c16a4c72ec9ca57109ae57a0ed

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index d4548db..f1a0d57 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -190,20 +190,23 @@ import TyCon		( TyCon, AlgTyConRhs(..), SynTyConRhs(..),
 			  isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
 			  isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
 			  tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
-			  tyConArity, tyConTyVars, algTyConRhs, tyConExtName  )
+			  tyConArity, tyConTyVars, algTyConRhs, tyConExtName,
+			  tyConFamInst_maybe )
 import DataCon		( dataConName, dataConFieldLabels, dataConStrictMarks,
-			  dataConTyCon, dataConIsInfix, dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
-			  dataConTheta, dataConOrigArgTys )
+			  dataConTyCon, dataConIsInfix, dataConUnivTyVars,
+			  dataConExTyVars, dataConEqSpec, dataConTheta,
+			  dataConOrigArgTys ) 
 import Type		( TyThing(..), splitForAllTys, funResultTy )
 import TcType		( deNoteType )
 import TysPrim		( alphaTyVars )
 import InstEnv		( Instance(..) )
 import TcRnMonad
 import HscTypes		( ModIface(..), ModDetails(..), 
-			  ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..),
+			  ModGuts(..), HscEnv(..), hscEPS, Dependencies(..),
+			  FixItem(..), 
 			  ModSummary(..), msHiFilePath, 
 			  mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
-			  typeEnvElts, 
+			  typeEnvElts, mkIfaceFamInstsCache,
 			  GenAvailInfo(..), availName, 
 			  ExternalPackageState(..),
 			  Usage(..), IsBootInterface,
@@ -264,17 +267,18 @@ mkIface :: HscEnv
 				--	    is identical, so no need to write it
 
 mkIface hsc_env maybe_old_iface 
-	(ModGuts{     mg_module  = this_mod,
-		      mg_boot    = is_boot,
-		      mg_usages  = usages,
-		      mg_deps    = deps,
-		      mg_rdr_env = rdr_env,
-		      mg_fix_env = fix_env,
-		      mg_deprecs = src_deprecs })
-	(ModDetails{  md_insts 	 = insts, 
-		      md_rules 	 = rules,
-		      md_types 	 = type_env,
-		      md_exports = exports })
+	(ModGuts{     mg_module   = this_mod,
+		      mg_boot     = is_boot,
+		      mg_usages   = usages,
+		      mg_deps     = deps,
+		      mg_rdr_env  = rdr_env,
+		      mg_fix_env  = fix_env,
+		      mg_deprecs  = src_deprecs })
+	(ModDetails{  md_insts 	  = insts, 
+		      md_fam_insts= _fam_inst,  -- we use the type_env instead
+		      md_rules 	  = rules,
+		      md_types 	  = type_env,
+		      md_exports  = exports })
 	
 -- NB:	notice that mkIface does not look at the bindings
 --	only at the TypeEnv.  The previous Tidy phase has
@@ -292,10 +296,13 @@ mkIface hsc_env maybe_old_iface
 		    	-- Don't put implicit Ids and class tycons in the interface file
 			-- Nor wired-in things; the compiler knows about them anyhow
 
-		; fixities    = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
-		; deprecs     = mkIfaceDeprec src_deprecs
-		; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules
-		; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts
+		; fixities        = [ (occ,fix) 
+				    | FixItem occ fix _ <- nameEnvElts fix_env]
+		; deprecs         = mkIfaceDeprec src_deprecs
+		; iface_rules     = map (coreRuleToIfaceRule 
+					   ext_nm_lhs ext_nm_rhs) rules
+		; iface_insts     = map (instanceToIfaceInst ext_nm_lhs) insts
+		; iface_fam_insts = extractIfFamInsts decls
 
 	        ; intermediate_iface = ModIface { 
 			mi_module   = this_mod,
@@ -304,6 +311,7 @@ mkIface hsc_env maybe_old_iface
 			mi_usages   = usages,
 			mi_exports  = mkIfaceExports exports,
 			mi_insts    = sortLe le_inst iface_insts,
+			mi_fam_insts= mkIfaceFamInstsCache decls,
 			mi_rules    = sortLe le_rule iface_rules,
 			mi_fixities = fixities,
 			mi_deprecs  = deprecs,
@@ -337,8 +345,8 @@ mkIface hsc_env maybe_old_iface
 
 	; return (new_iface, no_change_at_all) }
   where
-     r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
-     i1 `le_inst` i2 = ifDFun     i1 <= ifDFun     i2
+     r1      `le_rule`     r2      = ifRuleName r1 <= ifRuleName r2
+     i1      `le_inst`     i2      = ifDFun     i1 <= ifDFun     i2
 
      dflags = hsc_dflags hsc_env
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
@@ -377,17 +385,17 @@ mkExtNameFn hsc_env eps this_mod
     	occ	 = nameOccName name
     	par_occ  = nameOccName (nameParent name)
     		-- The version of the *parent* is the one want
-    	vers     = lookupVersion mod par_occ
+    	vers     = lookupVersion mod par_occ occ
     	      
-    lookupVersion :: Module -> OccName -> Version
+    lookupVersion :: Module -> OccName -> OccName -> Version
 	-- Even though we're looking up a home-package thing, in
 	-- one-shot mode the imported interfaces may be in the PIT
-    lookupVersion mod occ
-      = mi_ver_fn iface occ `orElse` 
-        pprPanic "lookupVers1" (ppr mod <+> ppr occ)
+    lookupVersion mod par_occ occ
+      = mi_ver_fn iface par_occ `orElse` 
+        pprPanic "lookupVers1" (ppr mod <+> ppr par_occ <+> ppr occ)
       where
         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
-	        pprPanic "lookupVers2" (ppr mod <+> ppr occ)
+	        pprPanic "lookupVers2" (ppr mod <+> ppr par_occ <+> ppr occ)
 
 
 ---------------------
@@ -1033,7 +1041,8 @@ tyThingToIfaceDecl ext (ATyCon tycon)
 		ifCons    = ifaceConDecls (algTyConRhs tycon),
 	  	ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
 		ifGadtSyntax = isGadtSyntaxTyCon tycon,
-		ifGeneric = tyConHasGenerics tycon }
+		ifGeneric = tyConHasGenerics tycon,
+		ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
 
   | isForeignTyCon tycon
   = IfaceForeign { ifName    = getOccName tycon,
@@ -1047,7 +1056,8 @@ tyThingToIfaceDecl ext (ATyCon tycon)
 		ifCons    = IfAbstractTyCon,
 		ifGadtSyntax = False,
 		ifGeneric = False,
-		ifRec     = NonRecursive}
+		ifRec     = NonRecursive,
+		ifFamInst = Nothing }
 
   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
   where
@@ -1075,12 +1085,20 @@ tyThingToIfaceDecl ext (ATyCon tycon)
 		    ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
 		    ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
 		    ifConCtxt    = toIfaceContext ext (dataConTheta data_con),
-		    ifConArgTys  = map (toIfaceType ext) (dataConOrigArgTys data_con),
-		    ifConFields  = map getOccName (dataConFieldLabels data_con),
+		    ifConArgTys  = map (toIfaceType ext) 
+				       (dataConOrigArgTys data_con),
+		    ifConFields  = map getOccName 
+				       (dataConFieldLabels data_con),
 		    ifConStricts = dataConStrictMarks data_con }
 
     to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec]
 
+    famInstToIface Nothing                    = Nothing
+    famInstToIface (Just (famTyCon, instTys)) = 
+      Just $ IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext famTyCon
+			  , ifFamInstTys   = map (toIfaceType ext) instTys
+			  }
+
 tyThingToIfaceDecl ext (ADataCon dc)
  = pprPanic "toIfaceDecl" (ppr dc)	-- Should be trimmed out earlier