Fixed two bugs concerning fanilies

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

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 388d040..6c197cc 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -31,7 +31,7 @@ import Type           ( liftedTypeKind, splitTyConApp, mkTyConApp,
                          mkTyVarTys, ThetaType )
 import TypeRep         ( Type(..), PredType(..) )
 import TyCon           ( TyCon, tyConName, SynTyConRhs(..), 
-                         AlgTyConParent(..) )
+                         AlgTyConParent(..), setTyConArgPoss )
 import HscTypes                ( ExternalPackageState(..), 
                          TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), HomeModInfo(..),
@@ -69,6 +69,8 @@ import SrcLoc         ( noSrcLoc )
 import Util            ( zipWithEqual, equalLength, splitAtList )
 import DynFlags                ( DynFlag(..), isOneShot )
 
+import List            ( elemIndex)
+import Maybe           ( catMaybes )
 import Monad           ( liftM )
 \end{code}
 
@@ -361,21 +363,23 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
                        ifCons = rdr_cons, 
                        ifRec = is_rec, 
                        ifGeneric = want_generic,
-                       ifFamily = mb_family })
+                       ifFamInst = mb_family })
   = do { tc_name <- lookupIfaceTop occ_name
        ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 
        { tycon <- fixM ( \ tycon -> do
            { stupid_theta <- tcIfaceCtxt ctxt
+           ; 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
-           ; family <- case mb_family of
-                         Nothing  -> return Nothing
-                         Just fam -> 
-                           do { famTyCon <- tcIfaceTyCon fam
-                              ; return $ Just famTyCon
-                              }
            ; buildAlgTyCon tc_name tyvars stupid_theta
-                           cons is_rec want_generic gadt_syn family
+                           cons is_rec want_generic gadt_syn famInst
            })
         ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
        ; return (ATyCon tycon)
@@ -391,8 +395,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
@@ -401,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)
@@ -418,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 
@@ -437,7 +457,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
                         ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
                         ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
                         ifConArgTys = args, ifConFields = field_lbls,
-                        ifConStricts = stricts, ifConInstTys = mb_insttys })
+                        ifConStricts = stricts})
       = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
        bindIfaceTyVars ex_tvs   $ \ ex_tyvars -> do
        { name  <- lookupIfaceTop occ
@@ -456,17 +476,12 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
        -- the component types unless they are really needed
        ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
        ; lbl_names <- mappM lookupIfaceTop field_lbls
-       ; mb_insttys' <- case mb_insttys of 
-                          Nothing      -> return Nothing 
-                          Just insttys -> liftM Just $ 
-                                            mappM tcIfaceType insttys
 
        ; buildDataCon name is_infix {- Not infix -}
                       stricts lbl_names
                       univ_tyvars ex_tyvars 
                        eq_spec theta 
                       arg_tys tycon
-                      mb_insttys'
        }
     mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name