Migrate cvs diff from fptools-assoc branch

Wed Jul 26 17:46:55 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Migrate cvs diff from fptools-assoc branch
  - Syntactic support for associated types
  - Renamer support for associated types
  - ATs are only allowed with -fglasgow-exts
  - Handle ATs in the type and class declaration kinding knot-tying exercise

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d85782b..1406d63 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -231,7 +231,7 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
                                ys_list <- coreList nameTyConName ys'
                                repFunDep xs_list ys_list
 
                                ys_list <- coreList nameTyConName ys'
                                repFunDep xs_list ys_list
 

-repInstD' (L loc (InstDecl ty binds _))                -- Ignore user pragmas for now
+repInstD' (L loc (InstDecl ty binds _ _))              -- Ignore user pragmas for now

  = do  { i <- addTyVarBinds tvs $ \tv_bndrs ->
                -- We must bring the type variables into scope, so their occurrences
                -- don't fail,  even though the binders don't appear in the resulting 
  = do  { i <- addTyVarBinds tvs $ \tv_bndrs ->
                -- We must bring the type variables into scope, so their occurrences
                -- don't fail,  even though the binders don't appear in the resulting 

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 17d6be9..4dd3a6d 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -128,14 +128,18 @@ cvtTop (ClassD ctxt cl tvs fds decs)
   = do { stuff <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
        ; (binds', sigs') <- cvtBindsAndSigs decs
   = do { stuff <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
        ; (binds', sigs') <- cvtBindsAndSigs decs

-       ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' }
+       ; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' []  
+                                                            -- ^^no ATs in TH
+       }

 
 cvtTop (InstanceD tys ty decs)
   = do         { (binds', sigs') <- cvtBindsAndSigs decs
        ; ctxt' <- cvtContext tys
        ; L loc pred' <- cvtPred ty
        ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
 
 cvtTop (InstanceD tys ty decs)
   = do         { (binds', sigs') <- cvtBindsAndSigs decs
        ; ctxt' <- cvtContext tys
        ; L loc pred' <- cvtPred ty
        ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))

-       ; returnL $ InstD (InstDecl inst_ty' binds' sigs') }
+       ; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
+                                                      -- ^^no ATs in TH
+       }

 
 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
 
 
 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
 

@@ -143,7 +147,7 @@ cvt_tycl_hdr cxt tc tvs
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tvs' <- cvtTvs tvs
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tvs' <- cvtTvs tvs

-       ; return (cxt', tc', tvs') }
+       ; return (cxt', tc', tvs', Nothing) }

 
 ---------------------------------------------------
 --     Data types
 
 ---------------------------------------------------
 --     Data types

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index e9ee026..070079e 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -21,6 +21,7 @@ module HsDecls (
        isClassDecl, isSynDecl, isDataDecl, 
        countTyClDecls,
        conDetailsTys,
        isClassDecl, isSynDecl, isDataDecl, 
        countTyClDecls,
        conDetailsTys,

+       instDeclATs,

        collectRuleBndrSigTys, 
     ) where
 
        collectRuleBndrSigTys, 
     ) where
 

@@ -341,7 +342,8 @@ data TyClDecl name
                tcdCtxt   :: LHsContext name,           -- Context
                tcdLName  :: Located name,              -- Type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- Type variables
                tcdCtxt   :: LHsContext name,           -- Context
                tcdLName  :: Located name,              -- Type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- Type variables

-               tcdKindSig :: Maybe Kind,               -- Optional kind sig; 
+               tcdTyPats :: Maybe [LHsType name],      -- Type patterns
+               tcdKindSig:: Maybe Kind,                -- Optional kind sig; 

                                                        -- (only for the 'where' form)
 
                tcdCons   :: [LConDecl name],           -- Data constructors
                                                        -- (only for the 'where' form)
 
                tcdCons   :: [LConDecl name],           -- Data constructors

@@ -367,7 +369,10 @@ data TyClDecl name
                tcdTyVars  :: [LHsTyVarBndr name],      -- Class type variables
                tcdFDs     :: [Located (FunDep name)],  -- Functional deps
                tcdSigs    :: [LSig name],              -- Methods' signatures
                tcdTyVars  :: [LHsTyVarBndr name],      -- Class type variables
                tcdFDs     :: [Located (FunDep name)],  -- Functional deps
                tcdSigs    :: [LSig name],              -- Methods' signatures

-               tcdMeths   :: LHsBinds name             -- Default methods
+               tcdMeths   :: LHsBinds name,            -- Default methods
+               tcdATs     :: [LTyClDecl name]          -- Associated types; ie
+                                                       --   only 'TyData'
+                                                       --   and 'TySynonym'

     }
 
 data NewOrData
     }
 
 data NewOrData

@@ -406,8 +411,9 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
 tyClDeclNames (TySynonym   {tcdLName = name})  = [name]
 tyClDeclNames (ForeignType {tcdLName = name})  = [name]
 
 tyClDeclNames (TySynonym   {tcdLName = name})  = [name]
 tyClDeclNames (ForeignType {tcdLName = name})  = [name]
 

-tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs})
-  = cls_name : [n | L _ (TypeSig n _) <- sigs]
+tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
+  = cls_name : 
+    concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]

 
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
   = tc_name : conDeclsNames (map unLoc cons)
 
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
   = tc_name : conDeclsNames (map unLoc cons)

@@ -442,38 +448,51 @@ instance OutputableBndr name
        = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
        = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})

-      = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars <+> equals)
+      = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars Nothing <+> equals)

             4 (ppr mono_ty)
 
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
             4 (ppr mono_ty)
 
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,

-                tcdTyVars = tyvars, tcdKindSig = mb_sig, tcdCons = condecls, 
-                tcdDerivs = derivings})
-      = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars <+> ppr_sig mb_sig)
+                tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig, 
+                tcdCons = condecls, tcdDerivs = derivings})
+      = pp_tydecl (ppr new_or_data <+> 
+                  pp_decl_head (unLoc context) ltycon tyvars typats <+> 
+                  ppr_sig mb_sig)

                  (pp_condecls condecls)
                  derivings
       where
        ppr_sig Nothing = empty
        ppr_sig (Just kind) = dcolon <+> pprKind kind
 
                  (pp_condecls condecls)
                  derivings
       where
        ppr_sig Nothing = empty
        ppr_sig (Just kind) = dcolon <+> pprKind kind
 

