From fbbe544c91020da143160bb8c68ee890d214a69e Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 13 Mar 2017 03:13:10 -0700 Subject: Render signature module tree separately from modules. Signed-off-by: Edward Z. Yang (cherry picked from commit 2067a2d0afa9cef381d26fb7140b67c62f433fc0) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 65b427f9..34911b11 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -263,13 +263,20 @@ ppHtmlContents dflags odir doctitle _maybe_package themes mathjax_url maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do let tree = mkModuleTree dflags showPkgs - [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + [(instMod iface, toInstalledDescription iface) + | iface <- ifaces + , not (instIsSig iface)] + sig_tree = mkModuleTree dflags showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- ifaces + , instIsSig iface] html = headHtml doctitle Nothing themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ ppPrologue qual doctitle prologue, + ppSignatureTree qual sig_tree, ppModuleTree qual tree ] createDirectoryIfMissing True odir @@ -282,7 +289,13 @@ ppPrologue qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppSignatureTree :: Qualification -> [ModuleTree] -> Html +ppSignatureTree qual ts = + divModuleList << (sectionName << "Signatures" +++ mkNodeList qual [] "n" ts) + + ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree _ [] = mempty ppModuleTree qual ts = divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) -- cgit v1.2.3 From ef93eaac9bc0ca40073763d2e18ced3a51679ead Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 22 Mar 2017 13:48:12 -0700 Subject: Annotate signature docs with (signature) Signed-off-by: Edward Z. Yang (cherry picked from commit 07b88c5d4e79b87a319fbb08f8ea01dbb41063c1) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 34911b11..fc26afbb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -482,13 +482,16 @@ ppHtmlModule odir doctitle themes mdl = ifaceMod iface aliases = ifaceModuleAliases iface mdl_str = moduleString mdl + mdl_str_annot = mdl_str ++ if ifaceIsSig iface + then " (signature)" + else "" real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ + headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] -- cgit v1.2.3 From 0567d936e02dcbc41c62b4dd63c7aaafc3383844 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 22 Mar 2017 14:11:25 -0700 Subject: Render help documentation link next to (signature) in title. Signed-off-by: Edward Z. Yang (cherry picked from commit 4eb765ca4205c79539d60b7afa9b7e261a4a49fe) --- haddock-api/resources/html/Ocean.std-theme/ocean.css | 5 +++++ haddock-api/src/Haddock/Backends/Xhtml.hs | 9 ++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index e8e4d705..29af691b 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -88,6 +88,11 @@ pre, code, kbd, samp, tt, .src { font-size: 182%; /* 24pt */ } +#module-header .caption sup { + font-size: 70%; + font-weight: normal; +} + .info { font-size: 85%; /* 11pt */ } diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index fc26afbb..4cb028b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -485,13 +485,17 @@ ppHtmlModule odir doctitle themes mdl_str_annot = mdl_str ++ if ifaceIsSig iface then " (signature)" else "" + mdl_str_linked = mdl_str +++ + " (signature" +++ + sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++ + ")" real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_annot)), + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual ] @@ -499,6 +503,9 @@ ppHtmlModule odir doctitle themes writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug +signatureDocURL :: String +signatureDocURL = "https://wiki.haskell.org/Module_signature" + ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO () ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do -- cgit v1.2.3 From 18ed871afb82560d5433b2f53e31b4db9353a74e Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sat, 1 Apr 2017 05:05:06 -0400 Subject: Update MathJax URL MathJax is shutting down their CDN: https://www.mathjax.org/cdn-shutting-down/ They recommend migrating to cdnjs. --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 4cb028b8..c5caa6a2 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -126,7 +126,7 @@ headHtml docTitle miniPage themes mathjax_url = ] where setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage - mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url + mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url srcButton :: SourceURLs -> Maybe Interface -> Maybe Html -- cgit v1.2.3 From ce3647ea278606f43615817ecb2865d96ca8b39e Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Sat, 22 Apr 2017 20:38:26 -0700 Subject: Render (signature) only if it actually is a signature! I forgot a conditional, oops! Signed-off-by: Edward Z. Yang (cherry picked from commit a0c4790e15a2d3fab8d830eee8fcd639fe6d39c9) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c5caa6a2..31a748cb 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -485,10 +485,13 @@ ppHtmlModule odir doctitle themes mdl_str_annot = mdl_str ++ if ifaceIsSig iface then " (signature)" else "" - mdl_str_linked = mdl_str +++ - " (signature" +++ + mdl_str_linked + | ifaceIsSig iface + = mdl_str +++ " (signature" +++ sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++ ")" + | otherwise + = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ -- cgit v1.2.3 From 4346ad26ac1346aa5e59991315f6969c844bea60 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Wed, 26 Apr 2017 07:07:04 +0200 Subject: Remove anything related to obsolete frames mode --- .../resources/html/Ocean.std-theme/ocean.css | 4 - haddock-api/resources/html/haddock-util.js | 132 +-------------------- haddock-api/src/Haddock/Backends/Xhtml.hs | 70 ++--------- html-test/ref/A.html | 4 +- html-test/ref/B.html | 4 +- html-test/ref/Bold.html | 4 +- html-test/ref/Bug1.html | 4 +- html-test/ref/Bug195.html | 4 +- html-test/ref/Bug2.html | 4 +- html-test/ref/Bug201.html | 4 +- html-test/ref/Bug253.html | 4 +- html-test/ref/Bug26.html | 4 +- html-test/ref/Bug280.html | 21 ++-- html-test/ref/Bug294.html | 4 +- html-test/ref/Bug298.html | 4 +- html-test/ref/Bug3.html | 4 +- html-test/ref/Bug308.html | 4 +- html-test/ref/Bug308CrossModule.html | 4 +- html-test/ref/Bug310.html | 4 +- html-test/ref/Bug313.html | 4 +- html-test/ref/Bug335.html | 4 +- html-test/ref/Bug387.html | 4 +- html-test/ref/Bug4.html | 4 +- html-test/ref/Bug6.html | 4 +- html-test/ref/Bug7.html | 4 +- html-test/ref/Bug8.html | 2 +- html-test/ref/Bug85.html | 4 +- html-test/ref/BugDeprecated.html | 4 +- html-test/ref/BugExportHeadings.html | 4 +- html-test/ref/Bugs.html | 4 +- html-test/ref/DeprecatedClass.html | 4 +- html-test/ref/DeprecatedData.html | 4 +- html-test/ref/DeprecatedFunction.html | 4 +- html-test/ref/DeprecatedFunction2.html | 4 +- html-test/ref/DeprecatedFunction3.html | 4 +- html-test/ref/DeprecatedModule.html | 4 +- html-test/ref/DeprecatedModule2.html | 4 +- html-test/ref/DeprecatedNewtype.html | 4 +- html-test/ref/DeprecatedReExport.html | 4 +- html-test/ref/DeprecatedRecord.html | 4 +- html-test/ref/DeprecatedTypeFamily.html | 4 +- html-test/ref/DeprecatedTypeSynonym.html | 4 +- html-test/ref/Examples.html | 4 +- html-test/ref/Extensions.html | 4 +- html-test/ref/FunArgs.html | 4 +- html-test/ref/GADTRecords.html | 4 +- html-test/ref/Hash.html | 4 +- html-test/ref/HiddenInstances.html | 4 +- html-test/ref/HiddenInstancesB.html | 4 +- html-test/ref/Hyperlinks.html | 4 +- html-test/ref/IgnoreExports.html | 4 +- html-test/ref/ImplicitParams.html | 4 +- html-test/ref/Instances.html | 2 +- html-test/ref/Math.html | 4 +- html-test/ref/Minimal.html | 2 +- html-test/ref/ModuleWithWarning.html | 4 +- html-test/ref/NamedDoc.html | 4 +- html-test/ref/Nesting.html | 4 +- html-test/ref/NoLayout.html | 4 +- html-test/ref/NonGreedy.html | 4 +- html-test/ref/Operators.html | 2 +- html-test/ref/OrphanInstances.html | 4 +- html-test/ref/OrphanInstancesClass.html | 4 +- html-test/ref/OrphanInstancesType.html | 4 +- html-test/ref/PatternSyns.html | 2 +- html-test/ref/PromotedTypes.html | 4 +- html-test/ref/Properties.html | 4 +- html-test/ref/PruneWithWarning.html | 4 +- html-test/ref/QuasiExpr.html | 4 +- html-test/ref/QuasiQuote.html | 4 +- html-test/ref/SpuriousSuperclassConstraints.html | 2 +- html-test/ref/TH.html | 4 +- html-test/ref/TH2.html | 2 +- html-test/ref/Test.html | 4 +- html-test/ref/Threaded.html | 4 +- html-test/ref/Threaded_TH.html | 2 +- html-test/ref/Ticket112.html | 4 +- html-test/ref/Ticket61.html | 4 +- html-test/ref/Ticket75.html | 4 +- html-test/ref/TitledPicture.html | 4 +- html-test/ref/TypeFamilies.html | 4 +- html-test/ref/TypeFamilies2.html | 4 +- html-test/ref/TypeOperators.html | 4 +- html-test/ref/Unicode.html | 4 +- html-test/ref/Visible.html | 4 +- html-test/ref/haddock-util.js | 132 +-------------------- 86 files changed, 174 insertions(+), 493 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/haddock-api/resources/html/Ocean.std-theme/ocean.css b/haddock-api/resources/html/Ocean.std-theme/ocean.css index 9d2c644f..3bfc8982 100644 --- a/haddock-api/resources/html/Ocean.std-theme/ocean.css +++ b/haddock-api/resources/html/Ocean.std-theme/ocean.css @@ -327,10 +327,6 @@ div#style-menu-holder { } #synopsis { - display: none; -} - -.no-frame #synopsis { display: block; position: fixed; right: 0; diff --git a/haddock-api/resources/html/haddock-util.js b/haddock-api/resources/html/haddock-util.js index 92d07d2a..05bdaef5 100644 --- a/haddock-api/resources/html/haddock-util.js +++ b/haddock-api/resources/html/haddock-util.js @@ -1,7 +1,7 @@ // Haddock JavaScript utilities var rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; + rtrim = /^\s+|\s+$/g; function spaced(s) { return (" " + s + " ").replace(rspace, " "); } function trim(s) { return s.replace(rtrim, ""); } @@ -109,136 +109,6 @@ function getCookie(name) { return null; } - - -var max_results = 75; // 50 is not enough to search for map in the base libraries -var shown_range = null; -var last_search = null; - -function quick_search() -{ - perform_search(false); -} - -function full_search() -{ - perform_search(true); -} - - -function perform_search(full) -{ - var text = document.getElementById("searchbox").value.toLowerCase(); - if (text == last_search && !full) return; - last_search = text; - - var table = document.getElementById("indexlist"); - var status = document.getElementById("searchmsg"); - var children = table.firstChild.childNodes; - - // first figure out the first node with the prefix - var first = bisect(-1); - var last = (first == -1 ? -1 : bisect(1)); - - if (first == -1) - { - table.className = ""; - status.innerHTML = "No results found, displaying all"; - } - else if (first == 0 && last == children.length - 1) - { - table.className = ""; - status.innerHTML = ""; - } - else if (last - first >= max_results && !full) - { - table.className = ""; - status.innerHTML = "More than " + max_results + ", press Search to display"; - } - else - { - // decide what you need to clear/show - if (shown_range) - setclass(shown_range[0], shown_range[1], "indexrow"); - setclass(first, last, "indexshow"); - shown_range = [first, last]; - table.className = "indexsearch"; - status.innerHTML = ""; - } - - - function setclass(first, last, status) - { - for (var i = first; i <= last; i++) - { - children[i].className = status; - } - } - - - // do a binary search, treating 0 as ... - // return either -1 (no 0's found) or location of most far match - function bisect(dir) - { - var first = 0, finish = children.length - 1; - var mid, success = false; - - while (finish - first > 3) - { - mid = Math.floor((finish + first) / 2); - - var i = checkitem(mid); - if (i == 0) i = dir; - if (i == -1) - finish = mid; - else - first = mid; - } - var a = (dir == 1 ? first : finish); - var b = (dir == 1 ? finish : first); - for (var i = b; i != a - dir; i -= dir) - { - if (checkitem(i) == 0) return i; - } - return -1; - } - - - // from an index, decide what the result is - // 0 = match, -1 is lower, 1 is higher - function checkitem(i) - { - var s = getitem(i).toLowerCase().substr(0, text.length); - if (s == text) return 0; - else return (s > text ? -1 : 1); - } - - - // from an index, get its string - // this abstracts over alternates - function getitem(i) - { - for ( ; i >= 0; i--) - { - var s = children[i].firstChild.firstChild.data; - if (s.indexOf(' ') == -1) - return s; - } - return ""; // should never be reached - } -} - -function setSynopsis(filename) { - if (parent.window.synopsis && parent.window.synopsis.location) { - if (parent.window.synopsis.location.replace) { - // In Firefox this avoids adding the change to the history. - parent.window.synopsis.location.replace(filename); - } else { - parent.window.synopsis.location = filename; - } - } -} - function addMenuItem(html) { var menu = document.getElementById("page-menu"); if (menu) { diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 31a748cb..34ecc5b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -108,8 +108,8 @@ copyHtmlBits odir libdir themes = do return () -headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html -headHtml docTitle miniPage themes mathjax_url = +headHtml :: String -> Themes -> Maybe String -> Html +headHtml docTitle themes mathjax_url = header << [ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, @@ -118,14 +118,11 @@ headHtml docTitle miniPage themes mathjax_url = script ! [src mjUrl, thetype "text/javascript"] << noHtml, script ! [thetype "text/javascript"] -- NB: Within XHTML, the content of script tags needs to be - -- a " in it! - << primHtml ( - "//\n") + -- a \n" ] where - setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url @@ -271,7 +268,7 @@ ppHtmlContents dflags odir doctitle _maybe_package | iface <- ifaces , instIsSig iface] html = - headHtml doctitle Nothing themes mathjax_url +++ + headHtml doctitle themes mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url Nothing maybe_index_url << [ @@ -372,7 +369,7 @@ ppHtmlIndex odir doctitle _maybe_package themes where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++ + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url maybe_contents_url Nothing << [ @@ -494,7 +491,7 @@ ppHtmlModule odir doctitle themes = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html = - headHtml mdl_str_annot (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ + headHtml mdl_str_annot themes maybe_mathjax_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url << [ @@ -504,24 +501,10 @@ ppHtmlModule odir doctitle themes createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes - -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO () -ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do - let mdl = ifaceMod iface - html = - headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++ - miniBody << - (divModuleHeader << sectionName << moduleString mdl +++ - miniSynopsis mdl iface unicode qual) - createDirectoryIfMissing True odir - writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) - - ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ @@ -572,43 +555,6 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual linksInfo = (maybe_source_url, maybe_wiki_url) -miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html -miniSynopsis mdl iface unicode qual = - divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports - where - exports = numberSectionHeadings (ifaceRnExportItems iface) - - -processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName - -> [Html] -processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = - ((divTopDecl <<).(declElem <<)) <$> case decl0 of - TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of - (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] - (DataDecl{}) -> [keyword "data" <+> b] - (SynDecl{}) -> [keyword "type" <+> b] - (ClassDecl {}) -> [keyword "class" <+> b] - SigD (TypeSig lnames _) -> - map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames - _ -> [] -processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = - [groupTag lvl << docToHtml Nothing qual (mkMeta txt)] -processForMiniSynopsis _ _ _ _ = [] - - -ppNameMini :: Notation -> Module -> OccName -> Html -ppNameMini notation mdl nm = - anchor ! [ href (moduleNameUrl mdl nm) - , target mainFrameName ] - << ppBinder' notation nm - - -ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html -ppTyClBinderWithVarsMini mdl decl = - let n = tcdName decl - ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above - in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName - ppModuleContents :: Qualification -> [ExportItem DocName] -> Bool -- ^ Orphans sections diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 64a2916b..edd95fe8 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/B.html b/html-test/ref/B.html index b1e43a51..f4ce89d4 100644 --- a/html-test/ref/B.html +++ b/html-test/ref/B.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bold.html b/html-test/ref/Bold.html index d8f8b3d4..a7cb4e7f 100644 --- a/html-test/ref/Bold.html +++ b/html-test/ref/Bold.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug1.html b/html-test/ref/Bug1.html index 5ea4ff26..37a37527 100644 --- a/html-test/ref/Bug1.html +++ b/html-test/ref/Bug1.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug195.html b/html-test/ref/Bug195.html index b7f10741..ca5c2cc0 100644 --- a/html-test/ref/Bug195.html +++ b/html-test/ref/Bug195.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug2.html b/html-test/ref/Bug2.html index 98d7f06d..5b88feae 100644 --- a/html-test/ref/Bug2.html +++ b/html-test/ref/Bug2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug201.html b/html-test/ref/Bug201.html index 19cb1aae..04cb0991 100644 --- a/html-test/ref/Bug201.html +++ b/html-test/ref/Bug201.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html index 2210b023..28482b24 100644 --- a/html-test/ref/Bug253.html +++ b/html-test/ref/Bug253.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug26.html b/html-test/ref/Bug26.html index 9382a738..8b0644aa 100644 --- a/html-test/ref/Bug26.html +++ b/html-test/ref/Bug26.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug280.html b/html-test/ref/Bug280.html index fa8ca0de..6c533a28 100644 --- a/html-test/ref/Bug280.html +++ b/html-test/ref/Bug280.html @@ -1,4 +1,3 @@ -

 

