Fixed two bugs concerning fanilies

Mon Sep 18 19:34:38 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fixed two bugs concerning fanilies
  Mon Sep  4 20:59:49 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fixed two bugs concerning fanilies

compiler/iface/LoadIface.lhs

@@ -35,6 +35,8 @@ import HscTypes		( ModIface(..), TyThing, IfaceExport, Usage(..),
 import BasicTypes	( Version, initialVersion,
 			  Fixity(..), FixityDirection(..), isMarkedStrict )
 import TcRnMonad
+import Type             ( TyThing(..) )
+import Class		( classATs )
 
 import PrelNames	( gHC_PRIM )
 import PrelInfo		( ghcPrimExports )
@@ -269,6 +271,10 @@ badDepMsg mod
 -- each binder with the right package info in it
 -- All subsequent lookups, including crucially lookups during typechecking
 -- the declaration itself, will find the fully-glorious Name
+--
+-- We handle ATs specially.  They are not main declarations, but also not
+-- implict things (in particular, adding them to `implicitTyThings' would mess
+-- things up in the renaming/type checking of source programs).
 -----------------------------------------------------
 
 addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
@@ -292,7 +298,9 @@ 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)) (ifaceDeclSubBndrs decl)
+	; implicit_names <- mapM (mk_new_bndr mod (Just main_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
@@ -304,9 +312,13 @@ loadDecl ignore_prags mod (_version, decl)
 	; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
 	      lookup n = case lookupOccEnv mini_env (getOccName n) of
 			   Just thing -> thing
-			   Nothing    -> pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (stripped_decl) )
+			   Nothing    -> 
+			     pprPanic "loadDecl" (ppr main_name <+> 
+						  ppr n $$ ppr (stripped_decl))
 
-	; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) }
+	; 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
 		-- thunks
@@ -324,6 +336,12 @@ 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 _            = []
+
     doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
 
 discardDeclPrags :: IfaceDecl -> IfaceDecl

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}
 
@@ -393,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
@@ -403,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)
@@ -420,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 

compiler/rename/RnSource.lhs

@@ -506,7 +506,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
   = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
 				-- data type is syntactically illegal
     bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
-    do	{ tycon' <- lookupLocatedTopBndrRn tycon
+    do	{ tycon' <- if isIdxTyDecl tydecl
+		    then lookupLocatedOccRn     tycon -- may be imported family
+		    else lookupLocatedTopBndrRn tycon
 	; context' <- rnContext data_doc context
 	; typats' <- rnTyPats data_doc typatsMaybe
 	; (derivs', deriv_fvs) <- rn_derivs derivs
@@ -519,11 +521,17 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 		   delFVs (map hsLTyVarName tyvars')	$
 	     	   extractHsCtxtTyNames context'	`plusFV`
 	     	   plusFVs (map conDeclFVs condecls')   `plusFV`
-	     	   deriv_fvs) }
+	     	   deriv_fvs				`plusFV`
+		   (if isIdxTyDecl tydecl
+		   then unitFV (unLoc tycon')	-- type instance => use
+		   else emptyFVs)) 
+        }
 
   | otherwise	          -- GADT
   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
-    do	{ tycon' <- lookupLocatedTopBndrRn tycon
+    do	{ tycon' <- if isIdxTyDecl tydecl
+		    then lookupLocatedOccRn     tycon -- may be imported family
+		    else lookupLocatedTopBndrRn tycon
 	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
     	; tyvars' <- bindTyVarsRn data_doc tyvars 
 				  (\ tyvars' -> return tyvars')
@@ -537,8 +545,12 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 			   tcdLName = tycon', tcdTyVars = tyvars', 
 			   tcdTyPats = Nothing, tcdKindSig = sig,
 			   tcdCons = condecls', tcdDerivs = derivs'}, 
-	     	   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
-
+	     	   plusFVs (map conDeclFVs condecls') `plusFV` 
+		   deriv_fvs			      `plusFV`
+		   (if isIdxTyDecl tydecl
+		   then unitFV (unLoc tycon')	-- type instance => use
+		   else emptyFVs))
+        }
   where
     is_vanilla = case condecls of	-- Yuk
 		     [] 		   -> True
@@ -561,15 +573,22 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 rnTyClDecl (tydecl@TyFunction {}) =
   rnTySig tydecl bindTyVarsRn
 
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
-		       tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+			      tcdTyPats = typatsMaybe, tcdSynRhs = ty})
   = bindTyVarsRn syn_doc tyvars		        $ \ tyvars' ->
-    do { name' <- lookupLocatedTopBndrRn name
+    do { name' <- if isIdxTyDecl tydecl
+		  then lookupLocatedOccRn     name -- may be imported family
+		  else lookupLocatedTopBndrRn name
        ; typats' <- rnTyPats syn_doc typatsMaybe
        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
 			     tcdTyPats = typats', tcdSynRhs = ty'},
-	          delFVs (map hsLTyVarName tyvars') fvs) }
+	          delFVs (map hsLTyVarName tyvars') $
+		  fvs			      `plusFV`
+		   (if isIdxTyDecl tydecl
+		   then unitFV (unLoc name')	-- type instance => use
+		   else emptyFVs))
+       }
   where
     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
@@ -756,7 +775,8 @@ rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
 			    tcdTyPats = Nothing, tcdKindSig = sig, 
 			    tcdCons = [], tcdDerivs = Nothing}, 
 		    delFVs (map hsLTyVarName tyvars') $
-	     	    extractHsCtxtTyNames context') } }
+	     	    extractHsCtxtTyNames context') 
+         } }
       where
 
 rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, 
@@ -767,7 +787,8 @@ rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
 	 ; tycon' <- lookupLocatedTopBndrRn tycon
 	 ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
 			        tcdIso = tcdIso tydecl, tcdKind = sig}, 
-		    emptyFVs) } }
+		    emptyFVs) 
+         } }
 
 ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
 needOneIdx = text "Kind signature requires at least one type index"

compiler/typecheck/TcTyClsDecls.lhs

@@ -737,6 +737,9 @@ tcTyClDecl1 calc_isrec
 				; tvs2' <- mappM tcLookupTyVar 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 = hsLTyVarNames tvs
 	  poss        =   catMaybes 
@@ -746,8 +749,7 @@ tcTyClDecl1 calc_isrec
 		     -- There will be no Nothing, as we already passed renaming
       in 
       ATyCon (setTyConArgPoss tycon poss)
-    setTyThingPoss _		  _ = panic "setTyThingPoss"
-
+    setTyThingPoss _		  _ = panic "TcTyClsDecls.setTyThingPoss"
 
 tcTyClDecl1 calc_isrec 
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})