-    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds,
-                   tcdSigs = sigs, tcdMeths = methods})
-      | null sigs      -- No "where" part
+    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
+                   tcdFDs = fds, 
+                   tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
+      | null sigs && null ats  -- No "where" part

       = top_matter
 
       | otherwise      -- Laid out
       = sep [hsep [top_matter, ptext SLIT("where {")],
       = top_matter
 
       | otherwise      -- Laid out
       = sep [hsep [top_matter, ptext SLIT("where {")],

-            nest 4 (sep [sep (map ppr_sig sigs), pprLHsBinds methods, char '}'])]
+            nest 4 (sep [ sep (map ppr_semi ats)
+                        , sep (map ppr_semi sigs)
+                        , pprLHsBinds methods
+                        , char '}'])]

       where
       where

-        top_matter  = ptext SLIT("class") <+> pp_decl_head (unLoc context) lclas tyvars <+> pprFundeps (map unLoc fds)
-       ppr_sig sig = ppr sig <> semi
+        top_matter    =     ptext SLIT("class") 
+                       <+> pp_decl_head (unLoc context) lclas tyvars Nothing
+                       <+> pprFundeps (map unLoc fds)
+       ppr_semi decl = ppr decl <> semi

 
 pp_decl_head :: OutputableBndr name
    => HsContext name
    -> Located name
    -> [LHsTyVarBndr name]
 
 pp_decl_head :: OutputableBndr name
    => HsContext name
    -> Located name
    -> [LHsTyVarBndr name]

+   -> Maybe [LHsType name]

    -> SDoc
    -> SDoc

-pp_decl_head context thing tyvars
+pp_decl_head context thing tyvars Nothing      -- no explicit type patterns

   = hsep [pprHsContext context, ppr thing, interppSP tyvars]
   = hsep [pprHsContext context, ppr thing, interppSP tyvars]

+pp_decl_head context thing _      (Just typats) -- explicit type patterns
+  = hsep [ pprHsContext context, ppr thing
+        , hsep (map (pprParendHsType.unLoc) typats)]
+

 pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
   = hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
 pp_condecls cs                           -- In H98 syntax
 pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
   = hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
 pp_condecls cs                           -- In H98 syntax

@@ -595,14 +614,21 @@ data InstDecl name
                                -- Using a polytype means that the renamer conveniently
                                -- figures out the quantified type variables for us.
                (LHsBinds name)
                                -- Using a polytype means that the renamer conveniently
                                -- figures out the quantified type variables for us.
                (LHsBinds name)

-               [LSig name]             -- User-supplied pragmatic info
+               [LSig name]     -- User-supplied pragmatic info
+               [LTyClDecl name]-- Associated types

 
 instance (OutputableBndr name) => Outputable (InstDecl name) where
 
 
 instance (OutputableBndr name) => Outputable (InstDecl name) where
 

-    ppr (InstDecl inst_ty binds uprags)
+    ppr (InstDecl inst_ty binds uprags ats)

       = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
       = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],

+             nest 4 (ppr ats),

              nest 4 (ppr uprags),
              nest 4 (pprLHsBinds binds) ]
              nest 4 (ppr uprags),
              nest 4 (pprLHsBinds binds) ]

+
+-- Extract the declarations of associated types from an instance
+--
+instDeclATs :: InstDecl name -> [LTyClDecl name]
+instDeclATs (InstDecl _ _ _ ats) = ats

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

diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index 750744a..e4e8ac5 100644 (file)
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
               (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info other = (0,0)
 
               (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
     class_info other = (0,0)
 

-    inst_info (InstDecl _ inst_meths inst_sigs)
+    inst_info (InstDecl _ inst_meths inst_sigs _)  -- !!!TODO: ATs info -=chak

        = case count_sigs (map unLoc inst_sigs) of
            (_,_,ss,is) ->
               (addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is)
        = case count_sigs (map unLoc inst_sigs) of
            (_,_,ss,is) ->
               (addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is)

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 4e98c24..da00825 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -45,6 +45,17 @@ import GLAEXTS
 
 {-
 -----------------------------------------------------------------------------
 
 {-
 -----------------------------------------------------------------------------

+26 July 2006
+
+Conflicts: 37 shift/reduce
+           1 reduce/reduce
+
+The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+  -=chak
+
+-----------------------------------------------------------------------------

 Conflicts: 36 shift/reduce (1.25)
 
 10 for abiguity in 'if x then y else z + 1'            [State 178]
 Conflicts: 36 shift/reduce (1.25)
 
 10 for abiguity in 'if x then y else z + 1'            [State 178]

@@ -430,10 +441,12 @@ topdecls :: { OrdList (LHsDecl RdrName) }
        | topdecl                       { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
        | topdecl                       { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }

-       : tycl_decl                     { unitOL (L1 (TyClD (unLoc $1))) }
+       : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
+       | ty_decl                       {% checkTopTyClD $1 >>= return.unitOL.L1 }

        | 'instance' inst_type where
        | 'instance' inst_type where

-               { let (binds,sigs) = cvBindsAndSigs (unLoc $3)
-                 in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+               { let (binds, sigs, ats) = cvBindsAndSigs (unLoc $3)
+                 in unitOL (L (comb3 $1 $2 $3) 
+                           (InstD (InstDecl $2 binds sigs ats))) }

        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
        | '{-# DEPRECATED' deprecations '#-}'   { $2 }

@@ -446,7 +459,21 @@ topdecl :: { OrdList (LHsDecl RdrName) }
                                                        L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
                                                  )) }
 
                                                        L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
                                                  )) }
 

-tycl_decl :: { LTyClDecl RdrName }
+-- Type classes
+--
+cl_decl :: { LTyClDecl RdrName }
+       : 'class' tycl_hdr fds where
+               {% do { let { (binds, sigs, ats)           = 
+                               cvBindsAndSigs (unLoc $4)
+                           ; (ctxt, tc, tvs, Just tparms) = unLoc $2}
+                      ; checkTyVars tparms
+                     ; return $ L (comb4 $1 $2 $3 $4) 
+                                  (mkClassDecl (ctxt, tc, tvs) 
+                                               (unLoc $3) sigs binds ats) } }
+
+-- Type declarations
+--
+ty_decl :: { LTyClDecl RdrName }

        : 'type' type '=' ctype 
                -- Note type on the left of the '='; this allows
                -- infix type constructors to be declared
        : 'type' type '=' ctype 
                -- Note type on the left of the '='; this allows
                -- infix type constructors to be declared

