diff options
author | David Waern <david.waern@gmail.com> | 2012-01-25 00:44:15 +0100 |
---|---|---|
committer | David Waern <david.waern@gmail.com> | 2012-02-01 02:30:05 +0100 |
commit | a566544cfd3b5ab5379f89d0b8886501c96da7fa (patch) | |
tree | 1842c91b0604b6e5f06f2ccca1d1fa961b6dd5d7 | |
parent | 949849c3fde2ea2838b143717f250c4cce9e026e (diff) |
Fix bug introduced in my recent refactoring.
-rw-r--r-- | src/Haddock/Interface/Create.hs | 34 | ||||
-rw-r--r-- | tests/html-tests/tests/A.hs | 9 | ||||
-rw-r--r-- | tests/html-tests/tests/A.html.ref | 88 | ||||
-rw-r--r-- | tests/html-tests/tests/B.hs | 4 | ||||
-rw-r--r-- | tests/html-tests/tests/B.html.ref | 57 |
5 files changed, 174 insertions, 18 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 580aaa83..0a0c0e2d 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -433,13 +433,12 @@ mkExportItems declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = - let (doc, subs) = exportDecl t docMap argMap subMap in case findDecl t of - [L _ (ValD _)] -> do + ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem t doc return [export] - ds | decl : _ <- filter (not . isValD . unLoc) ds -> + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) in case () of _ @@ -461,7 +460,7 @@ mkExportItems return [] -- normal case - | otherwise -> return [ mkExportDecl t newDecl (doc, subs) ] + | otherwise -> return [ mkExportDecl t newDecl docs_ ] where -- Since a single signature might refer to many names, we -- need to filter the ones that are actually exported. This @@ -475,7 +474,7 @@ mkExportItems _ -> decl -- Declaration from another package - [] -> do + ([], _) -> do mayDecl <- hiDecl t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] @@ -489,7 +488,7 @@ mkExportItems let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> do - return [ mkExportDecl t decl (exportDecl t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -506,13 +505,15 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> [LHsDecl Name] - findDecl name - | mdl == thisMod = maybe [] id (M.lookup name declMap) - | Just iface <- M.lookup mdl modMap = maybe [] id (M.lookup name (ifaceDeclMap iface)) - | otherwise = [] + findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl n + | m == thisMod, Just ds <- M.lookup n declMap = + (ds, lookupDocs n docMap argMap subMap) + | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + | otherwise = ([], (noDocForDecl, [])) where - mdl = nameModule name + m = nameModule n hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) @@ -533,8 +534,9 @@ hiValExportItem name doc = do Just decl -> return (ExportDecl decl doc [] []) -exportDecl :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -exportDecl name docMap argMap subMap = +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs name docMap argMap subMap = let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in let doc = (M.lookup name docMap, lookupArgMap name) in let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in @@ -616,12 +618,12 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = exportDecl name docMap argMap subMap in + let (doc, _) = lookupDocs name docMap argMap subMap in fmap Just (hiValExportItem name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = exportDecl name docMap argMap subMap in + let (doc, subs) = lookupDocs name docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing diff --git a/tests/html-tests/tests/A.hs b/tests/html-tests/tests/A.hs index ac8fad49..606b0865 100644 --- a/tests/html-tests/tests/A.hs +++ b/tests/html-tests/tests/A.hs @@ -1,8 +1,17 @@ module A where + data A = A other :: Int other = 2 +-- | Doc for test2 test2 :: Bool test2 = False + +-- | Should show up on the page for both modules A and B +data X = X -- ^ Doc for consructor + +-- | Should show up on the page for both modules A and B +reExport :: Int +reExport = 1 diff --git a/tests/html-tests/tests/A.html.ref b/tests/html-tests/tests/A.html.ref index 38a39479..143f8a73 100644 --- a/tests/html-tests/tests/A.html.ref +++ b/tests/html-tests/tests/A.html.ref @@ -41,6 +41,46 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; ><p class="caption" >A</p ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="" + >A</a + > = <a href="" + >A</a + ></li + ><li class="src short" + ><a href="" + >other</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >test2</a + > :: <a href="" + >Bool</a + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="" + >X</a + > = <a href="" + >X</a + ></li + ><li class="src short" + ><a href="" + >reExport</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div ><div id="interface" ><h1 >Documentation</h1 @@ -81,6 +121,54 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; > :: <a href="" >Bool</a ></p + ><div class="doc" + ><p + >Doc for test2 +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:X" class="def" + >X</a + > </p + ><div class="doc" + ><p + >Should show up on the page for both modules A and B +</p + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:X" class="def" + >X</a + ></td + ><td class="doc" + ><p + >Doc for consructor +</p + ></td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:reExport" class="def" + >reExport</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><p + >Should show up on the page for both modules A and B +</p + ></div ></div ></div ></div diff --git a/tests/html-tests/tests/B.hs b/tests/html-tests/tests/B.hs index 28cda4a0..5fd69acd 100644 --- a/tests/html-tests/tests/B.hs +++ b/tests/html-tests/tests/B.hs @@ -1,5 +1,5 @@ -module B ( module A, test ) where -import A ( A(..), test2 ) +module B ( module A, test, reExport, X(..) ) where +import A ( A(..), test2, reExport, X(..) ) -- | This link shouldn't work: 'other'. -- These links should work: 'A.other', 'Data.List.sortBy', 'test2', 'A.test2', 'Data.Maybe.fromMaybe'. diff --git a/tests/html-tests/tests/B.html.ref b/tests/html-tests/tests/B.html.ref index 039d860f..374e34e3 100644 --- a/tests/html-tests/tests/B.html.ref +++ b/tests/html-tests/tests/B.html.ref @@ -55,6 +55,20 @@ window.onload = function () {pageLoad();setSynopsis("mini_B.html");}; > :: <a href="" >Int</a ></li + ><li class="src short" + ><a href="" + >reExport</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="" + >X</a + > = <a href="" + >X</a + ></li ></ul ></div ><div id="interface" @@ -105,6 +119,49 @@ window.onload = function () {pageLoad();setSynopsis("mini_B.html");}; </p ></div ></div + ><div class="top" + ><p class="src" + ><a name="v:reExport" class="def" + >reExport</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><p + >Should show up on the page for both modules A and B +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:X" class="def" + >X</a + > </p + ><div class="doc" + ><p + >Should show up on the page for both modules A and B +</p + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:X" class="def" + >X</a + ></td + ><td class="doc" + ><p + >Doc for consructor +</p + ></td + ></tr + ></table + ></div + ></div ></div ></div ><div id="footer" |