From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 20:43:38 +0000 (+0000) Subject: Migrate cvs diff from fptools-assoc branch X-Git-Tag: After_FC_branch_merge~128 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=afef39736dcde6f4947a6f362f9e6b3586933db4 Migrate cvs diff from fptools-assoc branch Wed Jul 26 17:46:55 EDT 2006 Manuel M T Chakravarty * 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 --- 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 -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 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 17d6be9..4dd3a6d 100644 --- 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 - ; 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')) - ; 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' } @@ -143,7 +147,7 @@ cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') } + ; return (cxt', tc', tvs', Nothing) } --------------------------------------------------- -- Data types diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index e9ee026..070079e 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -21,6 +21,7 @@ module HsDecls ( isClassDecl, isSynDecl, isDataDecl, countTyClDecls, conDetailsTys, + instDeclATs, collectRuleBndrSigTys, ) where @@ -341,7 +342,8 @@ data TyClDecl name 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 @@ -367,7 +369,10 @@ data TyClDecl name 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 @@ -406,8 +411,9 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located 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) @@ -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}) - = 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, - 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 - 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 {")], - 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 - 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] + -> Maybe [LHsType name] -> 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] +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 @@ -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) - [LSig name] -- User-supplied pragmatic info + [LSig name] -- User-supplied pragmatic info + [LTyClDecl name]-- Associated types 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")], + nest 4 (ppr ats), 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} %************************************************************************ diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 750744a..e4e8ac5 100644 --- 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) - 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) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4e98c24..da00825 100644 --- 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] @@ -430,10 +441,12 @@ topdecls :: { 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 - { 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 } @@ -446,7 +459,21 @@ topdecl :: { OrdList (LHsDecl RdrName) } 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 @@ -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)) } - | '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 } @@ -484,19 +504,49 @@ opt_kind_sig :: { Maybe Kind } : { 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 +-- T Int [a] -- for associated types -- 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 +-- 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) } @@ -508,17 +558,16 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) } : '{' 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 + -- 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 + -- No type declarations : 'where' binds { LL (unLoc $2) } | {- empty -} { noLoc emptyLocalBinds } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index b24ec2e..a6ee5dd 100644 --- 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 '}' - { 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 - 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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index ca24070..777ff64 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -8,7 +8,7 @@ module RdrHsSyn ( extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, + mkHsOpApp, mkClassDecl, 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]) + checkTyVars, -- [LHsType RdrName] -> P () 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] @@ -155,12 +157,13 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds = 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, - tcdTyVars = tyvars, tcdCons = data_cons, + tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, 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 +-- Declaration list may only contain value bindings and signatures +-- 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) - -> (Bag (LHsBind RdrName), [LSig RdrName]) + -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName]) -- 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 - 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 @@ -368,44 +377,61 @@ checkInstType (L l t) 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 - -- Check that the name space is correct! + -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + | isRdrTyVar tv = return () 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]) -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 - -> 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 +-- 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 - = do (tc, tvs) <- gol ty [] + = do (tc, tvs, parms) <- gol ty [] 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 - | 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 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, @@ -414,7 +440,63 @@ checkTyClHdr (L l cxt) ty 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 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 59c5959..713fe00 100644 --- 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} + %************************************************************************ %* * \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 --- 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, + instDeclATs, LIE ) import RnEnv import IfaceEnv ( ifaceExportNames ) @@ -57,6 +58,7 @@ import DriverPhases ( isHsBoot ) import Util ( notNull ) import List ( partition ) import IO ( openFile, IOMode(..) ) +import Monad ( liftM ) \end{code} @@ -409,14 +411,24 @@ used for source code. *** 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, + hs_instds = inst_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 - ; 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) ; @@ -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) + + inst_ats inst_decl + = mappM (liftM tail . new_tc) (instDeclATs (unLoc inst_decl)) + -- drop main_rdr (already declared in class) \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index ae994d0..477307e 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -15,8 +15,8 @@ module RnSource ( 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 ) @@ -42,6 +42,7 @@ import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) import Maybe ( isNothing ) +import Monad ( liftM ) import BasicTypes ( Boxity(..) ) \end{code} @@ -109,8 +110,10 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; let { + rn_at_decls = concat + [ats | L _ (InstDecl _ _ _ ats) <- rn_inst_decls] ; rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, + hs_tyclds = rn_tycl_decls ++ rn_at_decls, 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} -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' -> + -- 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 @@ -302,9 +316,36 @@ rnSrcInstDecl (InstDecl inst_ty mbinds 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') + -- 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 @@ -450,27 +491,30 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ 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 + ; typats' <- rnTyPats data_doc typatsMaybe ; (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` - plusFVs (map conDeclFVs condecls') `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` 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') @@ -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 - ; 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 @@ -512,16 +557,23 @@ rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) 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' -> + rnATs tyvars' ats `thenM` \ (ats', ats_fvs) -> 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). @@ -555,17 +607,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 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` - 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 + 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"), @@ -579,6 +634,14 @@ badGadtStupidTheta tycon %********************************************************* \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 @@ -680,6 +743,77 @@ rnFds doc fds 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} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index c610594..ecf4ac9 100644 --- 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 -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 + ASSERT( null ats ) + -- !!!TODO: Handle the `ats' parameter!!! -=chak 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 --- 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 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 ) @@ -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}} ) +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 () } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 75d582e..1e61c39 100644 --- 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(..), - tyClDeclTyVars, isSynDecl, hsConArgs, + tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs, 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 - ; (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 @@ -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 +-- !!!TODO -=chak 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, - tcdFDs = fundeps, tcdSigs = sigs} ) + tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = 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 @@ -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) + + -- 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] + no_ats = True -- !!!TODO: determine whether the class has ATs -=chak 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] +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)")]