CopyrightFoo
Bar
BazBar
Baz

Description

The module description

The module description

+> \ No newline at end of file diff --git a/html-test/ref/Bug294.html b/html-test/ref/Bug294.html index 44aad9d1..3a82af80 100644 --- a/html-test/ref/Bug294.html +++ b/html-test/ref/Bug294.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug298.html b/html-test/ref/Bug298.html index a748e92a..cba626b6 100644 --- a/html-test/ref/Bug298.html +++ b/html-test/ref/Bug298.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug3.html b/html-test/ref/Bug3.html index d5f589ed..4a9cf8bc 100644 --- a/html-test/ref/Bug3.html +++ b/html-test/ref/Bug3.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug308.html b/html-test/ref/Bug308.html index 03f287d5..d816fef5 100644 --- a/html-test/ref/Bug308.html +++ b/html-test/ref/Bug308.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug308CrossModule.html b/html-test/ref/Bug308CrossModule.html index d9ed0b19..60f371af 100644 --- a/html-test/ref/Bug308CrossModule.html +++ b/html-test/ref/Bug308CrossModule.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug310.html b/html-test/ref/Bug310.html index 2ba8dfb9..468e64eb 100644 --- a/html-test/ref/Bug310.html +++ b/html-test/ref/Bug310.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug313.html b/html-test/ref/Bug313.html index a6573eaa..4fc1682c 100644 --- a/html-test/ref/Bug313.html +++ b/html-test/ref/Bug313.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html index f9eec481..d1602c7b 100644 --- a/html-test/ref/Bug335.html +++ b/html-test/ref/Bug335.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html index 6305a38d..27d47e75 100644 --- a/html-test/ref/Bug387.html +++ b/html-test/ref/Bug387.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug4.html b/html-test/ref/Bug4.html index 722d4102..fe6f47d1 100644 --- a/html-test/ref/Bug4.html +++ b/html-test/ref/Bug4.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug6.html b/html-test/ref/Bug6.html index 34fc4054..678f4070 100644 --- a/html-test/ref/Bug6.html +++ b/html-test/ref/Bug6.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug7.html b/html-test/ref/Bug7.html index cf6f2f2a..ef26d62f 100644 --- a/html-test/ref/Bug7.html +++ b/html-test/ref/Bug7.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bug8.html b/html-test/ref/Bug8.html index d6cef1b2..1b6c1525 100644 --- a/html-test/ref/Bug8.html +++ b/html-test/ref/Bug8.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/BugDeprecated.html b/html-test/ref/BugDeprecated.html index 2fb509d8..96fdab34 100644 --- a/html-test/ref/BugDeprecated.html +++ b/html-test/ref/BugDeprecated.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/BugExportHeadings.html b/html-test/ref/BugExportHeadings.html index 8d444e26..2a05bed9 100644 --- a/html-test/ref/BugExportHeadings.html +++ b/html-test/ref/BugExportHeadings.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Bugs.html b/html-test/ref/Bugs.html index b83036c8..c29004f3 100644 --- a/html-test/ref/Bugs.html +++ b/html-test/ref/Bugs.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedClass.html b/html-test/ref/DeprecatedClass.html index ac14b0d4..f055f36f 100644 --- a/html-test/ref/DeprecatedClass.html +++ b/html-test/ref/DeprecatedClass.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedData.html b/html-test/ref/DeprecatedData.html index 248de4cb..aeb2a7c8 100644 --- a/html-test/ref/DeprecatedData.html +++ b/html-test/ref/DeprecatedData.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedFunction.html b/html-test/ref/DeprecatedFunction.html index 59206ac9..f4381d96 100644 --- a/html-test/ref/DeprecatedFunction.html +++ b/html-test/ref/DeprecatedFunction.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedFunction2.html b/html-test/ref/DeprecatedFunction2.html index 36159359..b8985bcd 100644 --- a/html-test/ref/DeprecatedFunction2.html +++ b/html-test/ref/DeprecatedFunction2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedFunction3.html b/html-test/ref/DeprecatedFunction3.html index 1bfc7d90..b62e1ee3 100644 --- a/html-test/ref/DeprecatedFunction3.html +++ b/html-test/ref/DeprecatedFunction3.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedModule.html b/html-test/ref/DeprecatedModule.html index a6b2e0e8..84c7a885 100644 --- a/html-test/ref/DeprecatedModule.html +++ b/html-test/ref/DeprecatedModule.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedModule2.html b/html-test/ref/DeprecatedModule2.html index bd7a7f31..862f79ee 100644 --- a/html-test/ref/DeprecatedModule2.html +++ b/html-test/ref/DeprecatedModule2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedNewtype.html b/html-test/ref/DeprecatedNewtype.html index 3d826f57..a03d63fb 100644 --- a/html-test/ref/DeprecatedNewtype.html +++ b/html-test/ref/DeprecatedNewtype.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedReExport.html b/html-test/ref/DeprecatedReExport.html index e5a3c38c..52f2b8e9 100644 --- a/html-test/ref/DeprecatedReExport.html +++ b/html-test/ref/DeprecatedReExport.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedRecord.html b/html-test/ref/DeprecatedRecord.html index ff217c4d..79b7b7f9 100644 --- a/html-test/ref/DeprecatedRecord.html +++ b/html-test/ref/DeprecatedRecord.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedTypeFamily.html b/html-test/ref/DeprecatedTypeFamily.html index 4a5028f3..1d94e99b 100644 --- a/html-test/ref/DeprecatedTypeFamily.html +++ b/html-test/ref/DeprecatedTypeFamily.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/DeprecatedTypeSynonym.html b/html-test/ref/DeprecatedTypeSynonym.html index 8f1896df..cb7a3afe 100644 --- a/html-test/ref/DeprecatedTypeSynonym.html +++ b/html-test/ref/DeprecatedTypeSynonym.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Examples.html b/html-test/ref/Examples.html index 7f742f2f..f706eef1 100644 --- a/html-test/ref/Examples.html +++ b/html-test/ref/Examples.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Extensions.html b/html-test/ref/Extensions.html index 01dde2d3..e21785c0 100644 --- a/html-test/ref/Extensions.html +++ b/html-test/ref/Extensions.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html index 4c285c41..df597e12 100644 --- a/html-test/ref/FunArgs.html +++ b/html-test/ref/FunArgs.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/GADTRecords.html b/html-test/ref/GADTRecords.html index 6c091ac3..3b036aae 100644 --- a/html-test/ref/GADTRecords.html +++ b/html-test/ref/GADTRecords.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Hash.html b/html-test/ref/Hash.html index ac422955..4ad1c27e 100644 --- a/html-test/ref/Hash.html +++ b/html-test/ref/Hash.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/HiddenInstances.html b/html-test/ref/HiddenInstances.html index 5071e702..8c7312d7 100644 --- a/html-test/ref/HiddenInstances.html +++ b/html-test/ref/HiddenInstances.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/HiddenInstancesB.html b/html-test/ref/HiddenInstancesB.html index b3cf9ef9..77af69d0 100644 --- a/html-test/ref/HiddenInstancesB.html +++ b/html-test/ref/HiddenInstancesB.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Hyperlinks.html b/html-test/ref/Hyperlinks.html index 66b14d7a..db1953e3 100644 --- a/html-test/ref/Hyperlinks.html +++ b/html-test/ref/Hyperlinks.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html index 235d601c..262bb769 100644 --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/ImplicitParams.html b/html-test/ref/ImplicitParams.html index c08a565a..d22e7f4c 100644 --- a/html-test/ref/ImplicitParams.html +++ b/html-test/ref/ImplicitParams.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html index ba6ef185..b014e8df 100644 --- a/html-test/ref/Instances.html +++ b/html-test/ref/Instances.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Minimal.html b/html-test/ref/Minimal.html index ac28b0d9..b7507bd7 100644 --- a/html-test/ref/Minimal.html +++ b/html-test/ref/Minimal.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/NamedDoc.html b/html-test/ref/NamedDoc.html index 631f2043..a10aa305 100644 --- a/html-test/ref/NamedDoc.html +++ b/html-test/ref/NamedDoc.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Nesting.html b/html-test/ref/Nesting.html index 370c6a88..7ce0c0d8 100644 --- a/html-test/ref/Nesting.html +++ b/html-test/ref/Nesting.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/NoLayout.html b/html-test/ref/NoLayout.html index d8148b0e..43352864 100644 --- a/html-test/ref/NoLayout.html +++ b/html-test/ref/NoLayout.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/NonGreedy.html b/html-test/ref/NonGreedy.html index c389fc6a..6ed1563f 100644 --- a/html-test/ref/NonGreedy.html +++ b/html-test/ref/NonGreedy.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index 27b3427d..d498a906 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/OrphanInstancesClass.html b/html-test/ref/OrphanInstancesClass.html index 98641d0b..93594d90 100644 --- a/html-test/ref/OrphanInstancesClass.html +++ b/html-test/ref/OrphanInstancesClass.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/OrphanInstancesType.html b/html-test/ref/OrphanInstancesType.html index d616edf9..5d7a76c9 100644 --- a/html-test/ref/OrphanInstancesType.html +++ b/html-test/ref/OrphanInstancesType.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index 2052d87c..9f0caaa2 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Properties.html b/html-test/ref/Properties.html index 27f3a93a..4ce37acd 100644 --- a/html-test/ref/Properties.html +++ b/html-test/ref/Properties.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/PruneWithWarning.html b/html-test/ref/PruneWithWarning.html index 7523c657..e714ec21 100644 --- a/html-test/ref/PruneWithWarning.html +++ b/html-test/ref/PruneWithWarning.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/QuasiExpr.html b/html-test/ref/QuasiExpr.html index c51ac526..0b5b8054 100644 --- a/html-test/ref/QuasiExpr.html +++ b/html-test/ref/QuasiExpr.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/QuasiQuote.html b/html-test/ref/QuasiQuote.html index 251c48dc..4919e48d 100644 --- a/html-test/ref/QuasiQuote.html +++ b/html-test/ref/QuasiQuote.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html index 285ab05c..b7c707c5 100644 --- a/html-test/ref/SpuriousSuperclassConstraints.html +++ b/html-test/ref/SpuriousSuperclassConstraints.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TH2.html b/html-test/ref/TH2.html index 71bc1083..5562cb67 100644 --- a/html-test/ref/TH2.html +++ b/html-test/ref/TH2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Threaded.html b/html-test/ref/Threaded.html index bb31f300..ac6a66b9 100644 --- a/html-test/ref/Threaded.html +++ b/html-test/ref/Threaded.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Threaded_TH.html b/html-test/ref/Threaded_TH.html index 2890ca6b..89f276c9 100644 --- a/html-test/ref/Threaded_TH.html +++ b/html-test/ref/Threaded_TH.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Ticket61.html b/html-test/ref/Ticket61.html index cb9ba8bd..cfc2e7f7 100644 --- a/html-test/ref/Ticket61.html +++ b/html-test/ref/Ticket61.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Ticket75.html b/html-test/ref/Ticket75.html index 07e75296..616f5d47 100644 --- a/html-test/ref/Ticket75.html +++ b/html-test/ref/Ticket75.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TitledPicture.html b/html-test/ref/TitledPicture.html index 04d1476b..927631f8 100644 --- a/html-test/ref/TitledPicture.html +++ b/html-test/ref/TitledPicture.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index db6ee1c3..c6301a56 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TypeFamilies2.html b/html-test/ref/TypeFamilies2.html index 156486d0..65ab0317 100644 --- a/html-test/ref/TypeFamilies2.html +++ b/html-test/ref/TypeFamilies2.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/TypeOperators.html b/html-test/ref/TypeOperators.html index 53428892..b461ac71 100644 --- a/html-test/ref/TypeOperators.html +++ b/html-test/ref/TypeOperators.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Unicode.html b/html-test/ref/Unicode.html index 59f715e8..ae1d4293 100644 --- a/html-test/ref/Unicode.html +++ b/html-test/ref/Unicode.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/Visible.html b/html-test/ref/Visible.html index 47568b65..d9b8cd11 100644 --- a/html-test/ref/Visible.html +++ b/html-test/ref/Visible.html @@ -10,7 +10,7 @@ > +> \ No newline at end of file diff --git a/html-test/ref/haddock-util.js b/html-test/ref/haddock-util.js index 92d07d2a..05bdaef5 100644 --- a/html-test/ref/haddock-util.js +++ b/html-test/ref/haddock-util.js @@ -1,7 +1,7 @@ // Haddock JavaScript utilities var rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; + rtrim = /^\s+|\s+$/g; function spaced(s) { return (" " + s + " ").replace(rspace, " "); } function trim(s) { return s.replace(rtrim, ""); } @@ -109,136 +109,6 @@ function getCookie(name) { return null; } - - -var max_results = 75; // 50 is not enough to search for map in the base libraries -var shown_range = null; -var last_search = null; - -function quick_search() -{ - perform_search(false); -} - -function full_search() -{ - perform_search(true); -} - - -function perform_search(full) -{ - var text = document.getElementById("searchbox").value.toLowerCase(); - if (text == last_search && !full) return; - last_search = text; - - var table = document.getElementById("indexlist"); - var status = document.getElementById("searchmsg"); - var children = table.firstChild.childNodes; - - // first figure out the first node with the prefix - var first = bisect(-1); - var last = (first == -1 ? -1 : bisect(1)); - - if (first == -1) - { - table.className = ""; - status.innerHTML = "No results found, displaying all"; - } - else if (first == 0 && last == children.length - 1) - { - table.className = ""; - status.innerHTML = ""; - } - else if (last - first >= max_results && !full) - { - table.className = ""; - status.innerHTML = "More than " + max_results + ", press Search to display"; - } - else - { - // decide what you need to clear/show - if (shown_range) - setclass(shown_range[0], shown_range[1], "indexrow"); - setclass(first, last, "indexshow"); - shown_range = [first, last]; - table.className = "indexsearch"; - status.innerHTML = ""; - } - - - function setclass(first, last, status) - { - for (var i = first; i <= last; i++) - { - children[i].className = status; - } - } - - - // do a binary search, treating 0 as ... - // return either -1 (no 0's found) or location of most far match - function bisect(dir) - { - var first = 0, finish = children.length - 1; - var mid, success = false; - - while (finish - first > 3) - { - mid = Math.floor((finish + first) / 2); - - var i = checkitem(mid); - if (i == 0) i = dir; - if (i == -1) - finish = mid; - else - first = mid; - } - var a = (dir == 1 ? first : finish); - var b = (dir == 1 ? finish : first); - for (var i = b; i != a - dir; i -= dir) - { - if (checkitem(i) == 0) return i; - } - return -1; - } - - - // from an index, decide what the result is - // 0 = match, -1 is lower, 1 is higher - function checkitem(i) - { - var s = getitem(i).toLowerCase().substr(0, text.length); - if (s == text) return 0; - else return (s > text ? -1 : 1); - } - - - // from an index, get its string - // this abstracts over alternates - function getitem(i) - { - for ( ; i >= 0; i--) - { - var s = children[i].firstChild.firstChild.data; - if (s.indexOf(' ') == -1) - return s; - } - return ""; // should never be reached - } -} - -function setSynopsis(filename) { - if (parent.window.synopsis && parent.window.synopsis.location) { - if (parent.window.synopsis.location.replace) { - // In Firefox this avoids adding the change to the history. - parent.window.synopsis.location.replace(filename); - } else { - parent.window.synopsis.location = filename; - } - } -} - function addMenuItem(html) { var menu = document.getElementById("page-menu"); if (menu) { -- cgit v1.2.3 From 87c551fc668b9251f2647cce8772f205e1cee154 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Fri, 9 Jun 2017 08:26:43 +0200 Subject: Haddock support for bundled pattern synonyms (#627) * Haddock support for bundled pattern synonyms * Add fixities to bundled pattern synonyms * Add bundled pattern synonyms to the synopsis * Store bundled pattern fixities in expItemFixities * Add test for bundled pattern synonyms * Stop threading fixities * Include bundled pattern synonyms for re-exported data types Sadly, fixity information isn't found for re-exported data types * Support for pattern synonyms * Modify tests after #631 * Test some reexport variations * Also lookup bundled pattern synonyms from `InstalledInterface`s * Check isExported for bundled pattern synonyms * Pattern synonym is exported check * Always look for pattern synonyms in the current module Another overlooked cornercase * Account for types named twice in export lists Also introduce a fast function for nubbing on a `Name` and use it throughout the code base. * correct fixities for reexported pattern synonyms * Fuse concatMap and map * Remove obsolete import * Add pattern synonyms to visible exports * Fix test * Remove corner case --- CHANGES.md | 2 + haddock-api/src/Haddock/Backends/LaTeX.hs | 32 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 4 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 56 ++- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 + haddock-api/src/Haddock/GhcUtils.hs | 14 +- .../src/Haddock/Interface/AttachInstances.hs | 11 +- haddock-api/src/Haddock/Interface/Create.hs | 183 +++++--- haddock-api/src/Haddock/Interface/Rename.hs | 12 +- haddock-api/src/Haddock/InterfaceFile.hs | 8 +- haddock-api/src/Haddock/Types.hs | 50 ++- html-test/ref/BundledPatterns.html | 474 +++++++++++++++++++++ html-test/ref/BundledPatterns2.html | 472 ++++++++++++++++++++ html-test/src/BundledPatterns.hs | 110 +++++ html-test/src/BundledPatterns2.hs | 10 + 15 files changed, 1329 insertions(+), 113 deletions(-) create mode 100644 html-test/ref/BundledPatterns.html create mode 100644 html-test/ref/BundledPatterns2.html create mode 100644 html-test/src/BundledPatterns.hs create mode 100644 html-test/src/BundledPatterns2.hs (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs') diff --git a/CHANGES.md b/CHANGES.md index 95e1763a..628b0968 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,8 @@ * Synopsis is working again (#599) + * Support for bundled pattern synonyms (#494, #551, #626) + ## Changes in version 2.17.4 * Fix 'internal error: links: UnhelpfulSpan' (#554, #565) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 53cfccff..18660b3f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -227,8 +227,8 @@ isExportModule _ = Nothing processExport :: ExportItem DocName -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) -processExport (ExportDecl decl doc subdocs insts fixities _splice) - = ppDecl decl doc insts subdocs fixities +processExport (ExportDecl decl pats doc subdocs insts fixities _splice) + = ppDecl decl pats doc insts subdocs fixities processExport (ExportNoDecl y []) = ppDocName y processExport (ExportNoDecl y subs) @@ -278,16 +278,17 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c) ppDecl :: LHsDecl DocName + -> [(HsDecl DocName,DocForDecl DocName)] -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX -ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of +ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode TyClD d@(DataDecl {}) - -> ppDataDecl instances subdocs loc (Just doc) d unicode + -> ppDataDecl pats instances subdocs loc (Just doc) d unicode TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now -- TyClD d@(TySynonym {}) @@ -565,11 +566,11 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ------------------------------------------------------------------------------- -ppDataDecl :: [DocInstance DocName] -> +ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> LaTeX -ppDataDecl instances subdocs _loc doc dataDecl unicode +ppDataDecl pats instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body)) @@ -579,10 +580,12 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode cons = dd_cons (tcdDataDefn dataDecl) resTy = (unLoc . head) cons - body = catMaybes [constrBit, doc >>= documentationToLaTeX] + body = catMaybes [constrBit,patternBit, doc >>= documentationToLaTeX] (whereBit, leaders) - | null cons = (empty,[]) + | null cons + , null pats = (empty,[]) + | null cons = (decltt (keyword "where"), repeat empty) | otherwise = case resTy of ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) @@ -594,6 +597,19 @@ ppDataDecl instances subdocs _loc doc dataDecl unicode vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" + patternBit + | null cons = Nothing + | otherwise = Just $ + text "\\haddockbeginconstrs" $$ + vcat [ hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames + , dcolon unicode + , ppLType unicode (hsSigType ty) + ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d) + | (SigD (PatSynSig lnames ty),d) <- pats + ] $$ + text "\\end{tabulary}\\par" + instancesBit = ppDocInstances unicode instances diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 34ecc5b8..249389b9 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -604,8 +604,8 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) -processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual +processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode qual processExport summary _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y processExport summary _ _ qual (ExportNoDecl y subs) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 035c8e9e..716050fa 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -41,11 +41,12 @@ import BooleanFormula import RdrName ( rdrNameOcc ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName - -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] + -> [(HsDecl DocName, DocForDecl DocName)] + -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html -ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of +ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode qual TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames @@ -613,7 +614,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = , [subFamInstDetails iid pdecl]) where pdata = keyword "data" <+> typ - pdecl = pdata <+> ppShortDataDecl False True dd unicode qual + pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where iid = instanceId origin no orphan ihd typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual @@ -662,20 +663,23 @@ instanceId origin no orphan ihd = concat $ -- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html -ppShortDataDecl summary dataInst dataDecl unicode qual +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName + -> [(HsDecl DocName,DocForDecl DocName)] + -> Unicode -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl pats unicode qual - | [] <- cons = dataHeader + | [] <- cons + , [] <- pats = dataHeader - | [lcon] <- cons, isH98, + | [lcon] <- cons, [] <- pats, isH98, (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - | isH98 = dataHeader - +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) + | [] <- pats, isH98 = dataHeader + +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons ++ pats1) | otherwise = (dataHeader <+> keyword "where") - +++ shortSubDecls dataInst (map doGADTConstr cons) + +++ shortSubDecls dataInst (map doGADTConstr cons ++ pats1) where dataHeader @@ -689,16 +693,25 @@ ppShortDataDecl summary dataInst dataDecl unicode qual ConDeclH98 {} -> True ConDeclGADT{} -> False + pats1 = [ hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames + , dcolon unicode + , ppLType unicode qual (hsSigType typ) + ] + | (SigD (PatSynSig lnames typ),_) <- pats + ] + ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> + [(HsDecl DocName,DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html -ppDataDecl summary links instances fixities subdocs loc doc dataDecl +ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual - | summary = ppShortDataDecl summary False dataDecl unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit + | summary = ppShortDataDecl summary False dataDecl pats unicode qual + | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl @@ -713,7 +726,9 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual whereBit - | null cons = noHtml + | null cons + , null pats = noHtml + | null cons = keyword "where" | otherwise = if isH98 then noHtml else keyword "where" constrBit = subConstructors qual @@ -723,6 +738,17 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl (map unLoc (getConNames (unLoc c)))) fixities ] + patternBit = subPatterns qual + [ (hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames + , dcolon unicode + , ppLType unicode qual (hsSigType typ) + ] <+> ppFixities subfixs qual + ,combineDocumentation (fst d), []) + | (SigD (PatSynSig lnames typ),d) <- pats + , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities + ] + instancesBit = ppInstances links (OriginData docname) instances splice unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 41457f72..6993c7f6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -29,6 +29,7 @@ module Haddock.Backends.Xhtml.Layout ( subArguments, subAssociatedTypes, subConstructors, + subPatterns, subEquations, subFields, subInstances, subOrphanInstances, @@ -180,6 +181,9 @@ subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBloc subConstructors :: Qualification -> [SubDecl] -> Html subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual +subPatterns :: Qualification -> [SubDecl] -> Html +subPatterns qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable qual + subFields :: Qualification -> [SubDecl] -> Html subFields qual = divSubDecls "fields" "Fields" . subDlist qual diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 4280cd80..02867833 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -21,6 +21,7 @@ import Control.Arrow import Exception import Outputable import Name +import NameSet import Lexeme import Module import HscTypes @@ -135,6 +136,17 @@ declATs _ = [] pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr +nubByName :: (a -> Name) -> [a] -> [a] +nubByName f ns = go emptyNameSet ns + where + go !_ [] = [] + go !s (x:xs) + | y `elemNameSet` s = go s xs + | otherwise = let !s' = extendNameSet s y + in x : go s' xs + where + y = f x + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index d5d74819..7a3182b8 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -21,7 +21,6 @@ import Haddock.GhcUtils import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) -import Data.Function (on) import Data.Maybe ( maybeToList, mapMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set @@ -109,13 +108,17 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export = return $ e { expItemInstances = insts } e -> return e where - attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = - nubBy ((==) `on` fst) $ expItemFixities e ++ + attachFixities e@ExportDecl{ expItemDecl = L _ d + , expItemPats = patsyns + } = e { expItemFixities = + nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap] - , n' <- n : subs + , n' <- n : (subs ++ patsyn_names) , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } + where + patsyn_names = concatMap (getMainDeclBinder . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 36b0b7bb..0984894d 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -42,7 +42,7 @@ import Control.Arrow (second) import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad -import Data.Function (on) +import Data.Traversable import qualified Packages import qualified Module @@ -81,7 +81,10 @@ createInterface tm flags modMap instIfaceMap = do !fam_instances = md_fam_insts md !exportedNames = modInfoExports mi - (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm + (TcGblEnv { tcg_rdr_env = gre + , tcg_warns = warnings + , tcg_patsyns = patsyns + }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -101,6 +104,28 @@ createInterface tm flags modMap instIfaceMap = do (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ + + exports0 = fmap (reverse . map unLoc) mayExports + exports + | OptIgnoreExports `elem` opts = Nothing + | otherwise = exports0 + warningMap = mkWarningMap dflags warnings gre exportedNames + + localBundledPatSyns :: Map Name [Name] + localBundledPatSyns = + case exports of + Nothing -> M.empty + Just ies -> + M.map (nubByName id) $ + M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns) + | IEThingWith (L _ ty_name) _ exported _ <- ies + , let bundled_patsyns = + filter is_patsyn (map (ieWrappedName . unLoc) exported) + , not (null bundled_patsyns) + ] + where + is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns)) + fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) @@ -112,18 +137,12 @@ createInterface tm flags modMap instIfaceMap = do maps@(!docMap, !argMap, !subMap, !declMap, _) = mkMaps dflags gre localInsts declsWithDocs - let exports0 = fmap (reverse . map unLoc) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 - warningMap = mkWarningMap dflags warnings gre exportedNames - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls - maps fixMap splices exports instIfaceMap dflags + maps localBundledPatSyns fixMap splices exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -147,32 +166,33 @@ createInterface tm flags modMap instIfaceMap = do tokenizedSrc <- mkMaybeTokenizedSrc flags tm return $! Interface { - ifaceMod = mdl - , ifaceIsSig = is_sig - , ifaceOrigFilename = msHsFilePath ms - , ifaceInfo = info - , ifaceDoc = Documentation mbDoc modWarn - , ifaceRnDoc = Documentation Nothing Nothing - , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty - , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] - , ifaceExports = exportedNames - , ifaceVisibleExports = visibleNames - , ifaceDeclMap = declMap - , ifaceSubMap = subMap - , ifaceFixMap = fixMap - , ifaceModuleAliases = aliases - , ifaceInstances = instances - , ifaceFamInstances = fam_instances + ifaceMod = mdl + , ifaceIsSig = is_sig + , ifaceOrigFilename = msHsFilePath ms + , ifaceInfo = info + , ifaceDoc = Documentation mbDoc modWarn + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = opts + , ifaceDocMap = docMap + , ifaceArgMap = argMap + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = prunedExportItems + , ifaceRnExportItems = [] + , ifaceExports = exportedNames + , ifaceVisibleExports = visibleNames + , ifaceDeclMap = declMap + , ifaceBundledPatSynMap = localBundledPatSyns + , ifaceSubMap = subMap + , ifaceFixMap = fixMap + , ifaceModuleAliases = aliases + , ifaceInstances = instances + , ifaceFamInstances = fam_instances , ifaceOrphanInstances = [] -- Filled in `attachInstances` , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = tokenizedSrc + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap + , ifaceTokenizedSrc = tokenizedSrc } -- | Given all of the @import M as N@ declarations in a package, @@ -295,8 +315,9 @@ mkMaps :: DynFlags -> [(LHsDecl Name, [HsDocString])] -> Maps mkMaps dflags gre instances decls = - let (a, b, c, d) = unzip4 $ map mappings decls - in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) + let + (a, b, c, d) = unzip4 $ map mappings decls + in (f' $ map (nubByName fst) a , f b, f c, f d, instanceMap) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -362,7 +383,9 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates :: InstMap + -> HsDecl Name + -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do DataFamInstDecl { dfid_tycon = L l _ @@ -539,6 +562,7 @@ mkExportItems -> [Name] -- exported names (orig) -> [LHsDecl Name] -- renamed source declarations -> Maps + -> Map Name [Name] -> FixMap -> [SrcSpan] -- splice locations -> Maybe [IE Name] @@ -547,15 +571,21 @@ mkExportItems -> ErrMsgGhc [ExportItem Name] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = + maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags = case optExports of Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith $ ieWrappedName x - lookupExport (IEThingAbs (L _ t)) = declWith $ ieWrappedName t - lookupExport (IEThingAll (L _ t)) = declWith $ ieWrappedName t - lookupExport (IEThingWith (L _ t) _ _ _) = declWith $ ieWrappedName t + lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x + lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t + lookupExport (IEThingAll (L _ t)) = do + let name = ieWrappedName t + pats <- findBundledPatterns name + declWith pats name + lookupExport (IEThingWith (L _ t) _ _ _) = do + let name = ieWrappedName t + pats <- findBundledPatterns name + declWith pats name lookupExport (IEModuleContents (L _ m)) = -- TODO: We could get more accurate reporting here if IEModuleContents -- also recorded the actual names that are exported here. We CAN @@ -574,8 +604,8 @@ mkExportItems Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - declWith :: Name -> ErrMsgGhc [ ExportItem Name ] - declWith t = do + declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] + declWith pats t = do r <- findDecl t case r of ([L l (ValD _)], (doc, _)) -> do @@ -612,15 +642,15 @@ mkExportItems -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig - in return [ mkExportDecl t newDecl docs_ ] + in return [ mkExportDecl t newDecl pats docs_ ] L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef return [ mkExportDecl t - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] - _ -> return [ mkExportDecl t decl docs_ ] + _ -> return [ mkExportDecl t decl pats docs_ ] -- Declaration from another package ([], _) -> do @@ -637,20 +667,24 @@ mkExportItems liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] - return [ mkExportDecl t decl (noDocForDecl, subs_) ] + return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] - mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name - mkExportDecl name decl (doc, subs) = decl' + mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)] + -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name + mkExportDecl name decl pats (doc, subs) = decl' where - decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False + decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False subs' = filter (isExported . fst) subs + pats' = [ d | d@(patsyn_decl, _) <- pats + , all isExported (getMainDeclBinder patsyn_decl) ] sub_names = map fst subs' - fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] + pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl] + fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet @@ -684,6 +718,40 @@ mkExportItems where m = nameModule n + findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)] + findBundledPatterns t = + let + m = nameModule t + + local_bundled_patsyns = + M.findWithDefault [] t patSynMap + + iface_bundled_patsyns + | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap + , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface) + = patsyns + + | Just iface <- M.lookup m instIfaceMap + , Just patsyns <- M.lookup t (instBundledPatSynMap iface) + = patsyns + + | otherwise + = [] + + patsyn_decls = do + for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do + -- call declWith here so we don't have to prepare the pattern synonym for + -- showing ourselves. + export_items <- declWith [] patsyn_name + pure [ (unLoc patsyn_decl, patsyn_doc) + | ExportDecl { + expItemDecl = patsyn_decl + , expItemMbDoc = patsyn_doc + } <- export_items + ] + + in concat <$> patsyn_decls + -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. semToIdMod :: UnitId -> Module -> Module @@ -718,7 +786,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice) + Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice) where fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t fixities = case fixity of @@ -873,12 +941,12 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap fixities name subs = [ (n,f) | n <- name : map fst subs , Just f <- [M.lookup n fixMap] ] - expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) where (doc, subs) = lookupDocs name warnings docMap argMap subMap expInst decl l name = let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) -- | Sometimes the declaration we want to export is not the "main" declaration: @@ -958,8 +1026,9 @@ mkVisibleNames (_, _, _, _, instMap) exports opts | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns where - exportName e@ExportDecl {} = name ++ subs - where subs = map fst (expItemSubDocs e) + exportName e@ExportDecl {} = name ++ subs ++ patsyns + where subs = map fst (expItemSubDocs e) + patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap decl -> getMainDeclBinder decl diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b43860fb..5820c61e 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -55,7 +55,7 @@ renameInterface dflags renamingEnv warnings iface = -- combine the missing names and filter out the built-ins, which would -- otherwise always be missing. - missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much + missingNames = nubByName id $ filter isExternalName -- XXX: isExternalName filters out too much (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) @@ -314,6 +314,11 @@ renameInstHead InstHead {..} = do renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d +renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)] +renamePats = mapM + (\(d,doc) -> do { d' <- renameDecl d + ; doc' <- renameDocForDecl doc + ; return (d',doc')}) renameDecl :: HsDecl Name -> RnM (HsDecl DocName) renameDecl decl = case decl of @@ -601,15 +606,16 @@ renameExportItem item = case item of ExportGroup lev id_ doc -> do doc' <- renameDoc doc return (ExportGroup lev id_ doc') - ExportDecl decl doc subs instances fixities splice -> do + ExportDecl decl pats doc subs instances fixities splice -> do decl' <- renameLDecl decl + pats' <- renamePats pats doc' <- renameDocForDecl doc subs' <- mapM renameSub subs instances' <- forM instances renameDocInstance fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity) - return (ExportDecl decl' doc' subs' instances' fixities' splice) + return (ExportDecl decl' pats' doc' subs' instances' fixities' splice) ExportNoDecl x subs -> do x' <- lookupRn x subs' <- mapM lookupRn subs diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e5c2face..054c1384 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804) -binaryInterfaceVersion = 30 +binaryInterfaceVersion = 31 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -373,7 +373,7 @@ instance Binary InterfaceFile where instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap fixMap) = do + exps visExps opts subMap patSynMap fixMap) = do put_ bh modu put_ bh is_sig put_ bh info @@ -382,6 +382,7 @@ instance Binary InstalledInterface where put_ bh visExps put_ bh opts put_ bh subMap + put_ bh patSynMap put_ bh fixMap get bh = do @@ -393,10 +394,11 @@ instance Binary InstalledInterface where visExps <- get bh opts <- get bh subMap <- get bh + patSynMap <- get bh fixMap <- get bh return (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap fixMap) + exps visExps opts subMap patSynMap fixMap) instance Binary DocOption where diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 803995cc..bfc8e32b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -103,6 +103,9 @@ data Interface = Interface -- names of subordinate declarations mapped to their parent declarations. , ifaceDeclMap :: !(Map Name [LHsDecl Name]) + -- | Bundled pattern synonym declarations for specific types. + , ifaceBundledPatSynMap :: !(Map Name [Name]) + -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name) @@ -158,49 +161,53 @@ type WarningMap = Map Name (Doc Name) data InstalledInterface = InstalledInterface { -- | The module represented by this interface. - instMod :: Module + instMod :: Module -- | Is this a signature? - , instIsSig :: Bool + , instIsSig :: Bool -- | Textual information about the module. - , instInfo :: HaddockModInfo Name + , instInfo :: HaddockModInfo Name -- | Documentation of declarations originating from the module (including -- subordinates). - , instDocMap :: DocMap Name + , instDocMap :: DocMap Name - , instArgMap :: ArgMap Name + , instArgMap :: ArgMap Name -- | All names exported by this module. - , instExports :: [Name] + , instExports :: [Name] -- | All \"visible\" names exported by the module. -- A visible name is a name that will show up in the documentation of the -- module. - , instVisibleExports :: [Name] + , instVisibleExports :: [Name] -- | Haddock options for this module (prune, ignore-exports, etc). - , instOptions :: [DocOption] + , instOptions :: [DocOption] + + , instSubMap :: Map Name [Name] - , instSubMap :: Map Name [Name] - , instFixMap :: Map Name Fixity + , instBundledPatSynMap :: Map Name [Name] + + , instFixMap :: Map Name Fixity } -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface - { instMod = ifaceMod interface - , instIsSig = ifaceIsSig interface - , instInfo = ifaceInfo interface - , instDocMap = ifaceDocMap interface - , instArgMap = ifaceArgMap interface - , instExports = ifaceExports interface - , instVisibleExports = ifaceVisibleExports interface - , instOptions = ifaceOptions interface - , instSubMap = ifaceSubMap interface - , instFixMap = ifaceFixMap interface + { instMod = ifaceMod interface + , instIsSig = ifaceIsSig interface + , instInfo = ifaceInfo interface + , instDocMap = ifaceDocMap interface + , instArgMap = ifaceArgMap interface + , instExports = ifaceExports interface + , instVisibleExports = ifaceVisibleExports interface + , instOptions = ifaceOptions interface + , instSubMap = ifaceSubMap interface + , instBundledPatSynMap = ifaceBundledPatSynMap interface + , instFixMap = ifaceFixMap interface } @@ -217,6 +224,9 @@ data ExportItem name -- | A declaration. expItemDecl :: !(LHsDecl name) + -- | Bundled patterns for a data type declaration + , expItemPats :: ![(HsDecl name, DocForDecl name)] + -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). , expItemMbDoc :: !(DocForDecl name) diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html new file mode 100644 index 00000000..bf6c073c --- /dev/null +++ b/html-test/ref/BundledPatterns.html @@ -0,0 +1,474 @@ +BundledPatterns
Safe HaskellNone

