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 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 = [],
-- 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 type definitions in instances.
+Renaming of the associated types 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 rnAtDef) atDecls
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls =
+ mapFvRn (wrapLocFstM rnATInst) atDecls
where
- rnAtDef tydecl@TyFunction {} =
+ rnATInst tydecl@TyFunction {} =
do
addErr noKindSig
rnTyClDecl tydecl
- rnAtDef tydecl@TySynonym {} = rnTyClDecl tydecl
- rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} =
+ rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
+ rnATInst tydecl@TyData {} =
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"
+ rnTyClDecl tydecl
+ rnATInst _ =
+ panic "RnSource.rnATInsts: not a type declaration"
noKindSig = text "Instances cannot have kind signatures"
\end{code}
= 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
= 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
rnTyClDecl (tydecl@TyFunction {}) =
rnTySig tydecl bindTyVarsRn
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
- tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdSynRhs = ty})
= bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- do { name' <- lookupLocatedTopBndrRn name
+ 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) }
+ 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)
tcdTyPats = Nothing, tcdKindSig = sig,
tcdCons = [], tcdDerivs = Nothing},
delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context') } }
+ extractHsCtxtTyNames context')
+ } }
where
rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
; tycon' <- lookupLocatedTopBndrRn tycon
; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
tcdIso = tcdIso tydecl, tcdKind = sig},
- emptyFVs) } }
+ emptyFVs)
+ } }
ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
needOneIdx = text "Kind signature requires at least one type index"
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) =
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.
projects / ghc-hetmet.git / blobdiff