X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=6053098c6fb645d42928e800ce7d88a3a2ac3d36;hp=5083044a6fe3443b1cb6a6ff890ab66cbe867966;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=bd865113a1446bb18fb32b546b8776b846a23116

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 5083044..6053098 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -15,9 +15,8 @@ module RnSource (
 import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn
-import RdrName		( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc, 
-			  elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..),
-			  isLocalGRE )
+import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, 
+			  globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
 import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
@@ -43,7 +42,7 @@ import SrcLoc		( Located(..), unLoc, noLoc )
 import DynFlags	( DynFlag(..) )
 import Maybes		( seqMaybe )
 import Maybe            ( isNothing, isJust )
-import Monad		( liftM )
+import Monad		( liftM, when )
 import BasicTypes       ( Boxity(..) )
 \end{code}
 
@@ -111,10 +110,8 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
 	   <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 	
 	let {
-           rn_at_decls = concat 
-			   [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ;
 	   rn_group = HsGroup { hs_valds  = rn_val_decls,
-			    	hs_tyclds = rn_tycl_decls ++ rn_at_decls,
+			    	hs_tyclds = rn_tycl_decls,
 			    	hs_instds = rn_inst_decls,
 			    	hs_fixds  = rn_fix_decls,
 			    	hs_depds  = [],
@@ -282,12 +279,11 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the declarations are for the right class
     let
-	at_doc   = text "In the associated types in an instance declaration"
+	at_doc   = text "In the associated types of an instance declaration"
 	at_names = map (head . tyClDeclNames . unLoc) ats
-	(_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty)
     in
     checkDupNames at_doc at_names		`thenM_`
-    rnATDefs rdrCtxt ats			`thenM` \ (ats', at_fvs) ->
+    rnATInsts ats				`thenM` \ (ats', at_fvs) ->
 
 	-- Rename the bindings
 	-- The typechecker (not the renamer) checks that all 
@@ -333,30 +329,26 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	     --     to remove the context).
 \end{code}
 
-Renaming of the associated type definitions in instances.  
+Renaming of the associated types in instances.  
 
-* In the case of associated data and newtype definitions we add the instance
-  context.
 * We raise an error if we encounter a kind signature in an instance.
 
 \begin{code}
-rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] 
-	  -> RnM ([LTyClDecl Name], FreeVars)
-rnATDefs ctxt atDecls = 
-  mapFvRn (wrapLocFstM rnAtDef) atDecls
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls = 
+  mapFvRn (wrapLocFstM rnATInst) atDecls
   where
-    rnAtDef tydecl@TyFunction {}                 = 
+    rnATInst tydecl@TyFunction {} = 
       do
         addErr noKindSig
 	rnTyClDecl tydecl
-    rnAtDef tydecl@TySynonym  {}                 = rnTyClDecl tydecl
-    rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} = 
+    rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
+    rnATInst tydecl@TyData     {} = 
       do
         checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
-        rnTyClDecl (tydecl {tcdCtxt = L l (ctxt ++ tyCtxt)})
-          -- The source loc is somewhat half hearted... -=chak
-    rnAtDef _ =
-      panic "RnSource.rnATDefs: not a type declaration"
+        rnTyClDecl tydecl
+    rnATInst _                    =
+      panic "RnSource.rnATInsts: not a type declaration"
 
 noKindSig = text "Instances cannot have kind signatures"
 \end{code}
@@ -513,7 +505,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
@@ -526,11 +520,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')
@@ -544,8 +544,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
@@ -568,15 +572,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)
 
@@ -763,7 +774,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, 
@@ -774,7 +786,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"
@@ -794,8 +807,11 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
         rnTyClDecl tydecl
     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 
-    lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
-    --
+    lookupIdxVars _ tyvars cont = 
+      do { checkForDups tyvars;
+	 ; tyvars' <- mappM lookupIdxVar tyvars
+	 ; cont tyvars'
+	 }
     -- Type index variables must be class parameters, which are the only
     -- type variables in scope at this point.
     lookupIdxVar (L l tyvar) =
@@ -803,9 +819,27 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 	name' <- lookupOccRn (hsTyVarName tyvar)
 	return $ L l (replaceTyVarName tyvar name')
 
+    -- Type variable may only occur once.
+    --
+    checkForDups [] = return ()
+    checkForDups (L loc tv:ltvs) = 
+      do { setSrcSpan loc $
+	     when (hsTyVarName tv `ltvElem` ltvs) $
+	       addErr (repeatedTyVar tv)
+	 ; checkForDups ltvs
+	 }
+
+    rdrName `ltvElem` [] = False
+    rdrName `ltvElem` (L _ tv:ltvs)
+      | rdrName == hsTyVarName tv = True
+      | otherwise		  = rdrName `ltvElem` ltvs
+
 noPatterns = text "Default definition for an associated synonym cannot have"
 	     <+> text "type pattern"
 
+repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
+		   quotes (ppr tv)
+
 -- This data decl will parse OK
 --	data T = a Int
 -- treating "a" as the constructor.