@@ -469,13 +496,6 @@ tycl_decl :: { LTyClDecl RdrName }
                { L (comb4 $1 $2 $4 $5)
                    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 
                { L (comb4 $1 $2 $4 $5)
                    (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
 

-       | 'class' tycl_hdr fds where
-               { let 
-                       (binds,sigs) = cvBindsAndSigs (unLoc $4)
-                 in
-                 L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs 
-                                         binds) }
-

 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }
 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }

@@ -484,19 +504,49 @@ opt_kind_sig :: { Maybe Kind }
        :                               { Nothing }
        | '::' kind                     { Just $2 }
 
        :                               { Nothing }
        | '::' kind                     { Just $2 }
 

--- tycl_hdr parses the header of a type or class decl,
+-- tycl_hdr parses the header of a type decl,

 -- which takes the form
 --     T a b
 --     Eq a => T a
 --     (Eq a, Ord b) => T a b
 -- which takes the form
 --     T a b
 --     Eq a => T a
 --     (Eq a, Ord b) => T a b

+--      T Int [a]                      -- for associated types

 -- Rather a lot of inlining here, else we get reduce/reduce errors
 -- Rather a lot of inlining here, else we get reduce/reduce errors

-tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) }
+tycl_hdr :: { Located (LHsContext RdrName, 
+                      Located RdrName, 
+                      [LHsTyVarBndr RdrName],
+                      Maybe [LHsType RdrName]) }

        : context '=>' type             {% checkTyClHdr $1         $3 >>= return.LL }
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 
        : context '=>' type             {% checkTyClHdr $1         $3 >>= return.LL }
        | type                          {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
 
 -----------------------------------------------------------------------------
 -- Nested declarations
 

+-- Type declaration or value declaration
+--
+tydecl  :: { Located (OrdList (LHsDecl RdrName)) }
+tydecl  : ty_decl                      { LL (unitOL (L1 (TyClD (unLoc $1)))) }
+       | decl                          { $1 }
+
+tydecls        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
+       : tydecls ';' tydecl            { LL (unLoc $1 `appOL` unLoc $3) }
+       | tydecls ';'                   { LL (unLoc $1) }
+       | tydecl                        { $1 }
+       | {- empty -}                   { noLoc nilOL }
+
+
+tydecllist 
+        :: { Located (OrdList (LHsDecl RdrName)) }     -- Reversed
+       : '{'            tydecls '}'    { LL (unLoc $2) }
+       |     vocurly    tydecls close  { $2 }
+
+-- Form of the body of class and instance declarations
+--
+where  :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
+                               -- No implicit parameters
+                               -- May have type declarations
+       : 'where' tydecllist            { LL (unLoc $2) }
+       | {- empty -}                   { noLoc nilOL }
+

 decls  :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }
 decls  :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { LL (unLoc $1 `appOL` unLoc $3) }
        | decls ';'                     { LL (unLoc $1) }

@@ -508,17 +558,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
        : '{'            decls '}'      { LL (unLoc $2) }
        |     vocurly    decls close    { $2 }
 
        : '{'            decls '}'      { LL (unLoc $2) }
        |     vocurly    decls close    { $2 }
 

-where  :: { Located (OrdList (LHsDecl RdrName)) }
-                               -- No implicit parameters
-       : 'where' decllist              { LL (unLoc $2) }
-       | {- empty -}                   { noLoc nilOL }
-
+-- Binding groups other than those of class and instance declarations
+--

 binds  ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
 binds  ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters

+                                               -- No type declarations

        : decllist                      { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
        | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }       -- May have implicit parameters
        : decllist                      { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
        | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }       -- May have implicit parameters

+                                               -- No type declarations

        : 'where' binds                 { LL (unLoc $2) }
        | {- empty -}                   { noLoc emptyLocalBinds }
 
        : 'where' binds                 { LL (unLoc $2) }
        | {- empty -}                   { noLoc emptyLocalBinds }
 

diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index b24ec2e..a6ee5dd 100644 (file)
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -88,10 +88,18 @@ tdefs       :: { [TyClDecl RdrName] }
 
 tdef   :: { TyClDecl RdrName }
        : '%data' q_tc_name tv_bndrs '=' '{' cons '}'
 
 tdef   :: { TyClDecl RdrName }
        : '%data' q_tc_name tv_bndrs '=' '{' cons '}'

-                { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
+                { mkTyData DataType ( noLoc []
+                                   , noLoc (ifaceExtRdrName $2)
+                                   , map toHsTvBndr $3
+                                   , Nothing
+                                   ) Nothing $6 Nothing }

        | '%newtype' q_tc_name tv_bndrs trep 
                { let tc_rdr = ifaceExtRdrName $2 in
        | '%newtype' q_tc_name tv_bndrs trep 
                { let tc_rdr = ifaceExtRdrName $2 in

-                  mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
+                  mkTyData NewType ( noLoc []
+                                  , noLoc tc_rdr
+                                  , map toHsTvBndr $3
+                                  , Nothing
+                                  ) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }

 
 -- For a newtype we have to invent a fake data constructor name
 -- It doesn't matter what it is, because it won't be used
 
 -- For a newtype we have to invent a fake data constructor name
 -- It doesn't matter what it is, because it won't be used

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index ca24070..777ff64 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -8,7 +8,7 @@ module RdrHsSyn (
        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        extractHsTyRdrTyVars, 
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  

-       mkHsOpApp, mkClassDecl, 
+       mkHsOpApp, mkClassDecl,

        mkHsNegApp, mkHsIntegral, mkHsFractional,
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkHsNegApp, mkHsIntegral, mkHsFractional,
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 

@@ -36,7 +36,9 @@ module RdrHsSyn (
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])

+       checkTyVars,          -- [LHsType RdrName] -> P ()

        checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
        checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])

+       checkTopTyClD,        -- LTyClDecl RdrName -> P (HsDecl RdrName)

        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]
        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
        checkPatterns,        -- SrcLoc -> [HsExp] -> P [HsPat]

