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 _,
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})
......
......@@ -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) } }
......
......@@ -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 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).
......
......@@ -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}
......
......@@ -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.
......
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