Commit bd865113 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Added error checks & fixed bugs

Thu Aug  3 19:29:38 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Added error checks & fixed bugs
parent 7f7be6d1
...@@ -451,7 +451,9 @@ isKindSigDecl (TyData {tcdKindSig = Just _, ...@@ -451,7 +451,9 @@ isKindSigDecl (TyData {tcdKindSig = Just _,
isKindSigDecl other = False isKindSigDecl other = False
-- definition of an instance of an indexed type -- definition of an instance of an indexed type
isIdxTyDecl = isJust . tcdTyPats isIdxTyDecl tydecl
| isSynDecl tydecl || isDataDecl tydecl = isJust (tcdTyPats tydecl)
| otherwise = False
\end{code} \end{code}
Dealing with names Dealing with names
...@@ -467,9 +469,7 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name] ...@@ -467,9 +469,7 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
-- We use the equality to filter out duplicate field names -- We use the equality to filter out duplicate field names
tyClDeclNames (TyFunction {tcdLName = name}) = [name] tyClDeclNames (TyFunction {tcdLName = name}) = [name]
tyClDeclNames (TySynonym {tcdLName = name, tyClDeclNames (TySynonym {tcdLName = name}) = [name]
tcdTyPats= Nothing}) = [name]
tyClDeclNames (TySynonym {} ) = [] -- type equation
tyClDeclNames (ForeignType {tcdLName = name}) = [name] tyClDeclNames (ForeignType {tcdLName = name}) = [name]
tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
......
...@@ -470,6 +470,7 @@ cl_decl :: { LTyClDecl RdrName } ...@@ -470,6 +470,7 @@ cl_decl :: { LTyClDecl RdrName }
cvBindsAndSigs (unLoc $4) cvBindsAndSigs (unLoc $4)
; (ctxt, tc, tvs, tparms) = unLoc $2} ; (ctxt, tc, tvs, tparms) = unLoc $2}
; checkTyVars tparms False -- only type vars allowed ; checkTyVars tparms False -- only type vars allowed
; checkKindSigs ats
; return $ L (comb4 $1 $2 $3 $4) ; return $ L (comb4 $1 $2 $3 $4)
(mkClassDecl (ctxt, tc, tvs) (mkClassDecl (ctxt, tc, tvs)
(unLoc $3) sigs binds ats) } } (unLoc $3) sigs binds ats) } }
......
...@@ -38,6 +38,7 @@ module RdrHsSyn ( ...@@ -38,6 +38,7 @@ module RdrHsSyn (
checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName]) checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
checkTyVars, -- [LHsType RdrName] -> Bool -> P () checkTyVars, -- [LHsType RdrName] -> Bool -> P ()
checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
checkKindSigs, -- [LTyClDecl RdrName] -> P ()
checkTopTypeD, -- LTyClDecl RdrName -> P (HsDecl RdrName) checkTopTypeD, -- LTyClDecl RdrName -> P (HsDecl RdrName)
checkInstType, -- HsType -> P HsType checkInstType, -- HsType -> P HsType
checkPattern, -- HsExp -> P HsPat checkPattern, -- HsExp -> P HsPat
...@@ -213,7 +214,7 @@ cvBindsAndSigs :: OrdList (LHsDecl RdrName) ...@@ -213,7 +214,7 @@ cvBindsAndSigs :: OrdList (LHsDecl RdrName)
-> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl 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 -- and in case of class or instance declarations also
-- associated type declarations
cvBindsAndSigs fb = go (fromOL fb) cvBindsAndSigs fb = go (fromOL fb)
where where
go [] = (emptyBag, [], []) go [] = (emptyBag, [], [])
...@@ -506,6 +507,17 @@ extractTyVars tvs = collects [] tvs ...@@ -506,6 +507,17 @@ extractTyVars tvs = collects [] tvs
tvs' <- collects tvs ts tvs' <- collects tvs ts
collect tvs' t 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 -- Wrap a toplevel type or data declaration into 'TyClD' and ensure for
-- data declarations that all type parameters are variables only (which is in -- data declarations that all type parameters are variables only (which is in
-- contrast to type functions and associated type declarations). -- contrast to type functions and associated type declarations).
......
...@@ -17,7 +17,7 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) ) ...@@ -17,7 +17,7 @@ import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..), ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames, Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
instDeclATs, instDeclATs, isIdxTyDecl,
LIE ) LIE )
import RnEnv import RnEnv
import IfaceEnv ( ifaceExportNames ) import IfaceEnv ( ifaceExportNames )
...@@ -446,13 +446,14 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, ...@@ -446,13 +446,14 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
new_tc tc_decl new_tc tc_decl
= do { main_name <- newTopSrcBinder mod Nothing main_rdr = do { main_name <- newTopSrcBinder mod Nothing main_rdr
; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs ; 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 where
(main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
inst_ats inst_decl inst_ats inst_decl
= mappM (liftM tail . new_tc) (instDeclATs (unLoc inst_decl)) = mappM new_tc (instDeclATs (unLoc inst_decl))
-- drop main_rdr (already declared in class)
\end{code} \end{code}
......
...@@ -333,20 +333,32 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) ...@@ -333,20 +333,32 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- to remove the context). -- to remove the context).
\end{code} \end{code}
Renaming of the associated data definitions requires adding the instance Renaming of the associated type definitions in instances.
context, as the rhs of an AT declaration may use ATs from classes in the
context. * 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} \begin{code}
rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName]
-> RnM ([LTyClDecl Name], FreeVars) -> RnM ([LTyClDecl Name], FreeVars)
rnATDefs ctxt atDecls = rnATDefs ctxt atDecls =
mapFvRn (wrapLocFstM addCtxtAndRename) atDecls mapFvRn (wrapLocFstM rnAtDef) atDecls
where where
-- The parser won't accept anything, but a data declaration rnAtDef tydecl@TyFunction {} =
addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = do
rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)}) addErr noKindSig
-- The source loc is somewhat half hearted... -=chak 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} \end{code}
For the method bindings in class and instance decls, we extend the 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" ...@@ -769,15 +781,17 @@ needOneIdx = text "Kind signature requires at least one type index"
-- Rename associated type declarations (in classes) -- Rename associated type declarations (in classes)
-- --
-- * This can be data declarations, type function signatures, and (default) -- * This can be kind signatures and (default) type function equations.
-- type function equations.
-- --
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
where where
rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars
rn_at (tydecl@TyFunction {}) = 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" rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
...@@ -789,6 +803,9 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats ...@@ -789,6 +803,9 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
name' <- lookupOccRn (hsTyVarName tyvar) name' <- lookupOccRn (hsTyVarName tyvar)
return $ L l (replaceTyVarName tyvar name') 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 -- This data decl will parse OK
-- data T = a Int -- data T = a Int
-- treating "a" as the constructor. -- treating "a" as the constructor.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment