import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
import Maybe ( isNothing, isJust )
-import Monad ( liftM )
+import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
\end{code}
<- 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 ++ rn_at_decls,
+ hs_tyclds = rn_tycl_decls,
hs_instds = rn_inst_decls,
hs_fixds = rn_fix_decls,
hs_depds = [],
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) ->
+ rnATInsts ats `thenM` \ (ats', at_fvs) ->
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
-- 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 types in instances.
+
+* 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
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls =
+ mapFvRn (wrapLocFstM rnATInst) 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
+ rnATInst tydecl@TyFunction {} =
+ do
+ addErr noKindSig
+ rnTyClDecl tydecl
+ rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
+ rnATInst tydecl@TyData {} =
+ do
+ checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
+ rnTyClDecl tydecl
+ rnATInst _ =
+ panic "RnSource.rnATInsts: 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
returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
emptyFVs)
-rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdTyPats = typatsMaybe,
- tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs})
- | is_vanilla -- Normal Haskell data type decl
+rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
+ tcdLName = tycon, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdCons = condecls,
+ tcdKindSig = sig, tcdDerivs = derivs})
+ | isKindSigDecl tydecl -- kind signature of indexed type
+ = rnTySig tydecl bindTyVarsRn
+ | 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' ->
plusFVs (map conDeclFVs condecls') `plusFV`
deriv_fvs) }
- | otherwise -- GADT
+ | otherwise -- GADT
= ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
do { tycon' <- lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
rn_derivs Nothing = returnM (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
returnM (Just ds', extractHsTyNames_s ds')
-
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
- = lookupLocatedTopBndrRn name `thenM` \ name' ->
- bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) ->
- returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
- tcdSynRhs = ty'},
- delFVs (map hsLTyVarName tyvars') fvs)
+
+rnTyClDecl (tydecl@TyFunction {}) =
+ rnTySig tydecl bindTyVarsRn
+
+rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+ = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
+ do { name' <- lookupLocatedTopBndrRn name
+ ; typats' <- rnTyPats syn_doc typatsMaybe
+ ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
+ ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
+ tcdTyPats = typats', tcdSynRhs = ty'},
+ delFVs (map hsLTyVarName tyvars') fvs) }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnLHsType doc ty `thenM` \ new_ty ->
returnM (new_name, new_ty)
--- This data decl will parse OK
--- data T = a Int
--- treating "a" as the constructor.
--- It is really hard to make the parser spot this malformation.
--- So the renamer has to check that the constructor is legal
---
--- We can get an operator as the constructor, even in the prefix form:
--- data T = :% Int Int
--- from interface files, which always print in prefix form
-
-checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
-
-badDataCon name
- = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Support code to rename types}
-%* *
-%*********************************************************
-
-\begin{code}
-rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
-
-rnFds doc fds
- = mappM (wrapLocM rn_fds) fds
- where
- rn_fds (tys1, tys2)
- = rnHsTyVars doc tys1 `thenM` \ tys1' ->
- rnHsTyVars doc tys2 `thenM` \ tys2' ->
- returnM (tys1', tys2')
-
-rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
-rnHsTyvar doc tyvar = lookupOccRn tyvar
-
-- Rename kind signatures (signatures of indexed data types/newtypes and
-- signatures of type functions)
--
-- 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 (tydelc@TySynonym {}) = panic "!!!TODO: case not impl yet"
+ 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
- --
+ lookupIdxVars _ tyvars cont =
+ do { checkForDups tyvars;
+ ; tyvars' <- mappM lookupIdxVar tyvars
+ ; cont tyvars'
+ }
-- Type index variables must be class parameters, which are the only
-- type variables in scope at this point.
lookupIdxVar (L l tyvar) =
do
name' <- lookupOccRn (hsTyVarName tyvar)
return $ L l (replaceTyVarName tyvar name')
+
+ -- Type variable may only occur once.
+ --
+ checkForDups [] = return ()
+ checkForDups (L loc tv:ltvs) =
+ do { setSrcSpan loc $
+ when (hsTyVarName tv `ltvElem` ltvs) $
+ addErr (repeatedTyVar tv)
+ ; checkForDups ltvs
+ }
+
+ rdrName `ltvElem` [] = False
+ rdrName `ltvElem` (L _ tv:ltvs)
+ | rdrName == hsTyVarName tv = True
+ | otherwise = rdrName `ltvElem` ltvs
+
+noPatterns = text "Default definition for an associated synonym cannot have"
+ <+> text "type pattern"
+
+repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
+ quotes (ppr tv)
+
+-- This data decl will parse OK
+-- data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+-- data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+
+badDataCon name
+ = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Support code to rename types}
+%* *
+%*********************************************************
+
+\begin{code}
+rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
+
+rnFds doc fds
+ = mappM (wrapLocM rn_fds) fds
+ where
+ rn_fds (tys1, tys2)
+ = rnHsTyVars doc tys1 `thenM` \ tys1' ->
+ rnHsTyVars doc tys2 `thenM` \ tys2' ->
+ returnM (tys1', tys2')
+
+rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar = lookupOccRn tyvar
\end{code}