Avoid nasty name clash with associated data types (fixes Trac #2888)

The main bug was in TcHsType; see Note [Avoid name clashes for
associated data types].  However I did a bit of re-factoring while
I was abouut it.

I'm still a but unhappy with the use of TyCon.setTyConArgPoss; it'd
be better to construct the TyCon correctly in the first place.  But
that means passing an extra parameter to tcTyDecl1... maybe we should
do this.

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 6f56d4f..b8c04d3 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -8,7 +8,7 @@ module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
        mkAbstractTyConRhs, mkOpenDataTyConRhs, 
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
        mkAbstractTyConRhs, mkOpenDataTyConRhs, 

-       mkNewTyConRhs, mkDataTyConRhs 
+       mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -175,6 +175,13 @@ mkNewTyConRhs tycon_name tycon con
     eta_reduce tvs ty = (reverse tvs, ty)
                                
 
     eta_reduce tvs ty = (reverse tvs, ty)
                                
 

+setAssocFamilyPermutation :: [TyVar] -> TyThing -> TyThing
+setAssocFamilyPermutation clas_tvs (ATyCon tc) 
+  = ATyCon (setTyConArgPoss clas_tvs tc)
+setAssocFamilyPermutation _clas_tvs other
+  = pprPanic "setAssocFamilyPermutation" (ppr other)
+
+

 ------------------------------------------------------
 buildDataCon :: Name -> Bool
            -> [StrictnessMark] 
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
            -> [StrictnessMark] 

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 7f74cf2..28b0311 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -427,7 +427,7 @@ tcIfaceDecl ignore_prags
     ; sigs <- mapM tc_sig rdr_sigs
     ; fds  <- mapM tc_fd rdr_fds
     ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
     ; sigs <- mapM tc_sig rdr_sigs
     ; fds  <- mapM tc_fd rdr_fds
     ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats

-    ; let ats = zipWith setTyThingPoss ats' (map ifTyVars rdr_ats)
+    ; let ats = map (setAssocFamilyPermutation tyvars) ats'

     ; cls  <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
     ; return (AClass cls) }
   where
     ; cls  <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
     ; return (AClass cls) }
   where

@@ -445,19 +445,6 @@ tcIfaceDecl ignore_prags
                           ; tvs2' <- mapM tcIfaceTyVar tvs2
                           ; return (tvs1', tvs2') }
 
                           ; tvs2' <- mapM 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 
 tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
   = do { name <- lookupIfaceTop rdr_name
        ; return (ATyCon (mkForeignTyCon name ext_name 

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 8ea9b13..e158763 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -677,15 +677,17 @@ tcDataKindSig (Just kind)
        ; us   <- newUniqueSupply 
        ; let uniqs = uniqsFromSupply us
        ; return [ mk_tv span uniq str kind 
        ; us   <- newUniqueSupply 
        ; let uniqs = uniqsFromSupply us
        ; return [ mk_tv span uniq str kind 

-                | ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] }
+                | ((kind, str), uniq) <- arg_kinds `zip` dnames `zip` uniqs ] }

   where
     (arg_kinds, res_kind) = splitKindFunTys kind
     mk_tv loc uniq str kind = mkTyVar name kind
        where
           name = mkInternalName uniq occ loc
           occ  = mkOccName tvName str
   where
     (arg_kinds, res_kind) = splitKindFunTys kind
     mk_tv loc uniq str kind = mkTyVar name kind
        where
           name = mkInternalName uniq occ loc
           occ  = mkOccName tvName str

+         
+    dnames = map ('$' :) names -- Note [Avoid name clashes for associated data types]

 
 

-    names :: [String]  -- a,b,c...aa,ab,ac etc
+    names :: [String]

     names = [ c:cs | cs <- "" : names, c <- ['a'..'z'] ] 
 
 badKindSig :: Kind -> SDoc
     names = [ c:cs | cs <- "" : names, c <- ['a'..'z'] ] 
 
 badKindSig :: Kind -> SDoc

@@ -694,6 +696,24 @@ badKindSig kind
        2 (ppr kind)
 \end{code}
 
        2 (ppr kind)
 \end{code}
 

+Note [Avoid name clashes for associated data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider    class C a b where
+               data D b :: * -> *
+When typechecking the decl for D, we'll invent an extra type variable for D,
+to fill out its kind.  We *don't* want this type variable to be 'a', because
+in an .hi file we'd get
+            class C a b where
+               data D b a 
+which makes it look as if there are *two* type indices.  But there aren't!
+So we use $a instead, which cannot clash with a user-written type variable.
+Remember that type variable binders in interface files are just FastStrings,
+not proper Names.
+
+(The tidying phase can't help here because we don't tidy TyCons.  Another
+alternative would be to record the number of indexing parameters in the 
+interface file.)
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 14c96ae..baa7515 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -461,11 +461,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
            ; mapM_ (checkIndexes clas inst_tys) ats
            }
 
            ; mapM_ (checkIndexes clas inst_tys) ats
            }
 

