Allow associated types to have fresh parameters
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 1 Sep 2011 06:52:11 +0000 (07:52 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 1 Sep 2011 06:52:11 +0000 (07:52 +0100)
This patch allows

     class C a where
       type T a b :: *
     instance C Int
       type T Int b = b -> b

That is, T has a type index 'b' that is not one of the class
variables.

On the way I did a good deal of refactoring (as usual), especially in
TcInstDcls.tcLocalInstDecl1, which checks for consistent instantiation
of the class instance and the type instance.  Less code, more
expressiveness.  See Note [Checking consistent instantiation]

compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsTypes.lhs
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnSource.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcTyClsDecls.lhs

index 5461500..82f113c 100644 (file)
@@ -455,13 +455,8 @@ data TyClDecl name
                tcdLName  :: Located name,              -- ^ Type constructor
 
                tcdTyVars :: [LHsTyVarBndr name],       -- ^ Type variables
-                       
-               tcdTyPats :: Maybe [LHsType name],
-                        -- ^ Type patterns.
-                        --
-                       -- @Just [t1..tn]@ for @data instance T t1..tn = ...@
-                       --      in this case @tcdTyVars = fv( tcdTyPats )@.
-                       -- @Nothing@ for everything else.
+               tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns.
+                  -- See Note [tcdTyVars and tcdTyPats] 
 
                tcdKindSig:: Maybe Kind,
                         -- ^ Optional kind signature.
@@ -492,8 +487,7 @@ data TyClDecl name
   | TySynonym {        tcdLName  :: Located name,              -- ^ type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- ^ type variables
                tcdTyPats :: Maybe [LHsType name],      -- ^ Type patterns
-                       -- See comments for tcdTyPats in TyData
-                       -- 'Nothing' => vanilla type synonym
+                  -- See Note [tcdTyVars and tcdTyPats] 
 
                tcdSynRhs :: LHsType name               -- ^ synonym expansion
     }
@@ -505,9 +499,7 @@ data TyClDecl name
                tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                tcdMeths   :: LHsBinds name,            -- ^ Default methods
                tcdATs     :: [LTyClDecl name],         -- ^ Associated types; ie
-                                                       --   only 'TyFamily' and
-                                                       --   'TySynonym'; the
-                                                        --   latter for defaults
+                                                       --   only 'TyFamily' 
                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs
     }
   deriving (Data, Typeable)
@@ -523,6 +515,26 @@ data FamilyFlavour
   deriving (Data, Typeable)
 \end{code}
 
+Note [tcdTyVars and tcdTyPats] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use TyData and TySynonym both for vanilla data/type declarations
+     type T a = Int
+AND for data/type family instance declarations
+     type instance F [a] = (a,Int)
+
+tcdTyPats = Nothing
+   This is a vanilla data type or type synonym
+   tcdTyVars are the quantified type variables
+
+tcdTyPats = Just tys
+   This is a data/type family instance declaration
+   tcdTyVars are fv(tys)
+
+   Eg   instance C (a,b) where
+          type F a x y = x->y
+   After the renamer, the tcdTyVars of the F decl are {x,y}
+
+------------------------------
 Simple classifiers
 
 \begin{code}
index 7c8cdce..f8b7be4 100644 (file)
@@ -22,7 +22,7 @@ module HsTypes (
        ConDeclField(..), pprConDeclFields,
        
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-       hsTyVarName, hsTyVarNames, replaceTyVarName,
+       hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
        hsTyVarKind, hsTyVarNameKind,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
        splitHsInstDeclTy, splitHsFunType,
@@ -285,6 +285,9 @@ hsLTyVarLocNames = map hsLTyVarLocName
 replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
 replaceTyVarName (UserTyVar _ k)   n' = UserTyVar n' k
 replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
+
+replaceLTyVarName :: LHsTyVarBndr name1 -> name2 -> LHsTyVarBndr name2
+replaceLTyVarName (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
 \end{code}
 
 
index 10274e1..468c4d5 100644 (file)
@@ -182,7 +182,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
   = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
-       ; tyvars <- checkTyVars tparams      -- Only type vars allowed
+       ; tyvars <- checkTyVars tycl_hdr tparams      -- Only type vars allowed
        ; checkKindSigs ats
        ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
                                    tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
@@ -201,7 +201,7 @@ mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_d
 
        ; checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
-       ; (tyvars, typats) <- checkTParams is_family tparams
+       ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams
        ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
                                 tcdTyVars = tyvars, tcdTyPats = typats, 
                                  tcdCons = data_cons, 
@@ -214,7 +214,7 @@ mkTySynonym :: SrcSpan
             -> P (LTyClDecl RdrName)
 mkTySynonym loc is_family lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
-       ; (tyvars, typats) <- checkTParams is_family tparams
+       ; (tyvars, typats) <- checkTParams is_family lhs tparams
        ; return (L loc (TySynonym tc tyvars typats rhs)) }
 
 mkTyFamily :: SrcSpan
@@ -224,7 +224,7 @@ mkTyFamily :: SrcSpan
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
-       ; tyvars <- checkTyVars tparams
+       ; tyvars <- checkTyVars lhs tparams
        ; return (L loc (TyFamily flavour tc tyvars ksig)) }
 
 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
