X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=20aaa9fca8db18a489bd37073339a6f92841b1d3;hp=08dfe8c531aa401ae8d03ffd354f6c2fc99c91d8;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 08dfe8c..20aaa9f 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -27,14 +27,14 @@ import TcRnMonad
 import Type		( liftedTypeKind, splitTyConApp, mkTyConApp,
                           liftedTypeKindTyCon, unliftedTypeKindTyCon, 
                           openTypeKindTyCon, argTypeKindTyCon, 
-                          ubxTupleKindTyCon,
-			  mkTyVarTys, ThetaType )
+                          ubxTupleKindTyCon, ThetaType )
 import TypeRep		( Type(..), PredType(..) )
-import TyCon		( TyCon, tyConName, SynTyConRhs(..) )
+import TyCon		( TyCon, tyConName, SynTyConRhs(..), setTyConArgPoss )
 import HscTypes		( ExternalPackageState(..), 
 			  TyThing(..), tyThingClass, tyThingTyCon, 
 			  ModIface(..), ModDetails(..), HomeModInfo(..),
-			  emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
+			  emptyModDetails, lookupTypeEnv, lookupType,
+			  typeEnvIds, mkDetailsFamInstCache )
 import InstEnv		( Instance(..), mkImportedInstance )
 import CoreSyn
 import CoreUtils	( exprType, dataConRepFSInstPat )
@@ -49,9 +49,9 @@ import IdInfo		( IdInfo, CafInfo(..), WorkerInfo(..),
 			  vanillaIdInfo, newStrictnessInfo )
 import Class		( Class )
 import TyCon		( tyConDataCons, isTupleTyCon, mkForeignTyCon )
-import DataCon		( DataCon, dataConWorkId, dataConExTyVars, dataConInstArgTys )
+import DataCon		( DataCon, dataConWorkId )
 import TysWiredIn	( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
-import Var		( TyVar, mkTyVar, tyVarKind )
+import Var		( TyVar, mkTyVar )
 import Name		( Name, nameModule, nameIsLocalOrFrom, isWiredInName,
  			  nameOccName, wiredInNameTyThing_maybe )
 import NameEnv
@@ -65,9 +65,11 @@ import Outputable
 import ErrUtils		( Message )
 import Maybes		( MaybeErr(..) )
 import SrcLoc		( noSrcLoc )
-import Util		( zipWithEqual, equalLength, splitAtList )
+import Util		( zipWithEqual, equalLength )
 import DynFlags		( DynFlag(..), isOneShot )
 
+import List		( elemIndex)
+import Maybe		( catMaybes )
 \end{code}
 
 This module takes
@@ -219,10 +221,12 @@ typecheckIface iface
 	; exports <-  ifaceExportNames (mi_exports iface)
 
 		-- Finished
-	; return (ModDetails {	md_types = type_env, 
-				md_insts = dfuns,
-				md_rules = rules,
-				md_exports = exports }) 
+	; return $ ModDetails { md_types     = type_env
+			      , md_insts     = dfuns
+			      , md_fam_insts = mkDetailsFamInstCache type_env
+			      , md_rules     = rules
+			      , md_exports   = exports 
+			      }
     }
 \end{code}
 
@@ -358,15 +362,26 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
 			ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
 			ifCons = rdr_cons, 
 			ifRec = is_rec, 
-			ifGeneric = want_generic })
+			ifGeneric = want_generic,
+			ifFamInst = mb_family })
   = do	{ tc_name <- lookupIfaceTop occ_name
 	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 
 	{ tycon <- fixM ( \ tycon -> do
 	    { stupid_theta <- tcIfaceCtxt ctxt
-	    ; cons  <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+	    ; famInst <- 
+	        case mb_family of
+		  Nothing         -> return Nothing
+		  Just (IfaceFamInst { ifFamInstTyCon = fam
+				     , ifFamInstTys   = tys
+				     }) -> 
+		    do { famTyCon <- tcIfaceTyCon fam
+		       ; insttys <- mapM tcIfaceType tys
+		       ; return $ Just (famTyCon, insttys)
+		       }
+	    ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
 	    ; buildAlgTyCon tc_name tyvars stupid_theta
-			    cons is_rec want_generic gadt_syn
+			    cons is_rec want_generic gadt_syn famInst
 	    })
         ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
 	; return (ATyCon tycon)
@@ -382,8 +397,9 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
      ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))
      }
 
-tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 
-			 ifFDs = rdr_fds, ifSigs = rdr_sigs, 
+tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
+			 ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
+			 ifATs = rdr_ats, ifSigs = rdr_sigs, 
 			 ifRec = tc_isrec })
 -- ToDo: in hs-boot files we should really treat abstract classes specially,
 --	 as we do abstract tycons
@@ -392,7 +408,9 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
     ; ctxt <- tcIfaceCtxt rdr_ctxt
     ; sigs <- mappM tc_sig rdr_sigs
     ; fds  <- mappM tc_fd rdr_fds
-    ; cls  <- buildClass cls_name tyvars ctxt fds sigs tc_isrec
+    ; ats'  <- mappM tcIfaceDecl rdr_ats
+    ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
+    ; cls  <- buildClass cls_name tyvars ctxt fds ats sigs tc_isrec
     ; return (AClass cls) }
   where
    tc_sig (IfaceClassOp occ dm rdr_ty)
@@ -409,6 +427,19 @@ tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bnd
 			   ; tvs2' <- mappM tcIfaceTyVar tvs2
 			   ; return (tvs1', tvs2') }
 
+   -- For each AT argument compute the position of the corresponding class
+   -- parameter in the class head.  This will later serve as a permutation
+   -- vector when checking the validity of instance declarations.
+   setTyThingPoss (ATyCon tycon) atTyVars = 
+     let classTyVars = map fst tv_bndrs
+	 poss        =   catMaybes 
+		       . map ((`elemIndex` classTyVars) . fst) 
+		       $ atTyVars
+		    -- There will be no Nothing, as we already passed renaming
+     in 
+     ATyCon (setTyConArgPoss tycon poss)
+   setTyThingPoss _		  _ = panic "TcIface.setTyThingPoss"
+
 tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
   = do	{ name <- lookupIfaceTop rdr_name
 	; return (ATyCon (mkForeignTyCon name ext_name