@@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,
   = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
                tcdFDs = fds,  
                tcdSigs = sigs,

-               tcdMeths = mbinds
+               tcdMeths = mbinds,
+               tcdATs   = ats

                }
 
                }
 

-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv

   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
   = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,

-            tcdTyVars = tyvars,  tcdCons = data_cons, 
+            tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, 

             tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 \end{code}
 
             tcdKindSig = ksig, tcdDerivs = maybe_deriv }
 \end{code}
 

@@ -198,23 +201,29 @@ cvTopDecls decls = go (fromOL decls)
                            where (L l' b', ds') = getMonoBind (L l b) ds
     go (d : ds)            = d : go ds
 
                            where (L l' b', ds') = getMonoBind (L l b) ds
     go (d : ds)            = d : go ds
 

+-- Declaration list may only contain value bindings and signatures
+--

 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding
 cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
 cvBindGroup binding

-  = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
-    ValBindsIn mbs sigs
-    }
+  = case cvBindsAndSigs binding of
+      (mbs, sigs, []) ->                 -- list of type decls *always* empty
+        ValBindsIn mbs sigs

 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)

-  -> (Bag (LHsBind RdrName), [LSig RdrName])
+  -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])

 -- Input decls contain just value bindings and signatures
 -- Input decls contain just value bindings and signatures

+-- and in case of class or instance declarations also
+-- associated data or synonym definitions

 cvBindsAndSigs  fb = go (fromOL fb)
   where
 cvBindsAndSigs  fb = go (fromOL fb)
   where

-    go []                 = (emptyBag, [])
-    go (L l (SigD s) : ds) = (bs, L l s : ss)
-                           where (bs,ss) = go ds
-    go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
-                           where (b',ds') = getMonoBind (L l b) ds
-                                 (bs,ss)  = go ds'
+    go []                 = (emptyBag, [], [])
+    go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
+                           where (bs, ss, ts) = go ds
+    go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+                           where (b', ds')    = getMonoBind (L l b) ds
+                                 (bs, ss, ts) = go ds'
+    go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
+                           where (bs, ss, ts) = go ds

 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups
 
 -----------------------------------------------------------------------------
 -- Group function bindings into equation groups

@@ -368,44 +377,61 @@ checkInstType (L l t)
        ty ->   do dict_ty <- checkDictTy (L l ty)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
        ty ->   do dict_ty <- checkDictTy (L l ty)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 

-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs 
-  = mapM chk tvs
+-- Check that the given list of type parameters are all type variables
+-- (possibly with a kind signature).
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tvs = mapM_ chk tvs

   where
   where

-       --  Check that the name space is correct!
+       -- Check that the name space is correct!

     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))

-       | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+       | isRdrTyVar tv = return ()

     chk (L l (HsTyVar tv))
     chk (L l (HsTyVar tv))

-        | isRdrTyVar tv = return (L l (UserTyVar tv))
+        | isRdrTyVar tv = return ()

     chk (L l other)
        = parseError l "Type found where type variable expected"
 
 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
     chk (L l other)
        = parseError l "Type found where type variable expected"
 
 checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])

-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
+checkSynHdr ty = do { (_, tc, tvs, Just tparms) <- checkTyClHdr (noLoc []) ty
+                   ; checkTyVars tparms

                    ; return (tc, tvs) }
 
 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
                    ; return (tc, tvs) }
 
 checkTyClHdr :: LHsContext RdrName -> LHsType RdrName

-  -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+  -> P (LHsContext RdrName,         -- the type context
+        Located RdrName,            -- the head symbol (type or class name)
+       [LHsTyVarBndr RdrName],      -- free variables of the non-context part
+       Maybe [LHsType RdrName])     -- parameters of head symbol; wrapped into
+                                    -- 'Maybe' for 'mkTyData'

 -- The header of a type or class decl should look like
 --     (C a, D b) => T a b
 -- or  T a b
 -- or  a + b
 -- etc
 -- The header of a type or class decl should look like
 --     (C a, D b) => T a b
 -- or  T a b
 -- or  a + b
 -- etc

+-- With associated types, we can also have non-variable parameters; ie,
+--      T Int [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result.  Eg, for
+--      T Int [a]
+-- we return
+--      ('()', 'T', ['a'], Just ['Int', '[a]'])

 checkTyClHdr (L l cxt) ty
 checkTyClHdr (L l cxt) ty

-  = do (tc, tvs) <- gol ty []
+  = do (tc, tvs, parms) <- gol ty []

        mapM_ chk_pred cxt
        mapM_ chk_pred cxt

-       return (L l cxt, tc, tvs)
+       return (L l cxt, tc, tvs, Just parms)

   where
     gol (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc)    acc 
   where
     gol (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc)    acc 

-       | not (isRdrTyVar tc)   = checkTyVars acc               >>= \ tvs ->
-                                 return (L l tc, tvs)
-    go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)      >>= \ tvs ->
-                                 return (tc, tvs)
+       | not (isRdrTyVar tc)   = do
+                                   tvs <- extractTyVars acc
+                                   return (L l tc, tvs, acc)
+    go l (HsOpTy t1 tc t2) acc  = do
+                                   tvs <- extractTyVars (t1:t2:acc)
+                                   return (tc, tvs, acc)

     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
     go l (HsParTy ty)    acc    = gol ty acc
     go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)

-    go l other          acc    = parseError l "Malformed LHS to type of class declaration"
+    go l other          acc    = 
+      parseError l "Malformed head of type or class declaration"

 
        -- The predicates in a type or class decl must all
        -- be HsClassPs.  They need not all be type variables,
 
        -- The predicates in a type or class decl must all
        -- be HsClassPs.  They need not all be type variables,

@@ -414,7 +440,63 @@ checkTyClHdr (L l cxt) ty
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 
     chk_pred (L l _)
        = parseError l "Malformed context in type or class declaration"
 