@@ -484,6 +484,7 @@ checkDictTy (L spn ty) = check ty []
   done tc args = return (L spn (HsPredTy (HsClassP tc args)))
 
 checkTParams :: Bool     -- Type/data family
+            -> LHsType RdrName
             -> [LHsType RdrName]
             -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
 -- checkTParams checks the type parameters of a data/newtype declaration
@@ -501,31 +502,32 @@ checkTParams :: Bool        -- Type/data family
 --          If there are kind sigs in the type parameters, they
 --          will fix the binder's kind when we kind-check the 
 --          type parameters
-checkTParams is_family tparams
+checkTParams is_family tycl_hdr tparams
   | not is_family        -- Vanilla case (a)
-  = do { tyvars <- checkTyVars tparams
+  = do { tyvars <- checkTyVars tycl_hdr tparams
        ; return (tyvars, Nothing) }
   | otherwise           -- Family case (b)
   = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
        ; return (tyvars, Just tparams) }
 
-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
 -- non-variable; otherwise, we allow non-variable arguments and return the
 -- entire list of parameters.
-checkTyVars tparms = mapM chk tparms
+checkTyVars tycl_hdr tparms = mapM chk tparms
   where
        -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv placeHolderKind))
-    chk t@(L l _)            =
-         parseErrorSDoc l (text "Type found:" <+> ppr t
-                     $$ text "where type variable expected, in:" <+>
-                        sep (map (pprParendHsType . unLoc) tparms))
+    chk t@(L l _)           
+       = parseErrorSDoc l $
+          vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
+                     , ptext (sLit "where type variable expected") ]
+               , ptext (sLit "In the declaration of") <+> quotes (ppr tycl_hdr) ]
 
 checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
 checkDatatypeContext Nothing = return ()
index 7d4c2b6..cf37499 100644 (file)
@@ -7,7 +7,7 @@
 module RnEnv ( 
        newTopSrcBinder, 
        lookupLocatedTopBndrRn, lookupTopBndrRn,
-       lookupLocatedOccRn, lookupOccRn, 
+       lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
        lookupLocalDataTcNames, lookupSigOccRn,
        lookupFixityRn, lookupTyFixityRn, 
@@ -424,6 +424,12 @@ getLookupOccRn
 lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
 lookupLocatedOccRn = wrapLocM lookupOccRn
 
+lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Just look in the local environment
+lookupLocalOccRn_maybe rdr_name 
+  = do { local_env <- getLocalRdrEnv
+       ; return (lookupLocalRdrEnv local_env rdr_name) }
+
 -- lookupOccRn looks up an occurrence of a RdrName
 lookupOccRn :: RdrName -> RnM Name
 lookupOccRn rdr_name
@@ -947,9 +953,8 @@ bindTyVarsRn tyvar_names enclosed_scope
     do { kind_sigs_ok <- xoptM Opt_KindSignatures
        ; unless (null kinded_tyvars || kind_sigs_ok) 
                        (mapM_ (addErr . kindSigErr) kinded_tyvars)
-       ; enclosed_scope (zipWith replace tyvar_names names) }
+       ; enclosed_scope (zipWith replaceLTyVarName tyvar_names names) }
   where 
-    replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
     located_tyvars = hsLTyVarLocNames tyvar_names
     kinded_tyvars  = [n | L _ (KindedTyVar n _) <- tyvar_names]
 
index dc076cf..b5aec61 100644 (file)
@@ -16,7 +16,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
 #endif         /* GHCI */
 
 import HsSyn
