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(..),
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 ;
<- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
(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 ;
-
+
+ rn_docs <- mapM rnDocEntity docs ;
+
let {
rn_group = HsGroup { hs_valds = rn_val_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
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
+rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name)
+rnDocEntity (DocEntity docdecl) = do
+ rn_docdecl <- rnDocDecl docdecl
+ return (DocEntity rn_docdecl)
+rnDocEntity (DeclEntity name) = do
+ rn_name <- lookupTopBndrRn name
+ return (DeclEntity rn_name)
+
+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)
+
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
rnTyClDecls tycl_decls = do
(decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
-- 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
in
checkDupNames at_doc at_names `thenM_`
thing_inside
\end{code}
+%*********************************************************
+%* *
+\subsection{Stand-alone deriving declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
+rnSrcDerivDecl (DerivDecl ty n)
+ = do ty' <- rnLHsType (text "a deriving decl") ty
+ n' <- lookupLocatedOccRn n
+ let fvs = extractHsTyNames ty' `addOneFV` unLoc n'
+ return (DerivDecl ty' n', fvs)
+\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)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds, tcdATs = ats})
+ tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
= lookupLocatedTopBndrRn cname `thenM` \ cname' ->
-- Tyvars scope over superclass context and method signatures
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') ->
+ mapM rnDocEntity docs `thenM` \ docs' ->
+ returnM (tyvars', context', fds', (ats', ats_fvs), sigs', docs')
+ ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs', docs') ->
-- Check for duplicates among the associated types
let
returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
- tcdMeths = mbinds', tcdATs = ats'},
+ tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
= 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 kind signatures (signatures of indexed data types/newtypes and
-- signatures of type functions)
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"
projects / ghc-hetmet.git / blobdiff