-  
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+--   declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects [] tvs
+  where
+        -- Collect all variables (1st arg serves as an accumulator)
+    collect tvs (L l (HsForAllTy _ _ _ _)) =
+      parseError l "Forall type not allowed as type parameter"
+    collect tvs (L l (HsTyVar tv))
+      | isRdrTyVar tv                     = return $ L l (UserTyVar tv) : tvs
+      | otherwise                         = return tvs
+    collect tvs (L l (HsBangTy _ _      )) =
+      parseError l "Bang-style type annotations not allowed as type parameter"
+    collect tvs (L l (HsAppTy t1 t2     )) = do
+                                              tvs' <- collect tvs t2
+                                              collect tvs' t1
+    collect tvs (L l (HsFunTy t1 t2     )) = do
+                                              tvs' <- collect tvs t2
+                                              collect tvs' t1
+    collect tvs (L l (HsListTy t        )) = collect tvs t
+    collect tvs (L l (HsPArrTy t        )) = collect tvs t
+    collect tvs (L l (HsTupleTy _ ts    )) = collects tvs ts
+    collect tvs (L l (HsOpTy t1 _ t2    )) = do
+                                              tvs' <- collect tvs t2
+                                              collect tvs' t1
+    collect tvs (L l (HsParTy t         )) = collect tvs t
+    collect tvs (L l (HsNumTy t         )) = return tvs
+    collect tvs (L l (HsPredTy t        )) = 
+      parseError l "Predicate not allowed as type parameter"
+    collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
+       | isRdrTyVar tv                    = 
+         return $ L l (KindedTyVar tv k) : tvs
+       | otherwise                        =
+         parseError l "Kind signature only allowed for type variables"
+    collect tvs (L l (HsSpliceTy t      )) = 
+      parseError l "Splice not allowed as type parameter"
+
+        -- Collect all variables of a list of types
+    collects tvs []     = return tvs
+    collects tvs (t:ts) = do
+                           tvs' <- collects tvs ts
+                           collect tvs' t
+
+-- Wrap a toplevel type or class declaration into 'TyClDecl' after ensuring
+-- that all type parameters are variables only (which is in contrast to
+-- associated type declarations).
+--
+checkTopTyClD :: LTyClDecl RdrName -> P (HsDecl RdrName)
+checkTopTyClD (L _ d@TyData {tcdTyPats = Just typats}) = 
+  do
+    checkTyVars typats
+    return $ TyClD d {tcdTyPats = Nothing}
+checkTopTyClD (L _ d)                             = return $ TyClD d
+

 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l t)
   = check t
 checkContext :: LHsType RdrName -> P (LHsContext RdrName)
 checkContext (L l t)
   = check t

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 59c5959..713fe00 100644 (file)
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -468,6 +468,7 @@ rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
 \end{code}
 
 
 \end{code}
 
 

+

 %************************************************************************
 %*                                                                     *
 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 %************************************************************************
 %*                                                                     *
 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index d16e3d6..d1967c8 100644 (file)
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -17,6 +17,7 @@ import DynFlags               ( DynFlag(..), GhcMode(..), DynFlags(..) )
 import HsSyn           ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          ForeignDecl(..), HsGroup(..), HsValBinds(..),
                          Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
 import HsSyn           ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          ForeignDecl(..), HsGroup(..), HsValBinds(..),
                          Sig(..), collectHsBindLocatedBinders, tyClDeclNames,

+                         instDeclATs,

                          LIE )
 import RnEnv
 import IfaceEnv                ( ifaceExportNames )
                          LIE )
 import RnEnv
 import IfaceEnv                ( ifaceExportNames )

@@ -57,6 +58,7 @@ import DriverPhases   ( isHsBoot )
 import Util            ( notNull )
 import List            ( partition )
 import IO              ( openFile, IOMode(..) )
 import Util            ( notNull )
 import List            ( partition )
 import IO              ( openFile, IOMode(..) )

+import Monad           ( liftM )

 \end{code}
 
 
 \end{code}
 
 

@@ -409,14 +411,24 @@ used for source code.
 
        *** See "THE NAMING STORY" in HsDecls ****
 
 
        *** See "THE NAMING STORY" in HsDecls ****
 

+Associated data types: Instances declarations may contain definitions of
+associated data types whose data constructors we need to collect, too.
+However, we need to be careful with the handling of the data type constructor
+of each asscociated type, as it is already defined in the corresponding
+class.  We make a new name for it, but don't return it in the 'AvailInfo' (to
+avoid raising a duplicate declaration error; see the helper
+'unavail_main_name').
+

 \begin{code}
 getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name]
 getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, 
                                      hs_tyclds = tycl_decls, 
 \begin{code}
 getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name]
 getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, 
                                      hs_tyclds = tycl_decls, 

+                                     hs_instds = inst_decls,

                                      hs_fords = foreign_decls })
   = do { tc_names_s <- mappM new_tc tycl_decls
                                      hs_fords = foreign_decls })
   = do { tc_names_s <- mappM new_tc tycl_decls

+       ; at_names_s <- mappM inst_ats inst_decls

        ; val_names  <- mappM new_simple val_bndrs
        ; val_names  <- mappM new_simple val_bndrs

-       ; return (foldr (++) val_names tc_names_s) }
+       ; return (foldr (++) val_names (tc_names_s ++ concat at_names_s)) }

   where
     mod        = tcg_mod gbl_env
     is_hs_boot = isHsBoot (tcg_src gbl_env) ;
   where
     mod        = tcg_mod gbl_env
     is_hs_boot = isHsBoot (tcg_src gbl_env) ;

@@ -437,6 +449,10 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
             ; return (main_name : sub_names) }
        where
          (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
             ; return (main_name : sub_names) }
        where
          (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)

+
+    inst_ats inst_decl 
+       = mappM (liftM tail . new_tc) (instDeclATs (unLoc inst_decl))
+                      -- drop main_rdr (already declared in class)

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index ae994d0..477307e 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -15,8 +15,8 @@ module RnSource (
 import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn
 import {-# SOURCE #-} RnExpr( rnLExpr )
 
 import HsSyn

-import RdrName         ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
-                         GlobalRdrElt(..), isLocalGRE )
+import RdrName         ( RdrName, isRdrDataCon, isRdrTyVar, elemLocalRdrEnv, 
+                         globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )

 import RdrHsSyn                ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes         ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
 import RdrHsSyn                ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 import RnHsSyn
 import RnTypes         ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )

@@ -42,6 +42,7 @@ import SrcLoc         ( Located(..), unLoc, noLoc )
 import DynFlags        ( DynFlag(..) )
 import Maybes          ( seqMaybe )
 import Maybe            ( isNothing )
 import DynFlags        ( DynFlag(..) )
 import Maybes          ( seqMaybe )
 import Maybe            ( isNothing )