-import RdrName         ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
+import RdrName 
 import RdrHsSyn                ( extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes
@@ -48,7 +48,7 @@ import Digraph                ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 
 import Control.Monad
 import Maybes( orElse )
-import Data.Maybe
+import Data.Maybe( isNothing )
 \end{code}
 
 @rnSourceDecl@ `renames' declarations.
@@ -304,11 +304,14 @@ rnSrcWarnDecls bndr_set decls
    
    what = ptext (sLit "deprecation")
 
-   -- look for duplicates among the OccNames;
-   -- we check that the names are defined above
-   -- invt: the lists returned by findDupsEq always have at least two elements
-   warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
-                     (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
+   warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
+
+findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
+findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+
+-- look for duplicates among the OccNames;
+-- we check that the names are defined above
+-- invt: the lists returned by findDupsEq always have at least two elements
                
 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
 -- Located RdrName -> DeprecDecl RdrName -> SDoc
@@ -421,28 +424,29 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
        -- Used for both source and interface file decls
   = do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty
+       ; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty'
 
        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all 
        -- the bindings are for the right class
-       ; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty'
-
+       -- (Slightly strangely) when scoped type variables are on, the 
+        -- forall-d tyvars scope over the method bindings too
        ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $
-                               rnMethodBinds cls (\_ -> [])    -- No scoped tyvars
-                                             mbinds    
-            -- (Slightly strangely) the forall-d tyvars 
-             -- scope over the method bindings too
+                                rnMethodBinds cls (\_ -> [])   -- No scoped tyvars
+                                                 mbinds    
 
-       -- Rename the associated types
+       -- Rename the associated types
+       -- Here the instance variables always scope, regardless of -XScopedTypeVariables                                        
+       ; (ats', at_fvs) <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
+                           rnATInsts cls ats
+
+       -- Check for duplicate associated types
        -- The typechecker (not the renamer) checks that all 
        -- the declarations are for the right class
-       ; let  at_names = map (tcdLName . unLoc) ats    -- The names of the associated types
+       ; let at_names = map (tcdLName . unLoc) ats
        ; checkDupRdrNames at_names
        -- See notes with checkDupRdrNames for methods, above
 
-       ; traceRn (text "rnATInsts" <+> ppr ats)
-       ; (ats', at_fvs) <- rnATInsts cls ats
-
        -- Rename the prags and signatures.
        -- Note that the type variables are not in scope here,
        -- so that      instance Eq a => Eq (T a) where
@@ -457,7 +461,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 
        ; return (InstDecl inst_ty' mbinds' uprags' ats',
                 meth_fvs `plusFV` at_fvs
-                         `plusFV` hsSigsFVs uprags'
+                          `plusFV` hsSigsFVs uprags'
                          `plusFV` extractHsTyNames inst_ty') }
              -- We return the renamed associated data type declarations so
              -- that they can be entered into the list of type declarations
@@ -712,11 +716,19 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
        ; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
                 emptyFVs) }
 
--- all flavours of type family declarations ("type family", "newtype family",
--- and "data family")
-rnTyClDecl _ tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
+-- All flavours of type family declarations ("type family", "newtype family",
+-- and "data family"), both top level and (for an associated type) 
+-- in a class decl
+rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
+                            , tcdFlavour = flav, tcdKind = kind }) 
+  = bindQTvs mb_cls tyvars $ \tyvars' ->
+    do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
+                           , tcdFlavour = flav, tcdKind = kind }
+                , emptyFVs)  }
 
 -- "data", "newtype", "data instance, and "newtype instance" declarations
+-- both top level and (for an associated type) in an instance decl
 rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
                                 tcdLName = tycon, tcdTyVars = tyvars, 
                                 tcdTyPats = typats, tcdCons = condecls, 
@@ -724,8 +736,9 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
   = do { tycon' <- lookupTcdName mb_cls tydecl
        ; checkTc (h98_style || null (unLoc context)) 
                   (badGadtStupidTheta tycon)
+
        ; ((tyvars', context', typats', derivs'), stuff_fvs)
-               <- bindTyVarsFV tyvars $ \ tyvars' -> do
+               <- bindQTvs mb_cls tyvars $ \ tyvars' -> do
                                 -- Checks for distinct tyvars
                   { context' <- rnContext data_doc context
                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
@@ -766,7 +779,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 -- "type" and "type instance" declarations
 rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
                                      tcdTyPats = typats, tcdSynRhs = ty})
-  = bindTyVarsFV tyvars $ \ tyvars' -> do
+  = bindQTvs mb_cls tyvars $ \ tyvars' -> do
     {           -- Checks for distinct tyvars
       name' <- lookupTcdName mb_cls tydecl
     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
@@ -777,22 +790,24 @@ rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
   where
     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
-rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname
+rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls
                         tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
                         tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
-  = do { cname' <- lookupLocatedTopBndrRn cname
+  = do { lcls' <- lookupLocatedTopBndrRn lcls
+        ; let cls' = unLoc lcls'
 
        -- Tyvars scope over superclass context and method signatures
        ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
            <- bindTyVarsFV tyvars $ \ tyvars' -> do
                 -- Checks for distinct tyvars
             { context' <- rnContext cls_doc context
-            ; fds' <- rnFds cls_doc fds
-            ; (ats', at_fvs) <- rnATs ats
+            ; fds'  <- rnFds cls_doc fds
+             ; let rn_at = rnTyClDecl (Just cls')
+             ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
             ; sigs' <- renameSigs Nothing okClsDclSig sigs
-            ; let fvs = at_fvs `plusFV` 
-                         extractHsCtxtTyNames context' `plusFV`
-                        hsSigsFVs sigs'
+            ; let fvs = extractHsCtxtTyNames context'  `plusFV`
+                        hsSigsFVs sigs'                `plusFV`
+                         plusFVs fv_ats
                         -- The fundeps have no free variables
             ; return ((tyvars', context', fds', ats', sigs'), fvs) }
 
@@ -821,17 +836,60 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname,
                -- No need to check for duplicate method signatures
                -- since that is done by RnNames.extendGlobalRdrEnvRn
                -- and the methods are already in scope
-                rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
+                rnMethodBinds cls' (mkSigTvFn sigs') mbinds
 
   -- Haddock docs 
        ; docs' <- mapM (wrapLocM rnDocDecl) docs
 
-       ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
+       ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', 
                              tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
                              tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
                  meth_fvs `plusFV` stuff_fvs) }
   where
-    cls_doc  = text "In the declaration for class"     <+> ppr cname
+    cls_doc  = text "In the declaration for class" <+> ppr lcls
+
+
+bindQTvs :: Maybe Name -> [LHsTyVarBndr RdrName]
+         -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+         -> RnM (a, FreeVars)
+-- For *associated* type/data family instances (in an instance decl)
+-- don't quantify over the already-in-scope type variables
+bindQTvs mb_cls tyvars thing_inside
+  | isNothing mb_cls    -- Not associated
+  = bindTyVarsFV tyvars thing_inside
+  | otherwise          -- Associated
+  = do { let tv_rdr_names = map hsLTyVarLocName tyvars
+
+       -- Check for duplicated bindings
+       -- This test is irrelevant for data/type *instances*, where the tyvars
+       -- are the free tyvars of the patterns, and hence have no duplicates
+       -- But it's needed for data/type *family* decls
+       ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names)
+
+       ; rdr_env <- getLocalRdrEnv
+       ; tv_nbs <- mapM (mk_tv_name rdr_env) tv_rdr_names
+       ; let tv_ns, fresh_ns :: [Name]
+             tv_ns = map fst tv_nbs
+            fresh_ns = [n | (n,True)  <- tv_nbs]
+
+       ; (thing, fvs) <- bindLocalNames tv_ns $
+                         thing_inside (zipWith replaceLTyVarName tyvars tv_ns)
+       ; return (thing, delFVs fresh_ns fvs) }
+  where
+    mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM (Name, Bool)
+              -- False <=> already in scope
+              -- True  <=> fresh
+    mk_tv_name rdr_env (L l tv_rdr)
+      = do { case lookupLocalRdrEnv rdr_env tv_rdr of 
+               Just n  -> return (n, False)
+               Nothing -> do { n <- newLocalBndrRn (L l tv_rdr)
+                             ; return (n, True) } }
+
+dupBoundTyVar :: [Located RdrName] -> RnM ()
+dupBoundTyVar (L loc tv : _) 
+  = setSrcSpan loc $
+    addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv))
+dupBoundTyVar [] = panic "dupBoundTyVar"
 
 badGadtStupidTheta :: Located RdrName -> SDoc
 badGadtStupidTheta _
@@ -981,70 +1039,7 @@ rnConDeclDetails doc (RecCon fields)
                -- since that is done by RnNames.extendGlobalRdrEnvRn
        ; return (RecCon new_fields) }
 
--- Rename family declarations
---
--- * This function is parametrised by the routine handling the index
---   variables.  On the toplevel, these are defining occurences, whereas they
---   are usage occurences for associated types.
---
-rnFamily :: TyClDecl RdrName 
-         -> ([LHsTyVarBndr RdrName] -> 
-            ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
-            RnM (TyClDecl Name, FreeVars))
-         -> RnM (TyClDecl Name, FreeVars)
-
-rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
-                          tcdLName = tycon, tcdTyVars = tyvars}) 
-        bindIdxVars =
-      do { bindIdxVars tyvars $ \tyvars' -> do {
-        ; tycon' <- lookupLocatedTopBndrRn tycon
-        ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
-                             tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
-                   emptyFVs) 
-         } }
-rnFamily d _ = pprPanic "rnFamily" (ppr d)
-
--- Rename associated type declarations (in classes)
---
--- * This can be family declarations and (default) type instances
---
-rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
-rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
-  where
-    rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
-    rn_at (tydecl@TySynonym {}) = 
-      do
-        unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
-        rnTyClDecl Nothing tydecl
-    rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
-
-    lookupIdxVars tyvars cont = 
-      do { checkForDups tyvars
-        ; tyvars' <- mapM 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) =
-      do
-       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
-        }
-
-    _       `ltvElem` [] = False
-    rdrName `ltvElem` (L _ tv:ltvs)
-      | rdrName == hsTyVarName tv = True
-      | otherwise                = rdrName `ltvElem` ltvs
-
+-------------------------------------------------
 deprecRecSyntax :: ConDecl RdrName -> SDoc
 deprecRecSyntax decl 
   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
@@ -1055,14 +1050,6 @@ deprecRecSyntax decl
 badRecResTy :: SDoc -> SDoc
 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
 
-noPatterns :: SDoc
-noPatterns = text "Default definition for an associated synonym cannot have"
-            <+> text "type pattern"
-
-repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
-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.
index 0dca868..1d12c33 100644 (file)
@@ -9,7 +9,7 @@ Typechecking class declarations
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
                    findMethodBind, instantiateMethod, tcInstanceMethodBody,
                    mkGenericDefMethBind,
-                   tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
+                   tcAddDeclCtxt, badMethodErr
                  ) where
 
 #include "HsVersions.h"
@@ -400,14 +400,6 @@ badGenericMethod clas op
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
          ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
 
-badATErr :: Class -> Name -> SDoc
-badATErr clas at
-  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
-         ptext (sLit "does not have an associated type"), quotes (ppr at)]
-
-omittedATWarn :: Name -> SDoc
-omittedATWarn at
-  = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 {-
 badGenericInstanceType :: LHsBinds Name -> SDoc
 badGenericInstanceType binds
index 3070ee9..fed1864 100644 (file)
@@ -35,7 +35,7 @@ import TyCon
 import DataCon
 import Class
 import Var
-import VarEnv     ( mkInScopeSet )
+import VarEnv
 import VarSet     ( mkVarSet )
 import Pair
 import CoreUtils  ( mkPiTypes )
@@ -57,7 +57,6 @@ import SrcLoc
 import Util
 
 import Control.Monad
-import Data.List
 import Data.Maybe
 import Maybes     ( orElse )
 \end{code}
@@ -369,7 +368,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                 -- round)
 
                 -- (1) Do class and family instance declarations
-       ; idx_tycons        <- mapAndRecoverM (tcFamInstDecl TopLevel) $
+       ; idx_tycons        <- mapAndRecoverM tcTopFamInstDecl $
                               filter (isFamInstDecl . unLoc) tycl_decls
        ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
 
@@ -453,134 +452,75 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
 
         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
         ; checkValidInstance poly_ty tyvars theta clas inst_tys
+        ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
 
         -- Next, process any associated types.
-        ; idx_tycons <- recoverM (return []) $
-                     do { idx_tycons <- checkNoErrs $
-                                        mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
-                        ; checkValidAndMissingATs clas (tyvars, inst_tys)
-                                                  (zip ats idx_tycons)
-                        ; return idx_tycons }
+        ; idx_tycons <- tcExtendTyVarEnv tyvars $
+                        mapAndRecoverM (tcAssocDecl clas mini_env) ats
+
+        -- Check for misssing associated types
+        ; let class_ats   = map tyConName (classATs clas)
+              defined_ats = mkNameSet $ map (tcdName . unLoc) ats
+              omitted     = filterOut (`elemNameSet` defined_ats) class_ats
+        ; warn <- woptM Opt_WarnMissingMethods
+        ; mapM_ (warnTc warn . omittedATWarn) omitted
 
         -- Finally, construct the Core representation of the instance.
         -- (This no longer includes the associated types.)
         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
                 -- Dfun location is that of instance *header*
+
         ; overlap_flag <- getOverlapFlag
-        ; let (eq_theta,dict_theta) = partition isEqPred theta
-              theta'         = eq_theta ++ dict_theta
-              dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
-              ispec          = mkLocalInstance dfun overlap_flag
-
-        ; return (InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False },
-                  idx_tycons)
-        }
+        ; let dfun     = mkDictFunId dfun_name tyvars theta clas inst_tys
+              ispec    = mkLocalInstance dfun overlap_flag
+              inst_info = InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False }
+
+        ; return (inst_info, idx_tycons) }
+
+tcAssocDecl :: Class -> VarEnv Type -> LTyClDecl Name -> TcM TyCon
+tcAssocDecl clas mini_env (L loc decl)
+  = setSrcSpan loc      $
+    tcAddDeclCtxt decl  $
+    do { at_tc <- tcFamInstDecl NotTopLevel decl
+       ; let Just (fam_tc, at_tys) = tyConFamInst_maybe at_tc
+  
+       -- Check that the associated type comes from this class
+       ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
+                 (badATErr clas at_tc)
+
+       -- See Note [Checking consistent instantiation]
+       ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
+
+       ; return at_tc }
   where
-    -- We pass in the source form and the type checked form of the ATs.  We
-    -- really need the source form only to be able to produce more informative
-    -- error messages.
-    checkValidAndMissingATs :: Class
-                            -> ([TyVar], [TcType])     -- instance types
-                            -> [(LTyClDecl Name,       -- source form of AT
-                                 TyCon)]               -- Core form of AT
-                            -> TcM ()
-    checkValidAndMissingATs clas inst_tys ats
-      = do { -- Issue a warning for each class AT that is not defined in this
-             -- instance.
-           ; let class_ats   = map tyConName (classATs clas)
-                 defined_ats = listToNameSet . map (tcdName.unLoc.fst)  $ ats
-                 omitted     = filterOut (`elemNameSet` defined_ats) class_ats
-           ; warn <- woptM Opt_WarnMissingMethods
-           ; mapM_ (warnTc warn . omittedATWarn) omitted
-
-             -- Ensure that all AT indexes that correspond to class parameters
-             -- coincide with the types in the instance head.  All remaining
-             -- AT arguments must be variables.  Also raise an error for any
-             -- type instances that are not associated with this class.
-           ; mapM_ (checkIndexes clas inst_tys) ats
-           }
-
-    checkIndexes clas inst_tys (hsAT, tycon)
--- !!!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 (instTvs, instTys) hsAT (atTvs, atTys)
-      = let atName = tcdName . unLoc $ hsAT
-        in
-        setSrcSpan (getLoc hsAT)       $
-        addErrCtxt (atInstCtxt atName) $
-        case find ((atName ==) . tyConName) (classATs clas) of
-          Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
-          Just atycon ->
-                -- The following is tricky!  We need to deal with three
-                -- complications: (1) The AT possibly only uses a subset of
-                -- the class parameters as indexes and those it uses may be in
-                -- a different order; (2) the AT may have extra arguments,
-                -- 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 (2), we wrap the (permuted) class parameters in a Maybe
-                -- type and use Nothing for any extra AT arguments.  (First
-                -- equation of `checkIndex' below.)
-                --
-                -- Re (3), we replace any type variable in the AT parameters
-                -- that has the same source lexeme as some variable in the
-                -- instance types with the instance type variable sharing its
-                -- source lexeme.
-                --
-                let poss :: [Int]
-                    -- 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]
-                    poss = catMaybes [ tv `elemIndex` classTyVars clas
-                                     | tv <- tyConTyVars atycon]
-                       -- We will get Nothings for the "extra" type
-                       -- variables in an associated data type
-                       -- e.g. class C a where { data D a :: *->* }
-                       -- here D gets arity 2 and has two tyvars
-
-                    relevantInstTys = map (instTys !!) poss
-                    instArgs        = map Just relevantInstTys ++
-                                      repeat Nothing  -- extra arguments
-                    renaming        = substSameTyVar atTvs instTvs
-                in
-                zipWithM_ checkIndex (substTys renaming atTys) instArgs
-
-    checkIndex ty Nothing
-      | isTyVarTy ty         = return ()
-      | otherwise            = addErrTc $ mustBeVarArgErr ty
-    checkIndex ty (Just instTy)
-      | ty `eqType` instTy = return ()
-      | otherwise          = addErrTc $ wrongATArgErr ty instTy
-
-    listToNameSet = addListToNameSet emptyNameSet
-
-    substSameTyVar []       _            = emptyTvSubst
-    substSameTyVar (tv:tvs) replacingTvs =
-      let replacement = case find (tv `sameLexeme`) replacingTvs of
-                        Nothing  -> mkTyVarTy tv
-                        Just rtv -> mkTyVarTy rtv
-          --
-          tv1 `sameLexeme` tv2 =
-            nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
-      in
-      TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+    check_arg fam_tc_tv at_ty
+      | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
+      = checkTc (inst_ty `eqType` at_ty) 
+                (wrongATArgErr at_ty inst_ty)
+      | otherwise 
+      = checkTc (isTyVarTy at_ty)  
+                (mustBeVarArgErr at_ty)
 \end{code}
 
