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 RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
- lookupOccRn, newLocalsRn,
+ lookupOccRn, lookupTopBndrRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalNames, checkDupNames, mapFvRn
)
+import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
import HscTypes ( FixityEnv, FixItem(..),
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
import Maybe ( isNothing, isJust )
-import Monad ( liftM )
+import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
\end{code}
rnSrcDecls (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
hs_fixds = fix_decls,
hs_depds = deprec_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
- hs_ruleds = rule_decls })
+ hs_ruleds = rule_decls,
+ hs_docs = docs })
= do { -- Deal with deprecations (returns only the extra deprecations)
deprecs <- rnSrcDeprecDecls deprec_decls ;
-- So we content ourselves with gathering uses only; that
-- means we'll only report a declaration as unused if it isn't
-- mentioned at all. Ah well.
+ traceRn (text "Start rnTyClDecls") ;
(rn_tycl_decls, src_fvs1)
<- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
+ traceRn (text "finish rnTyClDecls") ;
(rn_inst_decls, src_fvs2)
<- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
+ (rn_deriv_decls, src_fvs_deriv)
+ <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ;
(rn_rule_decls, src_fvs3)
<- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
(rn_foreign_decls, src_fvs4)
<- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
(rn_default_decls, src_fvs5)
<- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-
+
+ -- Haddock docs
+ rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
+
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_derivds = rn_deriv_decls,
hs_fixds = rn_fix_decls,
hs_depds = [],
hs_fords = rn_foreign_decls,
hs_defds = rn_default_decls,
- hs_ruleds = rn_rule_decls } ;
+ hs_ruleds = rn_rule_decls,
+ hs_docs = rn_docs } ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3,
src_fvs4, src_fvs5] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs
-- Note: src_dus will contain *uses* for locally-defined types
%*********************************************************
%* *
+ HsDoc stuff
+%* *
+%*********************************************************
+
+\begin{code}
+rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl (DocCommentNext doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+ rn_doc <- rnHsDoc doc
+ return (DocGroup lev rn_doc)
+\end{code}
+
+
+%*********************************************************
+%* *
Source-code fixity declarations
%* *
%*********************************************************
-- 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.
\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@TyData {} = rnTyClDecl tydecl
+ rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
+ rnATInst tydecl =
+ pprPanic "RnSource.rnATInsts: invalid AT instance"
+ (ppr (tcdName tydecl))
\end{code}
For the method bindings in class and instance decls, we extend the
thing_inside
\end{code}
+%*********************************************************
+%* *
+\subsection{Stand-alone deriving declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
+rnSrcDerivDecl (DerivDecl ty)
+ = do ty' <- rnLHsType (text "a deriving decl") ty
+ let fvs = extractHsTyNames ty'
+ return (DerivDecl ty', fvs)
+\end{code}
%*********************************************************
%* *
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
+-- all flavours of type family declarations ("type family", "newtype fanily",
+-- and "data family")
+rnTyClDecl (tydecl@TyFamily {}) =
+ rnFamily tydecl bindTyVarsRn
+
+-- "data", "newtype", "data instance, and "newtype instance" declarations
+rnTyClDecl (tydecl@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
= 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 isFamInstDecl 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 isFamInstDecl 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 isFamInstDecl 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 isFamInstDecl 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)
+
+-- "type" and "type instance" declarations
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+ = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
+ do { name' <- if isFamInstDecl 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 isFamInstDecl tydecl
+ then unitFV (unLoc name') -- type instance => use
+ else emptyFVs))
+ }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds, tcdATs = ats})
- = lookupLocatedTopBndrRn cname `thenM` \ cname' ->
+ tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
+ = do { cname' <- lookupLocatedTopBndrRn cname
-- Tyvars scope over superclass context and method signatures
- bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
- rnContext cls_doc context `thenM` \ context' ->
- rnFds cls_doc fds `thenM` \ fds' ->
- 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') ->
+ ; (tyvars', context', fds', ats', ats_fvs, sigs')
+ <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ { context' <- rnContext cls_doc context
+ ; fds' <- rnFds cls_doc fds
+ ; (ats', ats_fvs) <- rnATs ats
+ ; sigs' <- renameSigs okClsDclSig sigs
+ ; return (tyvars', context', fds', ats', ats_fvs, sigs') }
-- Check for duplicates among the associated types
- let
- at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
- in
- checkDupNames at_doc at_rdr_names_w_locs `thenM_`
+ ; let at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
+ ; checkDupNames at_doc at_rdr_names_w_locs
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- let
- sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
- in
- checkDupNames sig_doc sig_rdr_names_w_locs `thenM_`
- -- Typechecker is responsible for checking that we only
- -- give default-method bindings for things in this class.
- -- The renamer *could* check this for class decls, but can't
- -- for instance decls.
+ ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
+ ; checkDupNames sig_doc sig_rdr_names_w_locs
+ -- Typechecker is responsible for checking that we only
+ -- give default-method bindings for things in this class.
+ -- The renamer *could* check this for class decls, but can't
+ -- for instance decls.
-- The newLocals call is tiresome: given a generic class decl
-- class C a where
-- op {| a*b |} (a*b) = ...
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
- extendTyVarEnvForMethodBinds tyvars' (
- getLocalRdrEnv `thenM` \ name_env ->
- let
- meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
- gen_rdr_tyvars_w_locs =
- [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
- in
- checkDupNames meth_doc meth_rdr_names_w_locs `thenM_`
- newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
- rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
- ) `thenM` \ (mbinds', meth_fvs) ->
-
- returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
- tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
- tcdMeths = mbinds', tcdATs = ats'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
- hsSigsFVs sigs' `plusFV`
- meth_fvs `plusFV`
- ats_fvs)
+ ; (mbinds', meth_fvs)
+ <- extendTyVarEnvForMethodBinds tyvars' $ do
+ { name_env <- getLocalRdrEnv
+ ; let meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
+ gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
+ not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ ; checkDupNames meth_doc meth_rdr_names_w_locs
+ ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
+ ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+
+ -- Haddock docs
+ ; docs' <- mapM (wrapLocM rnDocDecl) docs
+
+ ; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
+ tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+ tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
+
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
+ hsSigsFVs sigs' `plusFV`
+ meth_fvs `plusFV`
+ ats_fvs) }
where
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
= mappM (wrapLocM rnConDecl) condecls
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
-rnConDecl (ConDecl name expl tvs cxt details res_ty)
+rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc)
= do { addLocM checkConName name
; new_name <- lookupLocatedTopBndrRn name
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+
; bindTyVarsRn doc tvs' $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
- ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
- where
+ ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }}
+ where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
mappM (rnField doc) fields `thenM` \ new_fields ->
returnM (RecCon new_fields)
where
- field_names = [fld | (fld, _) <- fields]
+ field_names = [ name | HsRecField name _ _ <- fields ]
-rnField doc (name, ty)
+-- Document comments are renamed to Nothing here
+rnField doc (HsRecField name ty haddock_doc)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
rnLHsType doc ty `thenM` \ new_ty ->
- returnM (new_name, new_ty)
+ rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc ->
+ returnM (HsRecField new_name new_ty new_haddock_doc)
+
+-- Rename family declarations
+--
+-- * 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.
+--
+rnFamily :: TyClDecl RdrName
+ -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+ RnM (TyClDecl Name, FreeVars))
+ -> RnM (TyClDecl Name, FreeVars)
+
+rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
+ tcdLName = tycon, tcdTyVars = tyvars})
+ bindIdxVars =
+ do { checkM (isDataFlavour flavour -- for synonyms,
+ || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
+ tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
+ emptyFVs)
+ } }
+ where
+ isDataFlavour (DataFamily _) = True
+ isDataFlavour _ = False
+
+family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
+needOneIdx = text "Type family declarations requires at least one type index"
+
+-- Rename associated type declarations (in classes)
+--
+-- * This can be family declarations and (default) type instances
+--
+rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
+ where
+ rn_at (tydecl@TyFamily {}) = rnFamily 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
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)
---
--- * 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 data declarations, type function 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 _ = panic "RnSource.rnATs: invalid TyClDecl"
-
- lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
- --
- -- 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')
\end{code}