+import Monad           ( liftM )

 import BasicTypes       ( Boxity(..) )
 \end{code}
 
 import BasicTypes       ( Boxity(..) )
 \end{code}
 

@@ -109,8 +110,10 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
           <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
        
        let {
           <- 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,
           rn_group = HsGroup { hs_valds  = rn_val_decls,

-                               hs_tyclds = rn_tycl_decls,
+                               hs_tyclds = rn_tycl_decls ++ rn_at_decls,

                                hs_instds = rn_inst_decls,
                                hs_fixds  = rn_fix_decls,
                                hs_depds  = [],
                                hs_instds = rn_inst_decls,
                                hs_fixds  = rn_fix_decls,
                                hs_depds  = [],

@@ -270,10 +273,21 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

-rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)

        -- Used for both source and interface file decls
   = rnHsSigType (text "an instance decl") inst_ty      `thenM` \ inst_ty' ->
 
        -- Used for both source and interface file decls
   = rnHsSigType (text "an instance decl") inst_ty      `thenM` \ inst_ty' ->
 

+       -- Rename the associated types
+       -- 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_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) ->
+

        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all 
        -- the bindings are for the right class
        -- Rename the bindings
        -- The typechecker (not the renamer) checks that all 
        -- the bindings are for the right class

@@ -302,9 +316,36 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
     in
     bindLocalNames binders (renameSigs ok_sig uprags)  `thenM` \ uprags' ->
 
     in
     bindLocalNames binders (renameSigs ok_sig uprags)  `thenM` \ uprags' ->
 

-    returnM (InstDecl inst_ty' mbinds' uprags',
-            meth_fvs `plusFV` hsSigsFVs uprags'
+    returnM (InstDecl inst_ty' mbinds' uprags' ats',
+            meth_fvs `plusFV` at_fvs
+                     `plusFV` hsSigsFVs uprags'

                      `plusFV` extractHsTyNames inst_ty')
                      `plusFV` extractHsTyNames inst_ty')

+             -- We return the renamed associated data type declarations so
+             -- that they can be entered into the list of type declarations
+             -- for the binding group, but we also keep a copy in the instance.
+             -- The latter is needed for well-formedness checks in the type
+             -- checker (eg, to ensure that all ATs of the instance actually
+             -- receive a declaration). 
+            -- NB: Even the copies in the instance declaration carry copies of
+            --     the instance context after renaming.  This is a bit
+            --     strange, but should not matter (and it would be more work
+            --     to remove the context).
+\end{code}
+
+Renaming of the associated data definitions requires adding the instance
+context, as the rhs of an AT declaration may use ATs from classes in the
+context.
+
+\begin{code}
+rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] 
+         -> RnM ([LTyClDecl Name], FreeVars)
+rnATDefs ctxt atDecls = 
+  mapFvRn (wrapLocFstM addCtxtAndRename) atDecls
+  where
+    -- The parser won't accept anything, but a data declaration
+    addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = 
+      rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)})
+      -- The source loc is somewhat half hearted... -=chak

 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 

@@ -450,27 +491,30 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_
             emptyFVs)
 
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
             emptyFVs)
 
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,

-                   tcdTyVars = tyvars, tcdCons = condecls, 
-                   tcdKindSig = sig, tcdDerivs = derivs})
+                   tcdTyVars = tyvars, tcdTyPats = typatsMaybe, 
+                   tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs})

   | is_vanilla -- Normal Haskell data type decl
   = 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
        ; context' <- rnContext data_doc context
   | is_vanilla -- Normal Haskell data type decl
   = 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
        ; context' <- rnContext data_doc context

+       ; typats' <- rnTyPats data_doc typatsMaybe

        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; checkDupNames data_doc con_names
        ; condecls' <- rnConDecls (unLoc tycon') condecls
        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; checkDupNames data_doc con_names
        ; condecls' <- rnConDecls (unLoc tycon') condecls

-       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
-                          tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', 
-                          tcdDerivs = derivs'}, 
+       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', 
+                          tcdLName = tycon', tcdTyVars = tyvars', 
+                          tcdTyPats = typats', tcdKindSig = Nothing, 
+                          tcdCons = condecls', tcdDerivs = derivs'}, 

                   delFVs (map hsLTyVarName tyvars')    $
                   extractHsCtxtTyNames context'        `plusFV`
                   delFVs (map hsLTyVarName tyvars')    $
                   extractHsCtxtTyNames context'        `plusFV`

-                  plusFVs (map conDeclFVs condecls') `plusFV`
+                  plusFVs (map conDeclFVs condecls')   `plusFV`

                   deriv_fvs) }
 
   | otherwise  -- GADT
                   deriv_fvs) }
 
   | otherwise  -- GADT

-  = do { tycon' <- lookupLocatedTopBndrRn tycon
+  = ASSERT( null typats )       -- GADTs cannot have type patterns for now
+    do { tycon' <- lookupLocatedTopBndrRn tycon

        ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
        ; tyvars' <- bindTyVarsRn data_doc tyvars 
                                  (\ tyvars' -> return tyvars')
        ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
        ; tyvars' <- bindTyVarsRn data_doc tyvars 
                                  (\ tyvars' -> return tyvars')

@@ -480,9 +524,10 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; checkDupNames data_doc con_names
        ; condecls' <- rnConDecls (unLoc tycon') condecls
        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; checkDupNames data_doc con_names
        ; condecls' <- rnConDecls (unLoc tycon') condecls

-       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
-                          tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
-                          tcdDerivs = derivs'}, 
+       ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
+                          tcdLName = tycon', tcdTyVars = tyvars', 
+                          tcdTyPats = Nothing, tcdKindSig = sig,
+                          tcdCons = condecls', tcdDerivs = derivs'}, 

                   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 
   where
                   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 
   where

@@ -512,16 +557,23 @@ rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
 
 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
                       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
 
 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
                       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 