-    checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
+    checkIndexes clas inst_tys (hsAT, ATyCon tycon)

 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!

-      checkIndexes' clas inst_tys hsAT
-                    (tyConTyVars tycon,
-                     snd . fromJust . tyConFamInst_maybe $ tycon)
+      = checkIndexes' clas inst_tys hsAT
+                      (tyConTyVars tycon,
+                       snd . fromJust . tyConFamInst_maybe $ tycon)

     checkIndexes _ _ _ = panic "checkIndexes"
 
     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
     checkIndexes _ _ _ = panic "checkIndexes"
 
     checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)

@@ -475,8 +475,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         addErrCtxt (atInstCtxt atName) $
         case find ((atName ==) . tyConName) (classATs clas) of
           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
         addErrCtxt (atInstCtxt atName) $
         case find ((atName ==) . tyConName) (classATs clas) of
           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class

-          Just atDecl ->
-            case assocTyConArgPoss_maybe atDecl of
+          Just atycon ->
+            case assocTyConArgPoss_maybe atycon of

               Nothing   -> panic "checkIndexes': AT has no args poss?!?"
               Just poss ->
 
               Nothing   -> panic "checkIndexes': AT has no args poss?!?"
               Just poss ->
 

@@ -487,6 +487,13 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                 -- which must be type variables; and (3) variables in AT and
                 -- instance head will be different `Name's even if their
                 -- source lexemes are identical.
                 -- which must be type variables; and (3) variables in AT and
                 -- instance head will be different `Name's even if their
                 -- source lexemes are identical.

+               --
+               -- e.g.    class C a b c where 
+               --           data D b a :: * -> *           -- NB (1) b a, omits c
+               --         instance C [x] Bool Char where 
+               --           data D Bool [x] v = MkD x [v]  -- NB (2) v
+               --                -- NB (3) the x in 'instance C...' have differnt
+               --                --        Names to x's in 'data D...'

                 --
                 -- Re (1), `poss' contains a permutation vector to extract the
                 -- class parameters in the right order.
                 --
                 -- Re (1), `poss' contains a permutation vector to extract the
                 -- class parameters in the right order.

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 69a984d..2d68a6e 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -667,17 +667,18 @@ tcTyClDecl calc_isrec decl
 tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
 tcTyClDecl1 _calc_isrec 
   (TyFamily {tcdFlavour = TypeFamily, 
 tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
 tcTyClDecl1 _calc_isrec 
   (TyFamily {tcdFlavour = TypeFamily, 

-            tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind})
-                                                     -- NB: kind at latest
-                                                     --     added during
-                                                     --     kind checking
+            tcdLName = L _ tc_name, tcdTyVars = tvs,
+             tcdKind = Just kind}) -- NB: kind at latest added during kind checking

   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "type family: " <+> ppr tc_name) 
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "type family: " <+> ppr tc_name) 

-  ; idx_tys <- doptM Opt_TypeFamilies

 
        -- Check that we don't use families without -XTypeFamilies
 
        -- Check that we don't use families without -XTypeFamilies

+  ; idx_tys <- doptM Opt_TypeFamilies

   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; checkTc idx_tys $ badFamInstDecl tc_name
 

+        -- Check for no type indices
+  ; checkTc (not (null tvs)) (noIndexTypes tc_name)
+

   ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
   ; return [ATyCon tycon]
   }
   ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
   ; return [ATyCon tycon]
   }

@@ -691,11 +692,14 @@ tcTyClDecl1 _calc_isrec
   ; extra_tvs <- tcDataKindSig mb_kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
   ; extra_tvs <- tcDataKindSig mb_kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 