+Note [Checking consistent instantiation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  class C a b where
+    type T a x b
+
+  instance C [p] Int
+    type T [p] y Int = (p,y,y)  -- Induces the family instance TyCon
+                               --    type TR p y = (p,y,y)
+
+So we 
+  * Form the mini-envt from the class type variables a,b
+    to the instance decl types [p],Int:   [a->[p], b->Int]
+
+  * Look at the tyvars a,x,b of the type family constructor T
+    (it shares tyvars with the class C)
+
+  * Apply the mini-evnt to them, and check that the result is
+    consistent with the instance types [p] y Int
+
 
 %************************************************************************
 %*                                                                      *
@@ -594,50 +534,46 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
 \begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon
-tcFamInstDecl top_lvl (L loc decl)
-  =     -- Prime error recovery, set source location
-    setSrcSpan loc                              $
-    tcAddDeclCtxt decl                          $
-    do { -- type family instances require -XTypeFamilies
+tcTopFamInstDecl :: LTyClDecl Name -> TcM TyCon
+tcTopFamInstDecl (L loc decl)
+  = setSrcSpan loc      $
+    tcAddDeclCtxt decl  $
+    tcFamInstDecl TopLevel decl
+
+tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon
+-- TopLevel  => top-level
+-- NotTopLevel => in an instance decl
+tcFamInstDecl top_lvl decl
+  = do { -- type family instances require -XTypeFamilies
          -- and can't (currently) be in an hs-boot file
+       ; let fam_tc_lname = tcdLName decl
        ; type_families <- xoptM Opt_TypeFamilies
-       ; is_boot  <- tcIsHsBoot   -- Are we compiling an hs-boot file?
-       ; checkTc type_families $ badFamInstDecl (tcdLName decl)
+       ; is_boot <- tcIsHsBoot   -- Are we compiling an hs-boot file?
+       ; checkTc type_families $ badFamInstDecl fam_tc_lname
        ; checkTc (not is_boot) $ badBootFamInstDeclErr
 
-         -- Perform kind and type checking
-       ; tc <- tcFamInstDecl1 decl
+       -- Look up the family TyCon and check for validity including
+       -- check that toplevel type instances are not for associated types.
+       ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
+       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
+       ; when (isTopLevel top_lvl && isTyConAssoc fam_tc)
+              (addErr $ assocInClassErr fam_tc_lname)
+
+         -- Now check the type/data instance itself
+        -- This is where type and data decls are treated separately
+       ; tc <- tcFamInstDecl1 fam_tc decl
        ; checkValidTyCon tc     -- Remember to check validity;
                                 -- no recursion to worry about here
 
-       -- Check that toplevel type instances are not for associated types.
-       ; when (isTopLevel top_lvl && isAssocFamily tc)
-              (addErr $ assocInClassErr (tcdName decl))
-
        ; return tc }
 
-isAssocFamily :: TyCon -> Bool  -- Is an assocaited type
-isAssocFamily tycon
-  = case tyConFamInst_maybe tycon of
-          Nothing       -> panic "isAssocFamily: no family?!?"
-          Just (fam, _) -> isTyConAssoc fam
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name
- = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
-   ptext (sLit "must be inside a class instance")
-
-
-
-tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
+tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
 
   -- "type instance"
-tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
-  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+tcFamInstDecl1 fam_tc (decl@TySynonym {tcdLName = L loc tc_name})
+  = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind ->
     do { -- check that the family declaration is for a synonym
-         checkTc (isFamilyTyCon family) (notFamily family)
-       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
+         checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        ; -- (1) kind check the right-hand side of the type equation
        ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
@@ -645,13 +581,13 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
 
          -- we need the exact same number of type parameters as the family
          -- declaration
-       ; let famArity = tyConArity family
+       ; let famArity = tyConArity fam_tc
        ; checkTc (length k_typats == famArity) $
-           wrongNumberOfParmsErr famArity
+                 wrongNumberOfParmsErr famArity
 
          -- (2) type check type equation
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
-       ; t_typats <- mapM tcHsKindedType k_typats
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
+       { t_typats <- mapM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
          -- (3) check the well-formedness of the instance
@@ -659,18 +595,20 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
 
          -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
-       ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
+       ; buildSynTyCon rep_tc_name t_tvs
+                       (SynonymTyCon t_rhs)
                        (typeKind t_rhs)
-                       NoParentTyCon (Just (family, t_typats))
+                       NoParentTyCon (Just (fam_tc, t_typats))
        }}
 
   -- "newtype instance" and "data instance"
-tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
-                             tcdCons = cons})
-  = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
+tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data
+                                   , tcdLName = L loc tc_name
+                                   , tcdCons = cons})
+  = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind ->
     do { -- check that the family declaration is for the right kind
-         checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
-       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
+         checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
+       ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        ; -- (1) kind check the data declaration as usual
        ; k_decl <- kcDataDecl decl k_tvs
@@ -678,13 +616,13 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
              k_cons = tcdCons k_decl
 
          -- result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
+       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tc)
 
          -- (2) type check indexed data type declaration