-                      tcdMeths = mbinds})
+                      tcdMeths = mbinds, tcdATs = ats})

   = lookupLocatedTopBndrRn cname               `thenM` \ cname' ->
 
        -- Tyvars scope over superclass context and method signatures
     bindTyVarsRn cls_doc tyvars                        ( \ tyvars' ->
        rnContext cls_doc context       `thenM` \ context' ->
        rnFds cls_doc fds               `thenM` \ fds' ->
   = lookupLocatedTopBndrRn cname               `thenM` \ cname' ->
 
        -- Tyvars scope over superclass context and method signatures
     bindTyVarsRn cls_doc tyvars                        ( \ tyvars' ->
        rnContext cls_doc context       `thenM` \ context' ->
        rnFds cls_doc fds               `thenM` \ fds' ->

+       rnATs tyvars' ats               `thenM` \ (ats', ats_fvs) ->

        renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
        renameSigs okClsDclSig sigs     `thenM` \ sigs' ->

-       returnM   (tyvars', context', fds', sigs')
-    )  `thenM` \ (tyvars', context', fds', sigs') ->
+       returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
+    )  `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
+
+       -- Check for duplicates among the associated types
+    let
+      at_rdr_names_w_locs      = [tcdLName ty | L _ ty <- ats]
+    in
+    checkDupNames at_doc at_rdr_names_w_locs   `thenM_`

 
        -- Check the signatures
        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 
        -- Check the signatures
        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).

@@ -555,17 +607,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
         rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
     ) `thenM` \ (mbinds', meth_fvs) ->
 
         rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
     ) `thenM` \ (mbinds', meth_fvs) ->
 

-    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
-                        tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
+    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', 
+                        tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+                        tcdMeths = mbinds', tcdATs = ats'},

             delFVs (map hsLTyVarName tyvars')  $
             extractHsCtxtTyNames context'          `plusFV`
             plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
             hsSigsFVs sigs'                        `plusFV`
             delFVs (map hsLTyVarName tyvars')  $
             extractHsCtxtTyNames context'          `plusFV`
             plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
             hsSigsFVs sigs'                        `plusFV`

-            meth_fvs)
+            meth_fvs                               `plusFV`
+            ats_fvs)

   where
     meth_doc = text "In the default-methods for class" <+> ppr cname
     cls_doc  = text "In the declaration for class"     <+> ppr cname
     sig_doc  = text "In the signatures for class"      <+> ppr cname
   where
     meth_doc = text "In the default-methods for class" <+> ppr cname
     cls_doc  = text "In the declaration for class"     <+> ppr cname
     sig_doc  = text "In the signatures for class"      <+> ppr cname

+    at_doc   = text "In the associated types for class"        <+> ppr cname

 
 badGadtStupidTheta tycon
   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 
 badGadtStupidTheta tycon
   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),

@@ -579,6 +634,14 @@ badGadtStupidTheta tycon
 %*********************************************************
 
 \begin{code}
 %*********************************************************
 
 \begin{code}

+-- Although, we are processing type patterns here, all type variables should
+-- already be in scope (they are the same as in the 'tcdTyVars' field of the
+-- type declaration to which these patterns belong)
+--
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
+rnTyPats _   Nothing       = return Nothing
+rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
+

 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 rnConDecls tycon condecls
   = mappM (wrapLocM rnConDecl) condecls
 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 rnConDecls tycon condecls
   = mappM (wrapLocM rnConDecl) condecls

@@ -680,6 +743,77 @@ rnFds doc fds
 
 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 rnHsTyvar doc tyvar = lookupOccRn tyvar
 
 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 rnHsTyvar doc tyvar = lookupOccRn tyvar

+
+-- Rename associated data type declarations
+--
+rnATs :: [LHsTyVarBndr Name] -> [LTyClDecl RdrName] 
+      -> RnM ([LTyClDecl Name], FreeVars)
+rnATs classLTyVars ats
+  = mapFvRn (wrapLocFstM rn_at) ats
+  where
+    -- The parser won't accept anything, but a data declarations
+    rn_at (tydecl@TyData {tcdCtxt = L ctxtL ctxt, tcdLName = tycon, 
+                         tcdTyPats = Just typats, tcdCons = condecls,
+                         tcdDerivs = derivs}) =
+      do { checkM (null ctxt    ) $ addErr atNoCtxt    -- no context
+         ; checkM (null condecls) $ addErr atNoCons    -- no constructors
+        -- check and collect type parameters
+         ; let (idxParms, excessParms) = splitAt (length classLTyVars) typats
+        ; zipWithM_ cmpTyVar idxParms classLTyVars
+        ; excessTyVars <- liftM catMaybes $ mappM chkTyVar excessParms
+        -- bind excess parameters
+        ; bindTyVarsRn data_doc excessTyVars   $ \ excessTyVars' -> do {
+        ; tycon' <- lookupLocatedTopBndrRn tycon
+        ; (derivs', deriv_fvs) <- rn_derivs derivs
+        ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = L ctxtL [], 
+                           tcdLName = tycon', 
+                           tcdTyVars = classLTyVars ++ excessTyVars',
+                           tcdTyPats = Nothing, tcdKindSig = Nothing, 
+                           tcdCons = [], tcdDerivs = derivs'}, 
+                   delFVs (map hsLTyVarName (classLTyVars ++ excessTyVars')) $
+                   deriv_fvs) } }
+      where
+           -- Check that the name space is correct!
+       cmpTyVar (L l ty@(HsTyVar tv)) classTV =      -- just a type variable
+         checkM (rdrNameOcc tv == nameOccName classTVName) $ 
+           mustMatchErr l ty classTVName
+          where
+           classTVName = hsLTyVarName classTV
+       cmpTyVar (L l ty@(HsKindSig (L _ (HsTyVar tv)) k)) _ | isRdrTyVar tv = 
+         noKindSigErr l tv   -- additional kind sig not allowed at class parms
+       cmpTyVar (L l otherTy) _ = 
+         tyVarExpectedErr l  -- parameter must be a type variable
+
+           -- Check that the name space is correct!
+       chkTyVar (L l (HsKindSig (L _ (HsTyVar tv)) k))
+         | isRdrTyVar tv      = return $ Just (L l (KindedTyVar tv k))
+       chkTyVar (L l (HsTyVar tv))
+         | isRdrTyVar tv      = return $ Just (L l (UserTyVar tv))
+       chkTyVar (L l otherTy) = tyVarExpectedErr l >> return Nothing
+                                -- drop parameter; we stop after renaming anyways
+
+        rn_derivs Nothing   = returnM (Nothing, emptyFVs)
+        rn_derivs (Just ds) = do
+                               ds' <- rnLHsTypes data_doc ds
+                               returnM (Just ds', extractHsTyNames_s ds')
+    
+        atNoCtxt = text "Associated data type declarations cannot have a context"
+        atNoCons = text "Associated data type declarations cannot have any constructors"
+        data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
+
+noKindSigErr l ty =
+  addErrAt l $
+    sep [ptext SLIT("No kind signature allowed at copies of class parameters:"),
+         nest 2 $ ppr ty]
+
+mustMatchErr l ty classTV =
+  addErrAt l $
+    sep [ptext SLIT("Type variable"), quotes (ppr ty), 
+        ptext SLIT("must match corresponding class parameter"), 
+        quotes (ppr classTV)]
+
+tyVarExpectedErr l = 
+  addErrAt l (ptext SLIT("Type found where type variable expected"))

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index c610594..ecf4ac9 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -175,8 +175,10 @@ tcLocalInstDecl1 :: LInstDecl Name
        -- Type-check all the stuff before the "where"
        --
        -- We check for respectable instance type, and context
        -- Type-check all the stuff before the "where"
        --
        -- We check for respectable instance type, and context

-tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
+tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))

   =    -- Prime error recovery, set source location
   =    -- Prime error recovery, set source location

+    ASSERT( null ats )
+      -- !!!TODO: Handle the `ats' parameter!!! -=chak

     recoverM (returnM Nothing)         $
     setSrcSpan loc                     $
     addErrCtxt (instDeclCtxt1 poly_ty) $
     recoverM (returnM Nothing)         $
     setSrcSpan loc                     $
     addErrCtxt (instDeclCtxt1 poly_ty) $

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 1fa44ca..0b5e4fc 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -50,7 +50,8 @@ import Outputable
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import UniqFM          ( unitUFM )
 import Unique          ( Unique )
 import UniqSupply      ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
 import UniqFM          ( unitUFM )
 import Unique          ( Unique )