BundledPatterns

Synopsis

Documentation

data Vec :: Nat -> * -> * where #

Fixed size vectors.

  • Lists with their length encoded in their type
  • Vector elements have an ASCENDING subscript starting from 0 and + ending at length - 1.

Constructors

Nil :: Vec 0 a

Bundled Patterns

pattern (:>) :: a -> Vec n a -> Vec (n + 1) a infixr 5

Add an element to the head of a vector.

>>> 3:>4:>5:>Nil
+<3,4,5>
+>>> let x = 3:>4:>5:>Nil
+>>> :t x
+x :: Num a => Vec 3 a
+

Can be used as a pattern:

>>> let f (x :> y :> _) = x + y
+>>> :t f
+f :: Num a => Vec ((n + 1) + 1) a -> a
+>>> f (3:>4:>5:>6:>7:>Nil)
+7
+

Also in conjunctions with (:<):

>>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y
+>>> :t g
+g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a
+>>> g (1:>2:>3:>4:>5:>Nil)
+12
+

data RTree :: Nat -> * -> * where #

Perfect depth binary tree.

  • Only has elements at the leaf of the tree
  • A tree of depth d has 2^d elements.

Bundled Patterns

pattern LR :: a -> RTree 0 a

Leaf of a perfect depth tree

>>> LR 1
+1
+>>> let x = LR 1
+>>> :t x
+x :: Num a => RTree 0 a
+

