Remove the DocEntity type. Fixes the problem with duplicate error messages at
authordavve@dtek.chalmers.se <unknown>
Fri, 5 Jan 2007 17:43:46 +0000 (17:43 +0000)
committerdavve@dtek.chalmers.se <unknown>
Fri, 5 Jan 2007 17:43:46 +0000 (17:43 +0000)
its root. Also gets rid of the getDeclMainBinder function which isn't needed
anylonger.

compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsUtils.lhs
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnSource.lhs

index 2b97668..1822b58 100644 (file)
@@ -18,7 +18,7 @@ module HsDecls (
        ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
        CImportSpec(..), FoType(..),
        ConDecl(..), ResType(..), LConDecl,     
        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,
        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_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
   }
 
 emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
@@ -431,7 +429,7 @@ data TyClDecl name
                                                        --   only 'TyData',
                                                        --   'TyFunction',
                                                        --   and 'TySynonym'
                                                        --   only 'TyData',
                                                        --   'TyFunction',
                                                        --   and 'TySynonym'
-               tcdDocs    :: [DocEntity name]          -- Haddock docs
+               tcdDocs    :: [LDocDecl name]           -- Haddock docs
     }
 
 data NewOrData
     }
 
 data NewOrData
@@ -935,11 +933,6 @@ instance OutputableBndr name => Outputable (RuleBndr name) where
 
 \begin{code}
 
 
 \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
 type LDocDecl name = Located (DocDecl name)
 
 data DocDecl name
index 51925f8..d2c5d0e 100644 (file)
@@ -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}
 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}
index 687ffd2..0cfa292 100644 (file)
@@ -215,21 +215,21 @@ cvBindGroup binding
         ValBindsIn mbs sigs
 
 cvBindsAndSigs :: OrdList (LHsDecl RdrName)
         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, [], [], [])
 -- 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
                            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
                            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
 
 -----------------------------------------------------------------------------
                            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 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
        | 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 =
        | 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
 
 -- 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
 
 -- 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
 
 -- 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
   = 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
 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}
 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 add_sig  s (ValBindsIn bs sigs) = ValBindsIn bs                      (s:sigs) 
 \end{code}
index a9d6c5d..75af8fd 100644 (file)
@@ -75,7 +75,7 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
                      hs_fords  = foreign_decls,
                      hs_defds  = default_decls,
                      hs_ruleds = rule_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 ;
 
  = 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_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,
 
        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_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] ;
 
           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}
 %*********************************************************
 
 \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
 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 }
 
            ; 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',
 
        ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
                              tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',