-import DynFlags                ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
+import DynFlags                ( DynFlags(..), DynFlag(..), dopt, dopt_set,
+                         dopt_unset, GhcMode ) 

 import StaticFlags     ( opt_PprStyle_Debug )
 import Bag             ( snocBag, unionBags )
 import Panic           ( showException )
 import StaticFlags     ( opt_PprStyle_Debug )
 import Bag             ( snocBag, unionBags )
 import Panic           ( showException )

@@ -268,6 +269,10 @@ setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                         env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
 
 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
                         env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )
 

+unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
+                        env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
+

 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()    -- Do it flag is true
 ifOptM flag thing_inside = do { b <- doptM flag; 
                                if b then thing_inside else return () }
 ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()    -- Do it flag is true
 ifOptM flag thing_inside = do { b <- doptM flag; 
                                if b then thing_inside else return () }

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 75d582e..1e61c39 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -12,7 +12,7 @@ module TcTyClsDecls (
 
 import HsSyn           ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
                          ConDecl(..),   Sig(..), NewOrData(..), ResType(..),
 
 import HsSyn           ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
                          ConDecl(..),   Sig(..), NewOrData(..), ResType(..),

-                         tyClDeclTyVars, isSynDecl, hsConArgs,
+                         tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs,

                          LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
                        )
 import HsTypes          ( HsBang(..), getBangStrictness )
                          LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
                        )
 import HsTypes          ( HsBang(..), getBangStrictness )

@@ -127,7 +127,12 @@ tcTyAndClassDecls boot_details decls
        ; traceTc (text "tcTyAndCl" <+> ppr mod)
        ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
          do    { let { -- Calculate variances and rec-flag
        ; traceTc (text "tcTyAndCl" <+> ppr mod)
        ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
          do    { let { -- Calculate variances and rec-flag

-                     ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
+                     ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls
+                      ; alg_decls = alg_decls_pre ++ 
+                                   concat [tcdATs decl        -- add AT decls
+                                          | declLoc <- alg_decls_pre
+                                          , let decl = unLoc declLoc
+                                          , isClassDecl decl] }

 
                        -- Extend the global env with the knot-tied results
                        -- for data types and classes
 
                        -- Extend the global env with the knot-tied results
                        -- for data types and classes

@@ -320,6 +325,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
        -- going to remove the constructor while coercing it to a lifted type.
        -- And newtypes can't be bang'd
 
        -- going to remove the constructor while coercing it to a lifted type.
        -- And newtypes can't be bang'd
 

+-- !!!TODO -=chak

 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
   = kcTyClDeclBody decl        $ \ tvs' ->
     do { is_boot <- tcIsHsBoot
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
   = kcTyClDeclBody decl        $ \ tvs' ->
     do { is_boot <- tcIsHsBoot

@@ -434,10 +440,11 @@ tcTyClDecl1 calc_vrcs calc_isrec
 tcTyClDecl1 calc_vrcs calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
              tcdCtxt = ctxt, tcdMeths = meths,
 tcTyClDecl1 calc_vrcs calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
              tcdCtxt = ctxt, tcdMeths = meths,

-             tcdFDs = fundeps, tcdSigs = sigs} )
+             tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )

   = tcTyVarBndrs tvs           $ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps

+  -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak

   ; 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

@@ -704,11 +711,15 @@ checkValidClass cls
        -- class has only one parameter.  We can't do generic
        -- multi-parameter type classes!
        ; checkTc (unary || no_generics) (genericMultiParamErr cls)
        -- class has only one parameter.  We can't do generic
        -- multi-parameter type classes!
        ; checkTc (unary || no_generics) (genericMultiParamErr cls)

+
+       -- Check that the class has no associated types, unless GlaExs
+       ; checkTc (gla_exts || no_ats) (badATDecl cls)

        }
   where
     (tyvars, theta, _, op_stuff) = classBigSig cls
     unary      = isSingleton tyvars
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
        }
   where
     (tyvars, theta, _, op_stuff) = classBigSig cls
     unary      = isSingleton tyvars
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]

+    no_ats      = True -- !!!TODO: determine whether the class has ATs -=chak

 
     check_op gla_exts (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
 
     check_op gla_exts (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do

@@ -820,6 +831,10 @@ newtypeFieldErr con_name n_flds
   = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), 
         nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
 
   = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), 
         nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
 

+badATDecl cl_name
+  = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name)
+        , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ]
+

 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
         nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
         nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]