Can be used as a pattern:

>>> let f (LR a) (LR b) = a + b
+>>> :t f
+f :: Num a => RTree 0 a -> RTree 0 a -> a
+>>> f (LR 1) (LR 2)
+3
+
pattern BR :: RTree d a -> RTree d a -> RTree (d + 1) a

Branch of a perfect depth tree

>>> BR (LR 1) (LR 2)
+<1,2>
+>>> let x = BR (LR 1) (LR 2)
+>>> :t x
+x :: Num a => RTree 1 a
+

Case be used a pattern:

>>> let f (BR (LR a) (LR b)) = LR (a + b)
+>>> :t f
+f :: Num a => RTree 1 a -> RTree 0 a
+>>> f (BR (LR 1) (LR 2))
+3
+
\ No newline at end of file diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html new file mode 100644 index 00000000..3d1d4da0 --- /dev/null +++ b/html-test/ref/BundledPatterns2.html @@ -0,0 +1,472 @@ +BundledPatterns2
Safe HaskellNone

BundledPatterns2

Synopsis

Documentation

data Vec :: Nat -> * -> * where #

Fixed size vectors.

  • Lists with their length encoded in their type
  • Vector elements have an ASCENDING subscript starting from 0 and + ending at length - 1.

Bundled Patterns

pattern Empty :: Vec 0 a
pattern (:>) :: a -> Vec n a -> Vec (n + 1) a infixr 5

