From 5d0b2bba1dfc0b2786162927ed7b3d4911f1cc54 Mon Sep 17 00:00:00 2001 From: "davve@dtek.chalmers.se" Date: Fri, 5 Jan 2007 17:43:46 +0000 Subject: [PATCH] Remove the DocEntity type. Fixes the problem with duplicate error messages at its root. Also gets rid of the getDeclMainBinder function which isn't needed anylonger. --- compiler/hsSyn/HsDecls.lhs | 13 +++---------- compiler/hsSyn/HsUtils.lhs | 20 -------------------- compiler/parser/RdrHsSyn.lhs | 37 +++++++++++++++---------------------- compiler/rename/RnSource.lhs | 28 ++++++---------------------- 4 files changed, 24 insertions(+), 74 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 2b97668..1822b58 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,7 +18,7 @@ module HsDecls ( 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, @@ -111,9 +111,7 @@ data HsGroup id 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 @@ -431,7 +429,7 @@ data TyClDecl name -- only 'TyData', -- 'TyFunction', -- and 'TySynonym' - tcdDocs :: [DocEntity name] -- Haddock docs + tcdDocs :: [LDocDecl name] -- Haddock docs } data NewOrData @@ -935,11 +933,6 @@ instance OutputableBndr name => Outputable (RuleBndr name) where \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 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 51925f8..d2c5d0e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -428,23 +428,3 @@ collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) collect_pat other acc = acc -- Literals, vars, wildcard \end{code} - -%************************************************************************ -%* * -%* Getting the main binder name of a top declaration -%* * -%************************************************************************ - -\begin{code} - -getMainDeclBinder :: HsDecl name -> Maybe name -getMainDeclBinder (TyClD d) = Just (tcdName d) -getMainDeclBinder (ValD d) - = case collectAcc d [] of - [] -> Nothing -- see rn003 - (name:_) -> Just (unLoc name) -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) -getMainDeclBinder (ForD (ForeignExport name _ _)) = Nothing -getMainDeclBinder _ = Nothing -\end{code} diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 687ffd2..0cfa292 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -215,21 +215,21 @@ cvBindGroup binding 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 ----------------------------------------------------------------------------- @@ -304,28 +304,25 @@ add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] 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 @@ -334,20 +331,16 @@ add gp@(HsGroup {hs_derivds = ts}) l (DerivD 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} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a9d6c5d..75af8fd 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -75,7 +75,7 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, 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 ; @@ -116,7 +116,8 @@ rnSrcDecls (HsGroup { hs_valds = val_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, @@ -128,7 +129,7 @@ rnSrcDecls (HsGroup { hs_valds = 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] ; @@ -162,21 +163,6 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } %********************************************************* \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 @@ -690,10 +676,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; 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', -- 1.7.10.4