-       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
+       ; tcTyVarBndrs k_tvs $ \t_tvs -> do   -- turn kinded into proper tyvars
 
          -- kind check the type indexes and the context
-       ; t_typats     <- mapM tcHsKindedType k_typats
+       { t_typats     <- mapM tcHsKindedType k_typats
        ; stupid_theta <- tcHsKindedContext k_ctxt
 
          -- (3) Check that
@@ -699,7 +637,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
        ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
        ; let ex_ok = True       -- Existentials ok for type families!
        ; fixM (\ rep_tycon -> do
-             { let orig_res_ty = mkTyConApp fam_tycon t_typats
+             { let orig_res_ty = mkTyConApp fam_tc t_typats
              ; data_cons <- tcConDecls ex_ok rep_tycon
                                        (t_tvs, orig_res_ty) k_cons
              ; tc_rhs <-
@@ -708,7 +646,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                    NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
              ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-                             h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+                             h98_syntax NoParentTyCon (Just (fam_tc, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
@@ -721,7 +659,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
                         _ -> True
 
-tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
+tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
 
 -- Kind checking of indexed types
 -- -
@@ -732,27 +670,26 @@ tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
 --   not check whether there is a pattern for each type index; the latter
 --   check is only required for type synonym instances.
 
-kcIdxTyPats :: TyClDecl Name
-            -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
+kcIdxTyPats :: TyCon
+            -> TyClDecl Name
+            -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TcM a)
                -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
             -> TcM a
-kcIdxTyPats decl thing_inside
+kcIdxTyPats fam_tc decl thing_inside
   = kcHsTyVars (tcdTyVars decl) $ \tvs ->
-    do { let tc_name = tcdLName decl
-       ; fam_tycon <- tcLookupLocatedTyCon tc_name
-       ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
+    do { let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tc)
              ; hs_typats        = fromJust $ tcdTyPats decl }
 
-         -- we may not have more parameters than the kind indicates
+         -- We may not have more parameters than the kind indicates
        ; checkTc (length kinds >= length hs_typats) $
-           tooManyParmsErr (tcdLName decl)
+                 tooManyParmsErr (tcdLName decl)
 
-         -- type functions can have a higher-kinded result
+         -- Type functions can have a higher-kinded result
        ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
        ; typats <- zipWithM kcCheckLHsType hs_typats
-                            [ EK kind (EkArg (ppr tc_name) n)
+                            [ EK kind (EkArg (ppr fam_tc) n)
                             | (kind,n) <- kinds `zip` [1..]]
-       ; thing_inside tvs typats resultKind fam_tycon
+       ; thing_inside tvs typats resultKind 
        }
 \end{code}
 
@@ -1405,9 +1342,11 @@ instDeclCtxt2 dfun_ty
 inst_decl_ctxt :: SDoc -> SDoc
 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
 
+{-
 atInstCtxt :: Name -> SDoc
 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
                   quotes (ppr name)
+-}
 
 mustBeVarArgErr :: Type -> SDoc
 mustBeVarArgErr ty =
@@ -1455,4 +1394,24 @@ wrongKindOfFamily family
     kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
                  | isAlgTyCon family = ptext (sLit "data type")
                  | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
+
+assocInClassErr :: Located Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+   ptext (sLit "must be inside a class instance")
+
+badFamInstDecl :: Located Name -> SDoc
+badFamInstDecl tc_name
+  = vcat [ ptext (sLit "Illegal family instance for") <+>
+          quotes (ppr tc_name)
+        , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
+
+badATErr :: Class -> TyCon -> SDoc
+badATErr clas at
+  = hsep [ptext (sLit "Class"), quotes (ppr clas), 
+         ptext (sLit "does not have an associated type"), quotes (ppr at)]
+
+omittedATWarn :: Name -> SDoc
+omittedATWarn at
+  = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 \end{code}
index b7dc847..eb950f1 100644 (file)
@@ -8,7 +8,7 @@ TcTyClsDecls: Typecheck type and class declarations
 \begin{code}
 module TcTyClsDecls (
        tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
-        checkValidTyCon, dataDeclChecks, badFamInstDecl
+        checkValidTyCon, dataDeclChecks
     ) where
 
 #include "HsVersions.h"
@@ -435,11 +435,7 @@ tcTyClDecl1 parent _calc_isrec
              tcdKind = Just kind}) -- NB: kind at latest added during kind checking
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc "type family:" (ppr tc_name) 
-
-       -- Check that we don't use families without -XTypeFamilies
-  ; idx_tys <- xoptM Opt_TypeFamilies
-  ; checkTc idx_tys $ badFamInstDecl tc_name
-
+  ; checkFamFlag tc_name
   ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
   ; return [ATyCon tycon]
   }
@@ -450,21 +446,16 @@ tcTyClDecl1 parent _calc_isrec
             tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc "data family:" (ppr tc_name) 
+  ; checkFamFlag tc_name
   ; extra_tvs <- tcDataKindSig mb_kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
-
-
-       -- Check that we don't use families without -XTypeFamilies
-  ; idx_tys <- xoptM Opt_TypeFamilies
-  ; checkTc idx_tys $ badFamInstDecl tc_name
-
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
                DataFamilyTyCon Recursive True 
                parent Nothing
   ; return [ATyCon tycon]
   }
 
-  -- "type"
+  -- "type" synonym declaration
 tcTyClDecl1 _parent _calc_isrec
   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   = ASSERT( isNoParent _parent )
@@ -1022,6 +1013,17 @@ checkValidClass cls
                -- forall has an (Eq a) constraint.  Whereas in general, each constraint 
                -- in the context of a for-all must mention at least one quantified
                -- type variable.  What a mess!
+
+checkFamFlag :: Name -> TcM ()
+-- Check that we don't use families without -XTypeFamilies
+-- The parser won't even parse them, but I suppose a GHC API
+-- client might have a go!
+checkFamFlag tc_name
+  = do { idx_tys <- xoptM Opt_TypeFamilies
+       ; checkTc idx_tys err_msg }
+  where
+    err_msg = hang (ptext (sLit "Illegal family declaraion for") <+> quotes (ppr tc_name))
+                2 (ptext (sLit "Use -XTypeFamilies to allow indexed type families"))
 \end{code}
 
 
@@ -1350,12 +1352,6 @@ badSigTyDecl tc_name
           quotes (ppr tc_name)
         , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
 
-badFamInstDecl :: Outputable a => a -> SDoc
-badFamInstDecl tc_name
-  = vcat [ ptext (sLit "Illegal family instance for") <+>
-          quotes (ppr tc_name)
-        , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
-
 emptyConDeclsErr :: Name -> SDoc
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),