Add an element to the head of a vector.

>>> 3:>4:>5:>Nil
+<3,4,5>
+>>> let x = 3:>4:>5:>Nil
+>>> :t x
+x :: Num a => Vec 3 a
+

Can be used as a pattern:

>>> let f (x :> y :> _) = x + y
+>>> :t f
+f :: Num a => Vec ((n + 1) + 1) a -> a
+>>> f (3:>4:>5:>6:>7:>Nil)
+7
+

Also in conjunctions with (:<):

>>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y
+>>> :t g
+g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a
+>>> g (1:>2:>3:>4:>5:>Nil)
+12
+

data RTree :: Nat -> * -> * where #

Perfect depth binary tree.

  • Only has elements at the leaf of the tree
  • A tree of depth d has 2^d elements.

Bundled Patterns

pattern LR :: a -> RTree 0 a

Leaf of a perfect depth tree

>>> LR 1
+1
+>>> let x = LR 1
+>>> :t x
+x :: Num a => RTree 0 a
+

Can be used as a pattern:

>>> let f (LR a) (LR b) = a + b
+>>> :t f
+f :: Num a => RTree 0 a -> RTree 0 a -> a
+>>> f (LR 1) (LR 2)
+3
+
pattern BR :: RTree d a -> RTree d a -> RTree (d + 1) a

