From 2d919a367139482cd76398ca1e90dff6f5427779 Mon Sep 17 00:00:00 2001
From: Alex Biehl <alexbiehl@gmail.com>
Date: Fri, 23 Jun 2017 18:30:45 +0200
Subject: Don't include names with empty subordinates in maps (#644)
These are unecessary anyway and just blow up interface size
---
haddock-api/src/Haddock/Interface/Create.hs | 10 +++-
html-test/ref/PR643.html | 80 +++++++++++++++++++++++++++++
html-test/src/PR643.hs | 3 ++
html-test/src/PR643_1.hs | 7 +++
4 files changed, 99 insertions(+), 1 deletion(-)
create mode 100644 html-test/ref/PR643.html
create mode 100644 html-test/src/PR643.hs
create mode 100644 html-test/src/PR643_1.hs
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 0984894d..50643e2a 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -317,7 +317,12 @@ mkMaps :: DynFlags
mkMaps dflags gre instances decls =
let
(a, b, c, d) = unzip4 $ map mappings decls
- in (f' $ map (nubByName fst) a , f b, f c, f d, instanceMap)
+ in ( f' (map (nubByName fst) a)
+ , f (filterMapping (not . M.null) b)
+ , f (filterMapping (not . null) c)
+ , f (filterMapping (not . null) d)
+ , instanceMap
+ )
where
f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
f = M.fromListWith (<>) . concat
@@ -325,6 +330,9 @@ mkMaps dflags gre instances decls =
f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)
f' = M.fromListWith metaDocAppend . concat
+ filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]]
+ filterMapping p = map (filter (p . snd))
+
mappings :: (LHsDecl Name, [HsDocString])
-> ( [(Name, MDoc Name)]
, [(Name, Map Int (MDoc Name))]
diff --git a/html-test/ref/PR643.html b/html-test/ref/PR643.html
new file mode 100644
index 00000000..46e1e7ed
--- /dev/null
+++ b/html-test/ref/PR643.html
@@ -0,0 +1,80 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><title
+ >PR643</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Ocean"
+ /><script src="haddock-util.js" type="text/javascript"
+ ></script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript"
+ ></script
+ ><script type="text/javascript"
+ >//
+window.onload = function () {pageLoad();};
+//
+</script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ><p class="caption empty"
+ ></p
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >Safe</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >PR643</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"
+ ><a href="#"
+ >test</a
+ > :: ()</li
+ ></ul
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><a id="v:test" class="def"
+ >test</a
+ > :: () <span class="fixity"
+ >infixr 5</span
+ ><span class="rightedge"
+ ></span
+ > <a href="#" class="selflink"
+ >#</a
+ ></p
+ ><div class="doc"
+ ><p
+ >Some big documentation</p
+ ></div
+ ></div
+ ></div
+ ></div
+ ><div id="footer"
+ ></div
+ ></body
+ ></html
+>
\ No newline at end of file
diff --git a/html-test/src/PR643.hs b/html-test/src/PR643.hs
new file mode 100644
index 00000000..565e5b57
--- /dev/null
+++ b/html-test/src/PR643.hs
@@ -0,0 +1,3 @@
+module PR643 (test) where
+
+import PR643_1
diff --git a/html-test/src/PR643_1.hs b/html-test/src/PR643_1.hs
new file mode 100644
index 00000000..ecd0db94
--- /dev/null
+++ b/html-test/src/PR643_1.hs
@@ -0,0 +1,7 @@
+module PR643_1 where
+
+infixr 5 `test`
+
+-- | Some big documentation
+test :: ()
+test = ()
--
cgit v1.2.3