From bd865113a1446bb18fb32b546b8776b846a23116 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 21:04:28 +0000 Subject: [PATCH] Added error checks & fixed bugs Thu Aug 3 19:29:38 EDT 2006 Manuel M T Chakravarty * Added error checks & fixed bugs --- compiler/hsSyn/HsDecls.lhs | 8 ++++---- compiler/parser/Parser.y.pp | 1 + compiler/parser/RdrHsSyn.lhs | 14 +++++++++++++- compiler/rename/RnNames.lhs | 9 +++++---- compiler/rename/RnSource.lhs | 39 ++++++++++++++++++++++++++++----------- 5 files changed, 51 insertions(+), 20 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 54075d4..99d58ea 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -451,7 +451,9 @@ isKindSigDecl (TyData {tcdKindSig = Just _, isKindSigDecl other = False -- definition of an instance of an indexed type -isIdxTyDecl = isJust . tcdTyPats +isIdxTyDecl tydecl + | isSynDecl tydecl || isDataDecl tydecl = isJust (tcdTyPats tydecl) + | otherwise = False \end{code} Dealing with names @@ -467,9 +469,7 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name] -- We use the equality to filter out duplicate field names tyClDeclNames (TyFunction {tcdLName = name}) = [name] -tyClDeclNames (TySynonym {tcdLName = name, - tcdTyPats= Nothing}) = [name] -tyClDeclNames (TySynonym {} ) = [] -- type equation +tyClDeclNames (TySynonym {tcdLName = name}) = [name] tyClDeclNames (ForeignType {tcdLName = name}) = [name] tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 3951128..4548221 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -470,6 +470,7 @@ cl_decl :: { LTyClDecl RdrName } cvBindsAndSigs (unLoc $4) ; (ctxt, tc, tvs, tparms) = unLoc $2} ; checkTyVars tparms False -- only type vars allowed + ; checkKindSigs ats ; return $ L (comb4 $1 $2 $3 $4) (mkClassDecl (ctxt, tc, tvs) (unLoc $3) sigs binds ats) } } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 980c7f7..a8449ae 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -38,6 +38,7 @@ module RdrHsSyn ( checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) checkTyVars, -- [LHsType RdrName] -> Bool -> P () checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) + checkKindSigs, -- [LTyClDecl RdrName] -> P () checkTopTypeD, -- LTyClDecl RdrName -> P (HsDecl RdrName) checkInstType, -- HsType -> P HsType checkPattern, -- HsExp -> P HsPat @@ -213,7 +214,7 @@ cvBindsAndSigs :: OrdList (LHsDecl 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 +-- associated type declarations cvBindsAndSigs fb = go (fromOL fb) where go [] = (emptyBag, [], []) @@ -506,6 +507,17 @@ extractTyVars tvs = collects [] tvs tvs' <- collects tvs ts collect tvs' t +-- Check that associated type declarations of a class are all kind signatures. +-- +checkKindSigs :: [LTyClDecl RdrName] -> P () +checkKindSigs = mapM_ check + where + check (L l tydecl) + | isKindSigDecl tydecl + || isSynDecl tydecl = return () + | otherwise = + parseError l "Type declaration in a class must be a kind signature or synonym default" + -- Wrap a toplevel type or data declaration into 'TyClD' and ensure for -- data declarations that all type parameters are variables only (which is in -- contrast to type functions and associated type declarations). diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index d1967c8..6b98283 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -17,7 +17,7 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsValBinds(..), Sig(..), collectHsBindLocatedBinders, tyClDeclNames, - instDeclATs, + instDeclATs, isIdxTyDecl, LIE ) import RnEnv import IfaceEnv ( ifaceExportNames ) @@ -446,13 +446,14 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, new_tc tc_decl = do { main_name <- newTopSrcBinder mod Nothing main_rdr ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs - ; return (main_name : sub_names) } + ; if isIdxTyDecl (unLoc tc_decl) -- index type definitions + then return ( sub_names) -- are usage occurences + else 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) + = mappM new_tc (instDeclATs (unLoc inst_decl)) \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9a92f84..5083044 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -333,20 +333,32 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- 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. +Renaming of the associated type definitions in instances. + +* In the case of associated data and newtype definitions we add the instance + context. +* We raise an error if we encounter a kind signature in an instance. \begin{code} rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) rnATDefs ctxt atDecls = - mapFvRn (wrapLocFstM addCtxtAndRename) atDecls + mapFvRn (wrapLocFstM rnAtDef) 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 + rnAtDef tydecl@TyFunction {} = + do + addErr noKindSig + rnTyClDecl tydecl + rnAtDef tydecl@TySynonym {} = rnTyClDecl tydecl + rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} = + do + checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig + rnTyClDecl (tydecl {tcdCtxt = L l (ctxt ++ tyCtxt)}) + -- The source loc is somewhat half hearted... -=chak + rnAtDef _ = + panic "RnSource.rnATDefs: not a type declaration" + +noKindSig = text "Instances cannot have kind signatures" \end{code} For the method bindings in class and instance decls, we extend the @@ -769,15 +781,17 @@ needOneIdx = text "Kind signature requires at least one type index" -- Rename associated type declarations (in classes) -- --- * This can be data declarations, type function signatures, and (default) --- type function equations. +-- * This can be kind signatures and (default) type function equations. -- rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) rnATs ats = mapFvRn (wrapLocFstM rn_at) ats where rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars - rn_at (tydecl@TySynonym {}) = rnTyClDecl tydecl + rn_at (tydecl@TySynonym {}) = + do + checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns + rnTyClDecl tydecl rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont @@ -789,6 +803,9 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats name' <- lookupOccRn (hsTyVarName tyvar) return $ L l (replaceTyVarName tyvar name') +noPatterns = text "Default definition for an associated synonym cannot have" + <+> text "type pattern" + -- This data decl will parse OK -- data T = a Int -- treating "a" as the constructor. -- 1.7.10.4