X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=6c197cc0cf28e4b592ae0486e249e310161d730b;hb=a1899edb87b3192f192980f392680df05f50f104;hp=1f3c5d4b4349f50bd36efe3697ab0e76bb05cba4;hpb=7bb6c5b2827a3af0fb9188bb000997ac59c10122;p=ghc-hetmet.git

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 1f3c5d4..6c197cc 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -19,8 +19,10 @@ import IfaceEnv		( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
 			  extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
 			  tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, 
 			  newIfaceName, newIfaceNames, ifaceExportNames )
-import BuildTyCl	( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
-			  mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
+import BuildTyCl	( buildSynTyCon, buildAlgTyCon, buildDataCon,
+			  buildClass, 
+			  mkAbstractTyConRhs, mkOpenDataTyConRhs,
+			  mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad
 import Type		( liftedTypeKind, splitTyConApp, mkTyConApp,
                           liftedTypeKindTyCon, unliftedTypeKindTyCon, 
@@ -28,7 +30,8 @@ import Type		( liftedTypeKind, splitTyConApp, mkTyConApp,
                           ubxTupleKindTyCon,
 			  mkTyVarTys, ThetaType )
 import TypeRep		( Type(..), PredType(..) )
-import TyCon		( TyCon, tyConName )
+import TyCon		( TyCon, tyConName, SynTyConRhs(..), 
+			  AlgTyConParent(..), setTyConArgPoss )
 import HscTypes		( ExternalPackageState(..), 
 			  TyThing(..), tyThingClass, tyThingTyCon, 
 			  ModIface(..), ModDetails(..), HomeModInfo(..),
@@ -66,6 +69,9 @@ import SrcLoc		( noSrcLoc )
 import Util		( zipWithEqual, equalLength, splitAtList )
 import DynFlags		( DynFlag(..), isOneShot )
 
+import List		( elemIndex)
+import Maybe		( catMaybes )
+import Monad		( liftM )
 \end{code}
 
 This module takes
@@ -356,30 +362,42 @@ 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 (fam, 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)
     }}
 
 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-		       ifSynRhs = rdr_rhs_ty})
+		       ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
-     ; rhs_ty <- tcIfaceType rdr_rhs_ty
-     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
+     ; rhs_tyki <- tcIfaceType rdr_rhs_ty
+     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki 
+			   else SynonymTyCon rhs_tyki
+     ; 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
@@ -388,7 +406,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)
@@ -405,6 +425,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 
@@ -413,6 +446,8 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
 	IfAbstractTyCon	 -> return mkAbstractTyConRhs
+	IfOpenDataTyCon	 -> return mkOpenDataTyConRhs
+	IfOpenNewTyCon	 -> return mkOpenNewTyConRhs
 	IfDataTyCon cons -> do 	{ data_cons <- mappM tc_con_decl cons
 				; return (mkDataTyConRhs data_cons) }
 	IfNewTyCon con	 -> do 	{ data_con <- tc_con_decl con