import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc,
- elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..),
- isLocalGRE )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv,
+ globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import SrcLoc ( Located(..), unLoc, noLoc )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
-import Maybe ( isNothing, catMaybes )
-import Monad ( liftM )
+import Maybe ( isNothing, isJust )
+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 = [],
-- 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_doc = text "In the associated types of 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' ->
- do { tycon' <- lookupLocatedTopBndrRn tycon
+ do { tycon' <- if isIdxTyDecl tydecl
+ then lookupLocatedOccRn tycon -- may be imported family
+ else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
; typats' <- rnTyPats data_doc typatsMaybe
; (derivs', deriv_fvs) <- rn_derivs derivs
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs) }
+ deriv_fvs `plusFV`
+ (if isIdxTyDecl tydecl
+ then unitFV (unLoc tycon') -- type instance => use
+ else emptyFVs))
+ }
- | otherwise -- GADT
+ | otherwise -- GADT
= ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
- do { tycon' <- lookupLocatedTopBndrRn tycon
+ do { tycon' <- if isIdxTyDecl tydecl
+ then lookupLocatedOccRn tycon -- may be imported family
+ else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = Nothing, tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
-
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs `plusFV`
+ (if isIdxTyDecl tydecl
+ then unitFV (unLoc tycon') -- type instance => use
+ else emptyFVs))
+ }
where
is_vanilla = case condecls of -- Yuk
[] -> True
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 tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+ = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
+ do { name' <- if isIdxTyDecl tydecl
+ then lookupLocatedOccRn name -- may be imported family
+ else 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 `plusFV`
+ (if isIdxTyDecl tydecl
+ then unitFV (unLoc name') -- type instance => use
+ else emptyFVs))
+ }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
rnContext cls_doc context `thenM` \ context' ->
rnFds cls_doc fds `thenM` \ fds' ->
- rnATs tyvars' ats `thenM` \ (ats', ats_fvs) ->
+ rnATs ats `thenM` \ (ats', ats_fvs) ->
renameSigs okClsDclSig sigs `thenM` \ sigs' ->
returnM (tyvars', context', fds', (ats', ats_fvs), sigs')
) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
%*********************************************************
\begin{code}
--- Although, we are processing type patterns here, all type variables should
+-- Although, we are processing type patterns here, all type variables will
-- already be in scope (they are the same as in the 'tcdTyVars' field of the
-- type declaration to which these patterns belong)
--
rnLHsType doc ty `thenM` \ new_ty ->
returnM (new_name, new_ty)
+-- Rename kind signatures (signatures of indexed data types/newtypes and
+-- signatures of type functions)
+--
+-- * This function is parametrised by the routine handling the index
+-- variables. On the toplevel, these are defining occurences, whereas they
+-- are usage occurences for associated types.
+--
+rnTySig :: TyClDecl RdrName
+ -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+ RnM (TyClDecl Name, FreeVars))
+ -> RnM (TyClDecl Name, FreeVars)
+
+rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
+ tcdTyVars = tyvars, tcdTyPats = mb_typats,
+ tcdCons = condecls, tcdKindSig = sig,
+ tcdDerivs = derivs})
+ bindIdxVars =
+ ASSERT( null condecls ) -- won't have constructors
+ ASSERT( isNothing mb_typats ) -- won't have type patterns
+ ASSERT( isNothing derivs ) -- won't have deriving
+ ASSERT( isJust sig ) -- will have kind signature
+ do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; context' <- rnContext (ksig_doc tycon) context
+ ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdCons = [], tcdDerivs = Nothing},
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context')
+ } }
+ where
+
+rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
+ tcdKind = sig})
+ bindIdxVars =
+ do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
+ tcdIso = tcdIso tydecl, tcdKind = sig},
+ emptyFVs)
+ } }
+
+ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
+needOneIdx = text "Kind signature requires at least one type index"
+
+-- Rename associated type declarations (in classes)
+--
+-- * 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 {}) =
+ do
+ checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+ rnTyClDecl tydecl
+ rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
+
+ 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.
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}
projects / ghc-hetmet.git / blobdiff