ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), ResType(..), LConDecl,
- DocDecl(..), LDocDecl, docDeclDoc, DocEntity(..),
+ DocDecl(..), LDocDecl, docDeclDoc,
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
hs_depds :: [LDeprecDecl id],
hs_ruleds :: [LRuleDecl id],
- hs_docs :: [DocEntity id]
- -- Used to remember the module structure,
- -- which is needed to produce Haddock documentation
+ hs_docs :: [LDocDecl id]
}
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
-- only 'TyData',
-- 'TyFunction',
-- and 'TySynonym'
- tcdDocs :: [DocEntity name] -- Haddock docs
+ tcdDocs :: [LDocDecl name] -- Haddock docs
}
data NewOrData
\begin{code}
--- source code entities, for representing the module structure
-data DocEntity name
- = DeclEntity name
- | DocEntity (DocDecl name)
-
type LDocDecl name = Located (DocDecl name)
data DocDecl name
ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [DocEntity RdrName])
+ -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName], [LDocDecl RdrName])
-- Input decls contain just value bindings and signatures
-- and in case of class or instance declarations also
-- associated type declarations. They might also contain Haddock comments.
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = (emptyBag, [], [], [])
- go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, add_doc x docs)
+ go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
where (bs, ss, ts, docs) = go ds
- go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, add_doc x docs)
+ go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
where (b', ds') = getMonoBind (L l b) ds
(bs, ss, ts, docs) = go ds'
go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
where (bs, ss, ts, docs) = go ds
- go (L _ (DocD d) : ds) = (bs, ss, ts, DocEntity d : docs)
+ go (L l (DocD d) : ds) = (bs, ss, ts, (L l d) : docs)
where (bs, ss, ts, docs) = go ds
-----------------------------------------------------------------------------
add gp l (SpliceD e) ds = (gp, Just (e, ds))
-- Class declarations: pull out the fixity signatures to the top
-add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
- l decl@(TyClD d) ds
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
+ l (TyClD d) ds
| isClassDecl d =
let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
- addl (gp { hs_tyclds = L l d : ts,
- hs_fixds = fsigs ++ fs,
- hs_docs = add_doc decl docs}) ds
+ addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
| isFamInstDecl d =
addl (gp { hs_tyclds = L l d : ts }) ds
| otherwise =
- addl (gp { hs_tyclds = L l d : ts,
- hs_docs = add_doc decl docs }) ds
+ addl (gp { hs_tyclds = L l d : ts }) ds
-- Signatures: fixity sigs go a different place than all others
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
= addl (gp {hs_fixds = L l f : ts}) ds
-add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(SigD d) ds
- = addl (gp {hs_valds = add_sig (L l d) ts, hs_docs = add_doc x docs}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+ = addl (gp {hs_valds = add_sig (L l d) ts}) ds
-- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds = ts, hs_docs = docs}) l x@(ValD d) ds
- = addl (gp { hs_valds = add_bind (L l d) ts, hs_docs = add_doc x docs }) ds
+add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
+ = addl (gp { hs_valds = add_bind (L l d) ts }) ds
-- The rest are routine
add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
= addl (gp { hs_derivds = L l d : ts }) ds
add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
= addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords = ts, hs_docs = docs}) l x@(ForD d) ds
- = addl (gp { hs_fords = L l d : ts, hs_docs = add_doc x docs }) ds
+add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
+ = addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds
= addl (gp { hs_depds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
add gp l (DocD d) ds
- = addl (gp { hs_docs = DocEntity d : (hs_docs gp) }) ds
+ = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
-add_doc decl docs = case getMainDeclBinder decl of
- Just name -> DeclEntity name : docs
- Nothing -> docs
-
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
\end{code}
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
- hs_docs = docs })
+ hs_docs = docs })
= do { -- Deal with deprecations (returns only the extra deprecations)
deprecs <- rnSrcDeprecDecls deprec_decls ;
(rn_default_decls, src_fvs5)
<- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
- rn_docs <- rnDocEntities docs ;
+ -- Haddock docs
+ rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
let {
rn_group = HsGroup { hs_valds = rn_val_decls,
hs_fords = rn_foreign_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
- hs_docs = rn_docs } ;
+ hs_docs = rn_docs } ;
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3,
src_fvs4, src_fvs5] ;
%*********************************************************
\begin{code}
-rnDocEntities :: [DocEntity RdrName] -> RnM [DocEntity Name]
-rnDocEntities ents
- = ifErrsM (return []) $
- -- Yuk: stop if we have found errors. Otherwise
- -- the rnDocEntity stuff reports the errors again.
- mapM rnDocEntity ents
-
-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
; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
- -- Sigh. Check the Haddock docs after the methods, to avoid duplicate errors
- -- Example: class { op :: a->a; op2 x = x }
- -- Don't want a duplicate complait about op2
- ; docs' <- bindLocalNames (map hsLTyVarName tyvars') $ rnDocEntities docs
+ -- Haddock docs
+ ; docs' <- mapM (wrapLocM rnDocDecl) docs
; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
projects / ghc-hetmet.git / commitdiff