Branch of a perfect depth tree

>>> BR (LR 1) (LR 2)
+<1,2>
+>>> let x = BR (LR 1) (LR 2)
+>>> :t x
+x :: Num a => RTree 1 a
+

Case be used a pattern:

>>> let f (BR (LR a) (LR b)) = LR (a + b)
+>>> :t f
+f :: Num a => RTree 1 a -> RTree 0 a
+>>> f (BR (LR 1) (LR 2))
+3
+
\ No newline at end of file diff --git a/html-test/src/BundledPatterns.hs b/html-test/src/BundledPatterns.hs new file mode 100644 index 00000000..443e64fa --- /dev/null +++ b/html-test/src/BundledPatterns.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators, + ViewPatterns #-} +module BundledPatterns (Vec(Nil,(:>)), RTree (LR,BR)) where + +import GHC.TypeLits +import Prelude hiding (head, tail) +import Unsafe.Coerce + +-- | Fixed size vectors. +-- +-- * Lists with their length encoded in their type +-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and +-- ending at @'length' - 1@. +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + Cons :: a -> Vec n a -> Vec (n + 1) a + +infixr 5 `Cons` + +-- | Add an element to the head of a vector. +-- +-- >>> 3:>4:>5:>Nil +-- <3,4,5> +-- >>> let x = 3:>4:>5:>Nil +-- >>> :t x +-- x :: Num a => Vec 3 a +-- +-- Can be used as a pattern: +-- +-- >>> let f (x :> y :> _) = x + y +-- >>> :t f +-- f :: Num a => Vec ((n + 1) + 1) a -> a +-- >>> f (3:>4:>5:>6:>7:>Nil) +-- 7 +-- +-- Also in conjunctions with (':<'): +-- +-- >>> let g (a :> b :> (_ :< y :< x)) = a + b + x + y +-- >>> :t g +-- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a +-- >>> g (1:>2:>3:>4:>5:>Nil) +-- 12 +pattern (:>) :: a -> Vec n a -> Vec (n + 1) a +pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs)) + where + (:>) x xs = Cons x xs + +infixr 5 :> + +head :: Vec (n + 1) a -> a +head (x `Cons` _) = x + +tail :: Vec (n + 1) a -> Vec n a +tail (_ `Cons` xs) = unsafeCoerce xs + +-- | Perfect depth binary tree. +-- +-- * Only has elements at the leaf of the tree +-- * A tree of depth /d/ has /2^d/ elements. +data RTree :: Nat -> * -> * where + LR_ :: a -> RTree 0 a + BR_ :: RTree d a -> RTree d a -> RTree (d+1) a + +textract :: RTree 0 a -> a +textract (LR_ x) = x +{-# NOINLINE textract #-} + +tsplit :: RTree (d+1) a -> (RTree d a,RTree d a) +tsplit (BR_ l r) = (unsafeCoerce l, unsafeCoerce r) +{-# NOINLINE tsplit #-} + +-- | Leaf of a perfect depth tree +-- +-- >>> LR 1 +-- 1 +-- >>> let x = LR 1 +-- >>> :t x +-- x :: Num a => RTree 0 a +-- +-- Can be used as a pattern: +-- +-- >>> let f (LR a) (LR b) = a + b +-- >>> :t f +-- f :: Num a => RTree 0 a -> RTree 0 a -> a +-- >>> f (LR 1) (LR 2) +-- 3 +pattern LR :: a -> RTree 0 a +pattern LR x <- (textract -> x) + where + LR x = LR_ x + +-- | Branch of a perfect depth tree +-- +-- >>> BR (LR 1) (LR 2) +-- <1,2> +-- >>> let x = BR (LR 1) (LR 2) +-- >>> :t x +-- x :: Num a => RTree 1 a +-- +-- Case be used a pattern: +-- +-- >>> let f (BR (LR a) (LR b)) = LR (a + b) +-- >>> :t f +-- f :: Num a => RTree 1 a -> RTree 0 a +-- >>> f (BR (LR 1) (LR 2)) +-- 3 +pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a +pattern BR l r <- ((\t -> (tsplit t)) -> (l,r)) + where + BR l r = BR_ l r diff --git a/html-test/src/BundledPatterns2.hs b/html-test/src/BundledPatterns2.hs new file mode 100644 index 00000000..5e9a83a7 --- /dev/null +++ b/html-test/src/BundledPatterns2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators, + ViewPatterns #-} +module BundledPatterns2 (Vec((:>), Empty), RTree(..)) where + +import GHC.TypeLits + +import BundledPatterns + +pattern Empty :: Vec 0 a +pattern Empty <- Nil -- cgit v1.2.3