-  ; idx_tys <- doptM Opt_TypeFamilies

 
        -- Check that we don't use families without -XTypeFamilies
 
        -- Check that we don't use families without -XTypeFamilies

+  ; idx_tys <- doptM Opt_TypeFamilies

   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; checkTc idx_tys $ badFamInstDecl tc_name
 

+        -- Check for no type indices
+  ; checkTc (not (null tvs)) (noIndexTypes tc_name)
+

   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
               mkOpenDataTyConRhs Recursive False True Nothing
   ; return [ATyCon tycon]
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
               mkOpenDataTyConRhs Recursive False True Nothing
   ; return [ATyCon tycon]

@@ -771,7 +775,7 @@ tcTyClDecl1 calc_isrec
   ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats
             -- NB: 'ats' only contains "type family" and "data family"
             --     declarations as well as type family defaults
   ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats
             -- NB: 'ats' only contains "type family" and "data family"
             --     declarations as well as type family defaults

-  ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats)
+  ; let ats' = map (setAssocFamilyPermutation tvs') (concat atss)

   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
                let     -- This little knot is just so we can get
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
                let     -- This little knot is just so we can get

@@ -792,20 +796,6 @@ tcTyClDecl1 calc_isrec
                                ; tvs2' <- mapM tcLookupTyVar tvs2 ;
                                ; return (tvs1', tvs2') }
 
                                ; tvs2' <- mapM 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 
-                       . map (`elemIndex` classTyVars) 
-                       . hsLTyVarNames 
-                       $ atTyVars
-                    -- There will be no Nothing, as we already passed renaming
-      in 
-      ATyCon (setTyConArgPoss tycon poss)
-    setTyThingPoss _             _ = panic "TcTyClsDecls.setTyThingPoss"
-

 tcTyClDecl1 _
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
   = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
 tcTyClDecl1 _
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
   = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]

@@ -1312,6 +1302,11 @@ badSigTyDecl tc_name
           quotes (ppr tc_name)
         , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
 
           quotes (ppr tc_name)
         , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
 

+noIndexTypes :: Name -> SDoc
+noIndexTypes tc_name
+  = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name)
+    <+> ptext (sLit "must have at least one type index parameter")
+

 badFamInstDecl :: Outputable a => a -> SDoc
 badFamInstDecl tc_name
   = vcat [ ptext (sLit "Illegal family instance for") <+>
 badFamInstDecl :: Outputable a => a -> SDoc
 badFamInstDecl tc_name
   = vcat [ ptext (sLit "Illegal family instance for") <+>

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 256b141..fdd21be 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -13,6 +13,7 @@ module TyCon(
        AlgTyConRhs(..), visibleDataCons, 
         TyConParent(..), 
        SynTyConRhs(..),
        AlgTyConRhs(..), visibleDataCons, 
         TyConParent(..), 
        SynTyConRhs(..),

+       AssocFamilyPermutation,

 
         -- ** Constructing TyCons
        mkAlgTyCon,
 
         -- ** Constructing TyCons
        mkAlgTyCon,

@@ -92,6 +93,7 @@ import Maybes
 import Outputable
 import FastString
 import Constants
 import Outputable
 import FastString
 import Constants

+import Data.List( elemIndex )

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -260,17 +262,7 @@ data AlgTyConRhs
   -- >   data T b :: *
 
   | OpenTyCon {
   -- >   data T b :: *
 
   | OpenTyCon {

-
-      otArgPoss   :: Maybe [Int]
-       -- ^ @Nothing@ iff this is a top-level indexed type family.
-       -- @Just ns@ iff this is an associated (not top-level) family
-       --
-       -- In the latter case, for each 'TyVar' in the associated type declaration, 
-       -- @ns@ gives the position of that tyvar in the class argument list (starting 
-       -- from 0).
-       --
-       -- NB: The length of this list is less than the accompanying 'tyConArity' iff 
-       -- we have a higher kind signature.
+      otArgPoss :: AssocFamilyPermutation

     }
 
   -- | Information about those 'TyCon's derived from a @data@ declaration. This includes 
     }
 
   -- | Information about those 'TyCon's derived from a @data@ declaration. This includes 

@@ -316,6 +308,18 @@ data AlgTyConRhs
                                -- again check Trac #1072.
     }
 
                                -- again check Trac #1072.
     }
 

+type AssocFamilyPermutation
+  = Maybe [Int]  -- Nothing for *top-level* type families
+                 -- For *associated* type families, gives the position
+                -- of that 'TyVar' in the class argument list (0-indexed)
+                -- e.g.  class C a b c where { type F c a :: *->* }
+                 --       Then we get Just [2,0]
+        -- For *synonyms*, the length of the list is identical to
+        --                 the TyCon's arity
+        -- For *data types*, the length may be smaller than the
+        --     TyCon's arity; e.g. class C a where { data D a :: *->* }
+        --                    here D gets arity 2
+

 -- | Extract those 'DataCon's that we are able to learn about. Note that visibility in this sense does not
 -- correspond to visibility in the context of any particular user program!
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 -- | Extract those 'DataCon's that we are able to learn about. Note that visibility in this sense does not
 -- correspond to visibility in the context of any particular user program!
 visibleDataCons :: AlgTyConRhs -> [DataCon]

@@ -369,16 +373,10 @@ okParent _       (FamilyTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length t
 
 -- | Information pertaining to the expansion of a type synonym (@type@)
 data SynTyConRhs
 
 -- | Information pertaining to the expansion of a type synonym (@type@)
 data SynTyConRhs

-  = OpenSynTyCon Kind          
-                (Maybe [Int])  -- ^ A Type family synonym. The /result/ 'Kind' is
-                               -- given for associated families, and in this case the
-                               -- list of @Int@s is not empty, and for each 'TyVar' in
-                               -- the associated type declaration, it gives the position
-                               -- of that 'TyVar' in the class argument list (starting
-                               -- from 0). 
-                               --
-                               -- NB: The length of this list will be less than 'tyConArity' iff
-                               -- the family has a higher kind signature.
+  = OpenSynTyCon      -- e.g. type family F x y :: * -> *
+       Kind          -- Kind of the "rhs"; ie *excluding type indices*
+                             --     In the example, the kind is (*->*)
+       AssocFamilyPermutation

 
   | SynonymTyCon Type   -- ^ The synonym mentions head type variables. It acts as a
                        -- template for the expansion when the 'TyCon' is applied to some
 
   | SynonymTyCon Type   -- ^ The synonym mentions head type variables. It acts as a
                        -- template for the expansion when the 'TyCon' is applied to some

@@ -836,14 +834,22 @@ assocTyConArgPoss_maybe _ = Nothing
 isTyConAssoc :: TyCon -> Bool
 isTyConAssoc = isJust . assocTyConArgPoss_maybe
 
 isTyConAssoc :: TyCon -> Bool
 isTyConAssoc = isJust . assocTyConArgPoss_maybe
 

--- | Sets up a 'TyVar' to family argument-list mapping in the given 'TyCon' if it is
--- an open 'TyCon'. Panics otherwise
-setTyConArgPoss :: TyCon -> [Int] -> TyCon
-setTyConArgPoss tc@(AlgTyCon { algTcRhs = rhs })               poss = 
-  tc { algTcRhs = rhs {otArgPoss = Just poss} }
-setTyConArgPoss tc@(SynTyCon { synTcRhs = OpenSynTyCon ki _ }) poss = 
-  tc { synTcRhs = OpenSynTyCon ki (Just poss) }
-setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (ppr tc)
+-- | Set the AssocFamilyPermutation structure in an 
+-- associated data or type synonym.  The [TyVar] are the
+-- class type variables.  Remember, the tyvars of an associated
+-- data/type are a subset of the class tyvars; except that an
+-- associated data type can have extra type variables at the
+-- end (see Note [Avoid name clashes for associated data types] in TcHsType)
+setTyConArgPoss :: [TyVar] -> TyCon -> TyCon
+setTyConArgPoss clas_tvs tc
+  = case tc of
+      AlgTyCon { algTcRhs = rhs }               -> tc { algTcRhs = rhs {otArgPoss = Just ps} }
+      SynTyCon { synTcRhs = OpenSynTyCon ki _ } -> tc { synTcRhs = OpenSynTyCon ki (Just ps) }
+      _                                         -> pprPanic "setTyConArgPoss" (ppr tc)
+  where
+    ps = catMaybes [tv `elemIndex` clas_tvs | tv <- tyConTyVars tc]
+       -- We will get Nothings for the "extra" type variables in an
+       -- associated data type

 
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it
 
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it