diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,1 @@ +See [`haddock`'s changelog](https://hackage.haskell.org/package/haddock/changelog). diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,23 +1,26 @@ -Copyright 2002-2010, Simon Marlow. All rights reserved. +Copyright (c) 2002-2010, Simon Marlow +All rights reserved. Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +modification, are permitted provided that the following conditions are +met: -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY -EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR -BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN -IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,47 +1,54 @@ +cabal-version: 3.0 name: haddock-api -version: 2.17.4 +version: 2.29.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries -license: BSD3 +license: BSD-2-Clause license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Alex Biehl , Simon Hengel , Mateusz Kowalczyk +maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -cabal-version: >= 1.10 -stability: experimental +tested-with: GHC==9.6.* +extra-source-files: + CHANGES.md + data-dir: resources data-files: + html/quick-jump.min.js + html/haddock-bundle.min.js + html/quick-jump.css html/solarized.css - html/haddock-util.js html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif html/Classic.theme/plus.gif html/Classic.theme/xhaddock.css - html/Ocean.std-theme/hslogo-16.png - html/Ocean.std-theme/minus.gif - html/Ocean.std-theme/ocean.css - html/Ocean.std-theme/plus.gif - html/Ocean.std-theme/synopsis.png + html/Ocean.theme/hslogo-16.png + html/Ocean.theme/minus.gif + html/Ocean.theme/ocean.css + html/Ocean.theme/plus.gif + html/Ocean.theme/synopsis.png + html/Linuwial.std-theme/linuwial.css + html/Linuwial.std-theme/synopsis.png latex/haddock.sty library default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base == 4.9.* - , Cabal == 1.24.* - , ghc == 8.0.* - , ghc-paths == 0.1.* - , haddock-library >= 1.4.2 && < 1.5 - , xhtml == 3000.2.* + build-depends: base ^>= 4.16.0 + , ghc ^>= 9.6 + , ghc-paths ^>= 0.1.0.9 + , haddock-library ^>= 1.11 + , xhtml ^>= 3000.2.2 + , parsec ^>= 3.1.13.0 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version @@ -51,14 +58,26 @@ , containers , deepseq , directory + , exceptions , filepath , ghc-boot + , mtl , transformers hs-source-dirs: src - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + ghc-options: -funbox-strict-fields -O2 + -Wall + -Wcompat + -Wcompat-unqualified-imports + -Widentities + -Wredundant-constraints + -Wnoncanonical-monad-instances + -Wmissing-home-modules + -Wincomplete-uni-patterns + -Wincomplete-record-updates + exposed-modules: Documentation.Haddock @@ -68,15 +87,20 @@ Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances + Haddock.Interface.Json Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Interface.Specialize Haddock.Parser Haddock.Utils + Haddock.Utils.Json + Haddock.Utils.Json.Types + Haddock.Utils.Json.Parser Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta Haddock.Backends.Xhtml.Names Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types @@ -85,7 +109,6 @@ Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker - Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Renderer Haddock.Backends.Hyperlinker.Types @@ -101,6 +124,9 @@ Haddock.Convert Paths_haddock_api + autogen-modules: + Paths_haddock_api + test-suite spec type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -112,14 +138,74 @@ , src other-modules: + Haddock + Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Utils + Haddock.Backends.LaTeX + Haddock.Backends.Xhtml + Haddock.Backends.Xhtml.Decl + Haddock.Backends.Xhtml.DocMarkup + Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta + Haddock.Backends.Xhtml.Names + Haddock.Backends.Xhtml.Themes + Haddock.Backends.Xhtml.Types + Haddock.Backends.Xhtml.Utils + Haddock.Convert + Haddock.Doc + Haddock.GhcUtils + Haddock.Interface + Haddock.Interface.AttachInstances + Haddock.Interface.Create + Haddock.Interface.Json + Haddock.Interface.LexParseRn + Haddock.Interface.ParseModuleHeader + Haddock.Interface.Rename + Haddock.Interface.Specialize + Haddock.InterfaceFile + Haddock.ModuleTree + Haddock.Options + Haddock.Parser + Haddock.Syb + Haddock.Types + Haddock.Utils + Haddock.Utils.Json + Haddock.Utils.Json.Types + Haddock.Utils.Json.Parser + Haddock.Version + Paths_haddock_api Haddock.Backends.Hyperlinker.ParserSpec + Haddock.Backends.Hyperlinker.Parser + Haddock.Backends.Hyperlinker.Types - build-depends: - base - , containers - , ghc - , hspec - , QuickCheck == 2.* + build-depends: ghc ^>= 9.6 + , ghc-paths ^>= 0.1.0.12 + , haddock-library ^>= 1.11 + , xhtml ^>= 3000.2.2 + , hspec ^>= 2.9 + , parsec ^>= 3.1.13.0 + , QuickCheck >= 2.11 && ^>= 2.14 + + -- Versions for the dependencies below are transitively pinned by + -- the non-reinstallable `ghc` package and hence need no version + -- bounds + build-depends: base + , array + , bytestring + , containers + , deepseq + , directory + , exceptions + , filepath + , ghc-boot + , ghc-boot-th + , mtl + , transformers + + build-tool-depends: + hspec-discover:hspec-discover ^>= 2.9 source-repository head type: git diff --git a/resources/html/Classic.theme/xhaddock.css b/resources/html/Classic.theme/xhaddock.css --- a/resources/html/Classic.theme/xhaddock.css +++ b/resources/html/Classic.theme/xhaddock.css @@ -153,6 +153,7 @@ text-align: center; right: 0; padding: 2px 2px 1px; + top: 1.25em; } #style-menu li { @@ -285,6 +286,7 @@ padding: 0 8px 2px 5px; margin-right: -3px; background-color: #f0f0f0; + -moz-user-select: none; } div.subs { @@ -391,6 +393,20 @@ } +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} #footer { background-color: #000099; diff --git a/resources/html/Linuwial.std-theme/linuwial.css b/resources/html/Linuwial.std-theme/linuwial.css new file mode 100644 --- /dev/null +++ b/resources/html/Linuwial.std-theme/linuwial.css @@ -0,0 +1,881 @@ +/* @group Fundamentals */ + +* { margin: 0; padding: 0 } + +/* Is this portable? */ +html { + background-color: white; + width: 100%; + height: 100%; +} + +body { + background: #fefefe; + color: #111; + text-align: left; + min-height: 100vh; + position: relative; + -webkit-text-size-adjust: 100%; + -webkit-font-feature-settings: "kern" 1, "liga" 0; + -moz-font-feature-settings: "kern" 1, "liga" 0; + -o-font-feature-settings: "kern" 1, "liga" 0; + font-feature-settings: "kern" 1, "liga" 0; + letter-spacing: 0.0015rem; +} + +#content a { + overflow-wrap: break-word; +} + +p { + margin: 0.8em 0; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +dl { + margin: 0.8em 0; +} + +dt { + font-weight: bold; +} +dd { + margin-left: 2em; +} + +a { text-decoration: none; } +a[href]:link { color: #9E358F; } +a[href]:visited {color: #6F5F9C; } +a[href]:hover { text-decoration:underline; } + +a[href].def:link, a[href].def:visited { color: rgba(69, 59, 97, 0.8); } +a[href].def:hover { color: rgb(78, 98, 114); } + +/* @end */ + +/* @group Show and hide with JS */ + +body.js-enabled .hide-when-js-enabled { + display: none; +} + +/* @end */ + + +/* @group responsive */ + +#package-header .caption { + margin: 0px 1em 0 2em; +} + +@media only screen and (min-width: 1280px) { + #content { + width: 63vw; + max-width: 1450px; + } + + #table-of-contents { + position: fixed; + max-width: 10vw; + top: 10.2em; + left: 2em; + bottom: 1em; + overflow-y: auto; + } + + #synopsis { + display: block; + position: fixed; + float: left; + top: 5em; + bottom: 1em; + right: 0; + max-width: 65vw; + overflow-y: auto; + /* Ensure that synopsis covers everything (including MathJAX markup) */ + z-index: 1; + } + + #synopsis .show { + border: 1px solid #5E5184; + padding: 0.7em; + max-height: 65vh; + } + +} + +@media only screen and (max-width: 1279px) { + #content { + width: 80vw; + } + + #synopsis { + display: block; + padding: 0; + position: relative; + margin: 0; + width: 100%; + } +} + +@media only screen and (max-width: 999px) { + #content { + width: 93vw; + } +} + + +/* menu for wider screens + + Display the package name at the left and the menu links at the right, + inline with each other: + The package name Source . Contents . Index +*/ +@media only screen and (min-width: 1000px) { + #package-header { + text-align: left; + white-space: nowrap; + height: 40px; + padding: 4px 1.5em 0px 1.5em; + overflow: visible; + + display: flex; + justify-content: space-between; + align-items: center; + } + + #package-header .caption { + display: inline-block; + margin: 0; + } + + #package-header ul.links { + margin: 0; + display: inline-table; + } + + #package-header .caption + ul.links { + margin-left: 1em; + } +} + +/* menu for smaller screens + +Display the package name on top of the menu links and center both elements: + The package name + Source . Contents . Index +*/ +@media only screen and (max-width: 999px) { + #package-header { + text-align: center; + padding: 6px 0 4px 0; + overflow: hidden; + } + + #package-header ul.links { + display: block; + text-align: center; + margin: 0; + + /* Hide scrollbar but allow scrolling menu links horizontally */ + white-space: nowrap; + overflow-x: auto; + overflow-y: hidden; + margin-bottom: -17px; + height: 50px; + } + + #package-header .caption { + display: block; + margin: 4px 0; + text-align: center; + } + + #package-header ul.links::-webkit-scrollbar { + display: none; + } + + #package-header ul.links li:first-of-type { + padding-left: 1em; + } + + #package-header ul.links li:last-of-type { + /* + The last link of the menu should offer the same distance to the right + as the #package-header enforces at the left. + */ + padding-right: 1em; + } + + #package-header .caption + ul.links { + padding-top: 9px; + } + + #module-header table.info { + float: none; + top: 0; + margin: 0 auto; + overflow: hidden; + max-width: 80vw; + } +} + +/* @end */ + + +/* @group Fonts & Sizes */ + +/* Basic technique & IE workarounds from YUI 3 + For reasons, see: + http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css + */ + + body, button { + font: 400 14px/1.4 'PT Sans', + /* Fallback Font Stack */ + -apple-system, + BlinkMacSystemFont, + 'Segoe UI', + Roboto, + Oxygen-Sans, + Cantarell, + 'Helvetica Neue', + sans-serif; + *font-size: medium; /* for IE */ + *font:x-small; /* for IE in quirks mode */ + } + +h1 { font-size: 146.5%; /* 19pt */ } +h2 { font-size: 131%; /* 17pt */ } +h3 { font-size: 116%; /* 15pt */ } +h4 { font-size: 100%; /* 13pt */ } +h5 { font-size: 100%; /* 13pt */ } + +table { + font-size:inherit; + font:100%; +} + +pre, code, kbd, samp, tt, .src { + font-family:monospace; +} + +.links, .link { + font-size: 85%; /* 11pt */ +} + +#module-header .caption { + font-size: 182%; /* 24pt */ +} + +#module-header .caption sup { + font-size: 80%; + font-weight: normal; +} + +#package-header #page-menu a:link, #package-header #page-menu a:visited { color: white; } + + +.info { + font-size: 90%; +} + + +/* @end */ + +/* @group Common */ + +.caption, h1, h2, h3, h4, h5, h6, summary { + font-weight: bold; + color: #5E5184; + margin: 1.5em 0 1em 0; +} + + +* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { + margin-top: 2em; +} + +h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { + margin-top: inherit; +} + +ul li + li { + margin-top: 0.2rem; +} + +ul + p { + margin-top: 0.93em; +} + +p + ul { + margin-top: 0.5em; +} + +p { + margin-top: 0.7rem; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +ul.links { + list-style: none; + text-align: left; + font-size: 0.95em; +} + +#package-header ul.links, #package-header ul.links button { + font-size: 1rem; +} + +ul.links li { + display: inline; + white-space: nowrap; + padding: 0; +} + +ul.links > li + li:before { + content: '\00B7'; +} + +ul.links li a { + padding: 0.2em 0.5em; +} + +.hide { display: none; } +.show { display: inherit; } +.clear { clear: both; } + +.collapser:before, .expander:before, .noexpander:before { + font-size: 1.2em; + color: #9C5791; + display: inline-block; + padding-right: 7px; +} + +.collapser:before { + content: '▿'; +} +.expander:before { + content: '▹'; +} +.noexpander:before { + content: '▿'; + visibility: hidden; +} + +.collapser, .expander { + cursor: pointer; +} + +.instance.collapser, .instance.expander { + margin-left: 0px; + background-position: left center; + min-width: 9px; + min-height: 9px; +} + +summary { + cursor: pointer; + outline: none; +} + +pre { + padding: 0.5rem 1rem; + margin: 1em 0 0 0; + background-color: #f7f7f7; + overflow: auto; + border: 1px solid #ddd; + border-radius: 0.3em; +} + +pre + p { + margin-top: 1em; +} + +pre + pre { + margin-top: 0.5em; +} + +blockquote { + border-left: 3px solid #c7a5d3; + background-color: #eee4f1; + margin: 0.5em; + padding: 0.0005em 0.3em 0.5em 0.5em; +} + +.src { + background: #f2f2f2; + padding: 0.2em 0.5em; +} + +.keyword { font-weight: normal; } +.def { font-weight: bold; } + +@media print { + #footer { display: none; } +} + +/* @end */ + +/* @group Page Structure */ + +#content { + margin: 3em auto 6em auto; + padding: 0; +} + +#package-header { + background: #5E5184; + border-bottom: 5px solid rgba(69, 59, 97, 0.5); + color: #ddd; + position: relative; + font-size: 1.2em; + text-align: left; + margin: 0 auto; +} + +#package-header .caption { + color: white; + font-style: normal; + font-size: 1rem; + font-weight: bold; +} + +#module-header .caption { + font-weight: bold; + border-bottom: 1px solid #ddd; +} + +table.info { + float: right; + padding: 0.5em 1em; + border: 1px solid #ddd; + color: rgb(78,98,114); + background-color: #fff; + max-width: 60%; + border-spacing: 0; + position: relative; + top: -0.78em; + margin: 0 0 0 2em; +} + +.info th { + padding: 0 1em 0 0; + text-align: right; +} + +#style-menu li { + display: block; + border-style: none; + list-style-type: none; +} + +#footer { + background: #ededed; + border-top: 1px solid #aaa; + padding: 0.5em 0; + color: #222; + text-align: center; + width: 100%; + height: 3em; + margin-top: 3em; + position: relative; + clear: both; +} + +/* @end */ + +/* @group Front Matter */ + +#synopsis .caption, +#contents-list .caption { + font-size: 1rem; +} + +#synopsis, #table-of-contents { + font-size: 16px; +} + +#contents-list { + background: #f4f4f4; + padding: 1em; + margin: 0; +} + +#contents-list .caption { + text-align: left; + margin: 0; +} + +#contents-list ul { + list-style: none; + margin: 0; + margin-top: 10px; + font-size: 14px; +} + +#contents-list ul ul { + margin-left: 1.5em; +} + +#description .caption { + display: none; +} + +#synopsis summary { + display: block; + float: right; + width: 29px; + color: rgba(255,255,255,0); + height: 110px; + margin: 0; + font-size: 1px; + padding: 0; + background: url(synopsis.png) no-repeat 0px -8px; +} + +#synopsis details[open] > summary { + background: url(synopsis.png) no-repeat -75px -8px; +} + +#synopsis details:not([open]) > ul { + visibility: hidden; +} + +#synopsis ul { + height: 100%; + overflow: auto; + padding: 0.5em; + margin: 0; +} + +#synopsis ul ul { + overflow: hidden; +} + +#synopsis ul, +#synopsis ul li.src { + background-color: rgb(250,247,224); + white-space: nowrap; + list-style: none; + margin-left: 0; +} + +#interface td.src { + white-space: nowrap; +} + +/* @end */ + +/* @group Main Content */ + +#interface div.top + div.top { + margin-top: 1.5em; +} + +#interface p + div.top, +#interface h1 + div.top, +#interface h2 + div.top, +#interface h3 + div.top, +#interface h4 + div.top, +#interface h5 + div.top { + margin-top: 1em; +} +#interface .src .selflink, +#interface .src .link { + float: right; + color: #888; + padding: 0 7px; + -moz-user-select: none; + font-weight: bold; + line-height: 30px; +} +#interface .src .selflink { + margin: 0 -0.5em 0 0.5em; +} + +#interface span.fixity { + color: #919191; + border-left: 1px solid #919191; + padding: 0.2em 0.5em 0.2em 0.5em; + margin: 0 -1em 0 1em; +} + +#interface span.rightedge { + border-left: 1px solid #919191; + padding: 0.2em 0 0.2em 0; + margin: 0 0 0 1em; +} + +#interface table { border-spacing: 2px; } +#interface td { + vertical-align: top; + padding-left: 0.5em; +} + +#interface td.doc p { + margin: 0; +} +#interface td.doc p + p { + margin-top: 0.8em; +} + +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} + +.clearfix:after { + clear: both; + content: " "; + display: block; + height: 0; + visibility: hidden; +} + +.subs, .top > .doc, .subs > .doc { + padding-left: 1em; + border-left: 1px solid gainsboro; + margin-bottom: 1em; +} + +.top .subs { + margin-bottom: 0.6em; +} + +.subs.fields ul { + list-style: none; + display: table; + margin: 0; +} + +.subs.fields ul li { + display: table-row; +} + +.subs ul li dfn { + display: table-cell; + font-style: normal; + font-weight: bold; + margin: 1px 0; + white-space: nowrap; +} + +.subs ul li > .doc { + display: table-cell; + padding-left: 0.5em; + margin-bottom: 0.5em; +} + +.subs ul li > .doc p { + margin: 0; +} + +.subs .subs p.src { + border: none; + background-color: #f8f8f8; +} + +.subs .subs .caption { + margin-top: 1em ; + margin-bottom: 0px; +} + +.subs p.caption { + margin-top: 0; +} + +.subs .subs .caption + .src { + margin: 0px; + margin-top: 8px; +} + +.subs .subs .src + .src { + margin: 7px 0 0 0; +} + +/* Render short-style data instances */ +.inst ul { + height: 100%; + padding: 0.5em; + margin: 0; +} + +.inst, .inst li { + list-style: none; + margin-left: 1em; +} + +/* Workaround for bug in Firefox (issue #384) */ +.inst-left { + float: left; +} + +.top p.src { + border-bottom: 3px solid #e5e5e5; + line-height: 2rem; + margin-bottom: 1em; +} + +.warning { + color: red; +} + +.arguments { + margin-top: -0.4em; +} +.arguments .caption { + display: none; +} + +.fields { padding-left: 1em; } + +.fields .caption { display: none; } + +.fields p { margin: 0 0; } + +/* this seems bulky to me +.methods, .constructors { + background: #f8f8f8; + border: 1px solid #eee; +} +*/ + +/* @end */ + +/* @group Auxillary Pages */ + + +.extension-list { + list-style-type: none; + margin-left: 0; +} + +#mini { + margin: 0 auto; + padding: 0 1em 1em; +} + +#mini > * { + font-size: 93%; /* 12pt */ +} + +#mini #module-list .caption, +#mini #module-header .caption { + font-size: 125%; /* 15pt */ +} + +#mini #interface h1, +#mini #interface h2, +#mini #interface h3, +#mini #interface h4 { + font-size: 109%; /* 13pt */ + margin: 1em 0 0; +} + +#mini #interface .top, +#mini #interface .src { + margin: 0; +} + +#mini #module-list ul { + list-style: none; + margin: 0; +} + +#alphabet ul { + list-style: none; + padding: 0; + margin: 0.5em 0 0; + text-align: center; +} + +#alphabet li { + display: inline; + margin: 0 0.25em; +} + +#alphabet a { + font-weight: bold; +} + +#index .caption, +#module-list .caption { font-size: 131%; /* 17pt */ } + +#index table { + margin-left: 2em; +} + +#index .src { + font-weight: bold; +} +#index .alt { + font-size: 77%; /* 10pt */ + font-style: italic; + padding-left: 2em; +} + +#index td + td { + padding-left: 1em; +} + +#module-list ul { + list-style: none; + margin: 0 0 0 2em; +} + +#module-list li { + clear: right; +} + +#module-list span.collapser, +#module-list span.expander { + background-position: 0 0.3em; +} + +#module-list .package { + float: right; +} + +:target { + background: -webkit-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -moz-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -o-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -ms-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: linear-gradient(to bottom, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); +} + +:target:hover { + background: -webkit-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -moz-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -o-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -ms-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: linear-gradient(to bottom, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); +} + +/* @end */ + +/* @group Dropdown menus */ + +#preferences-menu, #style-menu { + width: 25em; + overflow-y: auto; +} + +/* @end */ diff --git a/resources/html/Linuwial.std-theme/synopsis.png b/resources/html/Linuwial.std-theme/synopsis.png new file mode 100644 Binary files /dev/null and b/resources/html/Linuwial.std-theme/synopsis.png differ diff --git a/resources/html/Ocean.std-theme/hslogo-16.png b/resources/html/Ocean.std-theme/hslogo-16.png deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/hslogo-16.png and /dev/null differ diff --git a/resources/html/Ocean.std-theme/minus.gif b/resources/html/Ocean.std-theme/minus.gif deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/minus.gif and /dev/null differ diff --git a/resources/html/Ocean.std-theme/ocean.css b/resources/html/Ocean.std-theme/ocean.css deleted file mode 100644 --- a/resources/html/Ocean.std-theme/ocean.css +++ /dev/null @@ -1,612 +0,0 @@ -/* @group Fundamentals */ - -* { margin: 0; padding: 0 } - -/* Is this portable? */ -html { - background-color: white; - width: 100%; - height: 100%; -} - -body { - background: white; - color: black; - text-align: left; - min-height: 100%; - position: relative; -} - -p { - margin: 0.8em 0; -} - -ul, ol { - margin: 0.8em 0 0.8em 2em; -} - -dl { - margin: 0.8em 0; -} - -dt { - font-weight: bold; -} -dd { - margin-left: 2em; -} - -a { text-decoration: none; } -a[href]:link { color: rgb(196,69,29); } -a[href]:visited { color: rgb(171,105,84); } -a[href]:hover { text-decoration:underline; } - -a[href].def:link, a[href].def:visited { color: black; } -a[href].def:hover { color: rgb(78, 98, 114); } - -/* @end */ - -/* @group Fonts & Sizes */ - -/* Basic technique & IE workarounds from YUI 3 - For reasons, see: - http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css - */ - -body { - font:13px/1.4 sans-serif; - *font-size:small; /* for IE */ - *font:x-small; /* for IE in quirks mode */ -} - -h1 { font-size: 146.5%; /* 19pt */ } -h2 { font-size: 131%; /* 17pt */ } -h3 { font-size: 116%; /* 15pt */ } -h4 { font-size: 100%; /* 13pt */ } -h5 { font-size: 100%; /* 13pt */ } - -select, input, button, textarea { - font:99% sans-serif; -} - -table { - font-size:inherit; - font:100%; -} - -pre, code, kbd, samp, tt, .src { - font-family:monospace; - *font-size:108%; - line-height: 124%; -} - -.links, .link { - font-size: 85%; /* 11pt */ -} - -#module-header .caption { - font-size: 182%; /* 24pt */ -} - -.info { - font-size: 85%; /* 11pt */ -} - -#table-of-contents, #synopsis { - /* font-size: 85%; /* 11pt */ -} - - -/* @end */ - -/* @group Common */ - -.caption, h1, h2, h3, h4, h5, h6 { - font-weight: bold; - color: rgb(78,98,114); - margin: 0.8em 0 0.4em; -} - -* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { - margin-top: 2em; -} - -h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { - margin-top: inherit; -} - -ul.links { - list-style: none; - text-align: left; - float: right; - display: inline-table; - margin: 0 0 0 1em; -} - -ul.links li { - display: inline; - border-left: 1px solid #d5d5d5; - white-space: nowrap; - padding: 0; -} - -ul.links li a { - padding: 0.2em 0.5em; -} - -.hide { display: none; } -.show { display: inherit; } -.clear { clear: both; } - -.collapser { - background-image: url(minus.gif); - background-repeat: no-repeat; -} -.expander { - background-image: url(plus.gif); - background-repeat: no-repeat; -} -.collapser, .expander { - padding-left: 14px; - margin-left: -14px; - cursor: pointer; -} -p.caption.collapser, -p.caption.expander { - background-position: 0 0.4em; -} - -.instance.collapser, .instance.expander { - margin-left: 0px; - background-position: left center; - min-width: 9px; - min-height: 9px; -} - - -pre { - padding: 0.25em; - margin: 0.8em 0; - background: rgb(229,237,244); - overflow: auto; - border-bottom: 0.25em solid white; - /* white border adds some space below the box to compensate - for visual extra space that paragraphs have between baseline - and the bounding box */ -} - -.src { - background: #f0f0f0; - padding: 0.2em 0.5em; -} - -.keyword { font-weight: normal; } -.def { font-weight: bold; } - -@media print { - #footer { display: none; } -} - -/* @end */ - -/* @group Page Structure */ - -#content { - margin: 0 auto; - padding: 0 2em 6em; -} - -#package-header { - background: rgb(41,56,69); - border-top: 5px solid rgb(78,98,114); - color: #ddd; - padding: 0.2em; - position: relative; - text-align: left; -} - -#package-header .caption { - background: url(hslogo-16.png) no-repeat 0em; - color: white; - margin: 0 2em; - font-weight: normal; - font-style: normal; - padding-left: 2em; -} - -#package-header a:link, #package-header a:visited { color: white; } -#package-header a:hover { background: rgb(78,98,114); } - -#module-header .caption { - color: rgb(78,98,114); - font-weight: bold; - border-bottom: 1px solid #ddd; -} - -table.info { - float: right; - padding: 0.5em 1em; - border: 1px solid #ddd; - color: rgb(78,98,114); - background-color: #fff; - max-width: 40%; - border-spacing: 0; - position: relative; - top: -0.5em; - margin: 0 0 0 2em; -} - -.info th { - padding: 0 1em 0 0; -} - -div#style-menu-holder { - position: relative; - z-index: 2; - display: inline; -} - -#style-menu { - position: absolute; - z-index: 1; - overflow: visible; - background: #374c5e; - margin: 0; - text-align: center; - right: 0; - padding: 0; - top: 1.25em; -} - -#style-menu li { - display: list-item; - border-style: none; - margin: 0; - padding: 0; - color: #000; - list-style-type: none; -} - -#style-menu li + li { - border-top: 1px solid #919191; -} - -#style-menu a { - width: 6em; - padding: 3px; - display: block; -} - -#footer { - background: #ddd; - border-top: 1px solid #aaa; - padding: 0.5em 0; - color: #666; - text-align: center; - position: absolute; - bottom: 0; - width: 100%; - height: 3em; -} - -/* @end */ - -/* @group Front Matter */ - -#table-of-contents { - float: right; - clear: right; - background: #faf9dc; - border: 1px solid #d8d7ad; - padding: 0.5em 1em; - max-width: 20em; - margin: 0.5em 0 1em 1em; -} - -#table-of-contents .caption { - text-align: center; - margin: 0; -} - -#table-of-contents ul { - list-style: none; - margin: 0; -} - -#table-of-contents ul ul { - margin-left: 2em; -} - -#description .caption { - display: none; -} - -#synopsis { - display: none; -} - -.no-frame #synopsis { - display: block; - position: fixed; - right: 0; - height: 80%; - top: 10%; - padding: 0; - max-width: 75%; - /* Ensure that synopsis covers everything (including MathJAX markup) */ - z-index: 1; -} - -#synopsis .caption { - float: left; - width: 29px; - color: rgba(255,255,255,0); - height: 110px; - margin: 0; - font-size: 1px; - padding: 0; -} - -#synopsis p.caption.collapser { - background: url(synopsis.png) no-repeat -64px -8px; -} - -#synopsis p.caption.expander { - background: url(synopsis.png) no-repeat 0px -8px; -} - -#synopsis ul { - height: 100%; - overflow: auto; - padding: 0.5em; - margin: 0; -} - -#synopsis ul ul { - overflow: hidden; -} - -#synopsis ul, -#synopsis ul li.src { - background-color: #faf9dc; - white-space: nowrap; - list-style: none; - margin-left: 0; -} - -/* @end */ - -/* @group Main Content */ - -#interface div.top { margin: 2em 0; } -#interface h1 + div.top, -#interface h2 + div.top, -#interface h3 + div.top, -#interface h4 + div.top, -#interface h5 + div.top { - margin-top: 1em; -} -#interface .src .selflink, -#interface .src .link { - float: right; - color: #919191; - background: #f0f0f0; - padding: 0 0.5em 0.2em; - margin: 0 -0.5em 0 0; -} -#interface .src .selflink { - border-left: 1px solid #919191; - margin: 0 -0.5em 0 0.5em; -} - -#interface span.fixity { - color: #919191; - border-left: 1px solid #919191; - padding: 0.2em 0.5em 0.2em 0.5em; - margin: 0 -1em 0 1em; -} - -#interface span.rightedge { - border-left: 1px solid #919191; - padding: 0.2em 0 0.2em 0; - margin: 0 0 0 1em; -} - -#interface table { border-spacing: 2px; } -#interface td { - vertical-align: top; - padding-left: 0.5em; -} -#interface td.src { - white-space: nowrap; -} -#interface td.doc p { - margin: 0; -} -#interface td.doc p + p { - margin-top: 0.8em; -} - -.clearfix:after { - clear: both; - content: " "; - display: block; - height: 0; - visibility: hidden; -} - -.subs ul { - list-style: none; - display: table; - margin: 0; -} - -.subs ul li { - display: table-row; -} - -.subs ul li dfn { - display: table-cell; - font-style: normal; - font-weight: bold; - margin: 1px 0; - white-space: nowrap; -} - -.subs ul li > .doc { - display: table-cell; - padding-left: 0.5em; - margin-bottom: 0.5em; -} - -.subs ul li > .doc p { - margin: 0; -} - -/* Render short-style data instances */ -.inst ul { - height: 100%; - padding: 0.5em; - margin: 0; -} - -.inst, .inst li { - list-style: none; - margin-left: 1em; -} - -/* Workaround for bug in Firefox (issue #384) */ -.inst-left { - float: left; -} - -.top p.src { - border-top: 1px solid #ccc; -} - -.subs, .doc { - /* use this selector for one level of indent */ - padding-left: 2em; -} - -.warning { - color: red; -} - -.arguments { - margin-top: -0.4em; -} -.arguments .caption { - display: none; -} - -.fields { padding-left: 1em; } - -.fields .caption { display: none; } - -.fields p { margin: 0 0; } - -/* this seems bulky to me -.methods, .constructors { - background: #f8f8f8; - border: 1px solid #eee; -} -*/ - -/* @end */ - -/* @group Auxillary Pages */ - - -.extension-list { - list-style-type: none; - margin-left: 0; -} - -#mini { - margin: 0 auto; - padding: 0 1em 1em; -} - -#mini > * { - font-size: 93%; /* 12pt */ -} - -#mini #module-list .caption, -#mini #module-header .caption { - font-size: 125%; /* 15pt */ -} - -#mini #interface h1, -#mini #interface h2, -#mini #interface h3, -#mini #interface h4 { - font-size: 109%; /* 13pt */ - margin: 1em 0 0; -} - -#mini #interface .top, -#mini #interface .src { - margin: 0; -} - -#mini #module-list ul { - list-style: none; - margin: 0; -} - -#alphabet ul { - list-style: none; - padding: 0; - margin: 0.5em 0 0; - text-align: center; -} - -#alphabet li { - display: inline; - margin: 0 0.25em; -} - -#alphabet a { - font-weight: bold; -} - -#index .caption, -#module-list .caption { font-size: 131%; /* 17pt */ } - -#index table { - margin-left: 2em; -} - -#index .src { - font-weight: bold; -} -#index .alt { - font-size: 77%; /* 10pt */ - font-style: italic; - padding-left: 2em; -} - -#index td + td { - padding-left: 1em; -} - -#module-list ul { - list-style: none; - margin: 0 0 0 2em; -} - -#module-list li { - clear: right; -} - -#module-list span.collapser, -#module-list span.expander { - background-position: 0 0.3em; -} - -#module-list .package { - float: right; -} - -/* @end */ diff --git a/resources/html/Ocean.std-theme/plus.gif b/resources/html/Ocean.std-theme/plus.gif deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/plus.gif and /dev/null differ diff --git a/resources/html/Ocean.std-theme/synopsis.png b/resources/html/Ocean.std-theme/synopsis.png deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/synopsis.png and /dev/null differ diff --git a/resources/html/Ocean.theme/hslogo-16.png b/resources/html/Ocean.theme/hslogo-16.png new file mode 100644 Binary files /dev/null and b/resources/html/Ocean.theme/hslogo-16.png differ diff --git a/resources/html/Ocean.theme/minus.gif b/resources/html/Ocean.theme/minus.gif new file mode 100644 Binary files /dev/null and b/resources/html/Ocean.theme/minus.gif differ diff --git a/resources/html/Ocean.theme/ocean.css b/resources/html/Ocean.theme/ocean.css new file mode 100644 --- /dev/null +++ b/resources/html/Ocean.theme/ocean.css @@ -0,0 +1,647 @@ +/* @group Fundamentals */ + +* { margin: 0; padding: 0 } + +/* Is this portable? */ +html { + background-color: white; + width: 100%; + height: 100%; +} + +body { + background: white; + color: black; + text-align: left; + min-height: 100%; + position: relative; +} + +p { + margin: 0.8em 0; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +dl { + margin: 0.8em 0; +} + +dt { + font-weight: bold; +} +dd { + margin-left: 2em; +} + +a { text-decoration: none; } +a[href]:link { color: rgb(196,69,29); } +a[href]:visited { color: rgb(171,105,84); } +a[href]:hover { text-decoration:underline; } + +a[href].def:link, a[href].def:visited { color: black; } +a[href].def:hover { color: rgb(78, 98, 114); } + +/* @end */ + +/* @group Show and hide with JS */ + +body.js-enabled .hide-when-js-enabled { + display: none; +} + +/* @end */ + +/* @group Fonts & Sizes */ + +/* Basic technique & IE workarounds from YUI 3 + For reasons, see: + http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css + */ + +body { + font:13px/1.4 sans-serif; + *font-size:small; /* for IE */ + *font:x-small; /* for IE in quirks mode */ +} + +h1 { font-size: 146.5%; /* 19pt */ } +h2 { font-size: 131%; /* 17pt */ } +h3 { font-size: 116%; /* 15pt */ } +h4 { font-size: 100%; /* 13pt */ } +h5 { font-size: 100%; /* 13pt */ } + +select, input, button, textarea { + font:99% sans-serif; +} + +table { + font-size:inherit; + font:100%; +} + +pre, code, kbd, samp, tt, .src { + font-family:monospace; + *font-size:108%; + line-height: 124%; +} + +.links, .link { + font-size: 85%; /* 11pt */ +} + +#module-header .caption { + font-size: 182%; /* 24pt */ +} + +#module-header .caption sup { + font-size: 70%; + font-weight: normal; +} + +.info { + font-size: 85%; /* 11pt */ +} + +#table-of-contents, #synopsis { + /* font-size: 85%; /* 11pt */ +} + + +/* @end */ + +/* @group Common */ + +.caption, h1, h2, h3, h4, h5, h6, summary { + font-weight: bold; + color: rgb(78,98,114); + margin: 0.8em 0 0.4em; +} + +* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { + margin-top: 2em; +} + +h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { + margin-top: inherit; +} + +ul.links { + list-style: none; + text-align: left; + float: right; + display: inline-table; + margin: 0 0 0 1em; +} + +ul.links li { + display: inline; + border-left: 1px solid #d5d5d5; + white-space: nowrap; + padding: 0; +} + +ul.links li a { + padding: 0.2em 0.5em; +} + +.hide { display: none; } +.show { display: inherit; } +.clear { clear: both; } + +.collapser { + background-image: url(minus.gif); + background-repeat: no-repeat; +} +.expander { + background-image: url(plus.gif); + background-repeat: no-repeat; +} +.collapser, .expander { + padding-left: 14px; + margin-left: -14px; + cursor: pointer; +} +p.caption.collapser, +p.caption.expander { + background-position: 0 0.4em; +} + +.instance.collapser, .instance.expander { + margin-left: 0px; + background-position: left center; + min-width: 9px; + min-height: 9px; +} + +summary { + cursor: pointer; + outline: none; + list-style-image: url(plus.gif); + list-style-position: outside; +} + +details[open] > summary { + list-style-image: url(minus.gif); +} + +pre { + padding: 0.25em; + margin: 0.8em 0; + background: rgb(229,237,244); + overflow: auto; + border-bottom: 0.25em solid white; + /* white border adds some space below the box to compensate + for visual extra space that paragraphs have between baseline + and the bounding box */ +} + +.src { + background: #f0f0f0; + padding: 0.2em 0.5em; +} + +.keyword { font-weight: normal; } +.def { font-weight: bold; } + +@media print { + #footer { display: none; } +} + +/* @end */ + +/* @group Page Structure */ + +#content { + margin: 0 auto; + padding: 0 2em 6em; +} + +#package-header { + background: rgb(41,56,69); + border-top: 5px solid rgb(78,98,114); + color: #ddd; + padding: 0.2em; + position: relative; + text-align: left; +} + +#package-header .caption { + background: url(hslogo-16.png) no-repeat 0em; + color: white; + margin: 0 2em; + font-weight: normal; + font-style: normal; + padding-left: 2em; +} + +#package-header a:link, #package-header a:visited { color: white; } +#package-header a:hover { background: rgb(78,98,114); } + +#module-header .caption { + color: rgb(78,98,114); + font-weight: bold; + border-bottom: 1px solid #ddd; +} + +table.info { + float: right; + padding: 0.5em 1em; + border: 1px solid #ddd; + color: rgb(78,98,114); + background-color: #fff; + max-width: 40%; + border-spacing: 0; + position: relative; + top: -0.5em; + margin: 0 0 0 2em; +} + +.info th { + padding: 0 1em 0 0; +} + +div#style-menu-holder { + position: relative; + z-index: 2; + display: inline; +} + +#style-menu { + position: absolute; + z-index: 1; + overflow: visible; + background: #374c5e; + margin: 0; + text-align: center; + right: 0; + padding: 0; + top: 1.25em; +} + +#style-menu li { + display: list-item; + border-style: none; + margin: 0; + padding: 0; + color: #000; + list-style-type: none; +} + +#style-menu li + li { + border-top: 1px solid #919191; +} + +#style-menu a { + width: 6em; + padding: 3px; + display: block; +} + +#footer { + background: #ddd; + border-top: 1px solid #aaa; + padding: 0.5em 0; + color: #666; + text-align: center; + position: absolute; + bottom: 0; + width: 100%; + height: 3em; +} + +/* @end */ + +/* @group Front Matter */ + +#table-of-contents { + float: right; + clear: right; + background: #faf9dc; + border: 1px solid #d8d7ad; + padding: 0.5em 1em; + max-width: 20em; + margin: 0.5em 0 1em 1em; +} + +#table-of-contents .caption { + text-align: center; + margin: 0; +} + +#table-of-contents ul { + list-style: none; + margin: 0; +} + +#table-of-contents ul ul { + margin-left: 2em; +} + +#description .caption { + display: none; +} + +#synopsis { + display: block; + position: fixed; + right: 0; + height: 80%; + top: 10%; + padding: 0; + max-width: 75%; + /* Ensure that synopsis covers everything (including MathJAX markup) */ + z-index: 1; +} + +#synopsis summary { + display: block; + float: left; + width: 29px; + color: rgba(255,255,255,0); + height: 110px; + margin: 0; + font-size: 1px; + padding: 0; + background: url(synopsis.png) no-repeat 0px -8px; +} + +#synopsis details[open] > summary { + background: url(synopsis.png) no-repeat -64px -8px; +} + +#synopsis ul { + height: 100%; + overflow: auto; + padding: 0.5em; + margin: 0; +} + +#synopsis ul ul { + overflow: hidden; +} + +#synopsis ul, +#synopsis ul li.src { + background-color: #faf9dc; + white-space: nowrap; + list-style: none; + margin-left: 0; +} + +/* @end */ + +/* @group Main Content */ + +#interface div.top { margin: 2em 0; } +#interface h1 + div.top, +#interface h2 + div.top, +#interface h3 + div.top, +#interface h4 + div.top, +#interface h5 + div.top { + margin-top: 1em; +} +#interface .src .selflink, +#interface .src .link { + float: right; + color: #919191; + background: #f0f0f0; + padding: 0 0.5em 0.2em; + margin: 0 -0.5em 0 0; + -moz-user-select: none; +} +#interface .src .selflink { + border-left: 1px solid #919191; + margin: 0 -0.5em 0 0.5em; +} + +#interface span.fixity { + color: #919191; + border-left: 1px solid #919191; + padding: 0.2em 0.5em 0.2em 0.5em; + margin: 0 -1em 0 1em; +} + +#interface span.rightedge { + border-left: 1px solid #919191; + padding: 0.2em 0 0.2em 0; + margin: 0 0 0 1em; +} + +#interface table { border-spacing: 2px; } +#interface td { + vertical-align: top; + padding-left: 0.5em; +} + +#interface td.doc p { + margin: 0; +} +#interface td.doc p + p { + margin-top: 0.8em; +} + +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} + +.clearfix:after { + clear: both; + content: " "; + display: block; + height: 0; + visibility: hidden; +} + +.subs.fields ul { + list-style: none; + display: table; + margin: 0; +} + +.subs.fields ul li { + display: table-row; +} + +.subs ul li dfn { + display: table-cell; + font-style: normal; + font-weight: bold; + margin: 1px 0; + white-space: nowrap; +} + +.subs ul li > .doc { + display: table-cell; + padding-left: 0.5em; + margin-bottom: 0.5em; +} + +.subs ul li > .doc p { + margin: 0; +} + +/* Render short-style data instances */ +.inst ul { + height: 100%; + padding: 0.5em; + margin: 0; +} + +.inst, .inst li { + list-style: none; + margin-left: 1em; +} + +/* Workaround for bug in Firefox (issue #384) */ +.inst-left { + float: left; +} + +.top p.src { + border-top: 1px solid #ccc; +} + +.subs, .doc { + /* use this selector for one level of indent */ + padding-left: 2em; +} + +.warning { + color: red; +} + +.arguments { + margin-top: -0.4em; +} +.arguments .caption { + display: none; +} + +.fields { padding-left: 1em; } + +.fields .caption { display: none; } + +.fields p { margin: 0 0; } + +/* this seems bulky to me +.methods, .constructors { + background: #f8f8f8; + border: 1px solid #eee; +} +*/ + +/* @end */ + +/* @group Auxillary Pages */ + + +.extension-list { + list-style-type: none; + margin-left: 0; +} + +#mini { + margin: 0 auto; + padding: 0 1em 1em; +} + +#mini > * { + font-size: 93%; /* 12pt */ +} + +#mini #module-list .caption, +#mini #module-header .caption { + font-size: 125%; /* 15pt */ +} + +#mini #interface h1, +#mini #interface h2, +#mini #interface h3, +#mini #interface h4 { + font-size: 109%; /* 13pt */ + margin: 1em 0 0; +} + +#mini #interface .top, +#mini #interface .src { + margin: 0; +} + +#mini #module-list ul { + list-style: none; + margin: 0; +} + +#alphabet ul { + list-style: none; + padding: 0; + margin: 0.5em 0 0; + text-align: center; +} + +#alphabet li { + display: inline; + margin: 0 0.25em; +} + +#alphabet a { + font-weight: bold; +} + +#index .caption, +#module-list .caption { font-size: 131%; /* 17pt */ } + +#index table { + margin-left: 2em; +} + +#index .src { + font-weight: bold; +} +#index .alt { + font-size: 77%; /* 10pt */ + font-style: italic; + padding-left: 2em; +} + +#index td + td { + padding-left: 1em; +} + +#module-list ul { + list-style: none; + margin: 0 0 0 2em; +} + +#module-list li { + clear: right; +} + +#module-list span.collapser, +#module-list span.expander { + background-position: 0 0.3em; +} + +#module-list .package { + float: right; +} + +:target { + background-color: #ffff00; +} + +/* @end */ diff --git a/resources/html/Ocean.theme/plus.gif b/resources/html/Ocean.theme/plus.gif new file mode 100644 Binary files /dev/null and b/resources/html/Ocean.theme/plus.gif differ diff --git a/resources/html/Ocean.theme/synopsis.png b/resources/html/Ocean.theme/synopsis.png new file mode 100644 Binary files /dev/null and b/resources/html/Ocean.theme/synopsis.png differ diff --git a/resources/html/haddock-bundle.min.js b/resources/html/haddock-bundle.min.js new file mode 100644 --- /dev/null +++ b/resources/html/haddock-bundle.min.js @@ -0,0 +1,2 @@ +!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e element with id '"+e+"'");return t}function x(){return u.defaultInstanceState==i.Open}function w(e){for(var t=S(e.target.id),n=t.element.open,o=0,r=t.toggles;owindow.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return d(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,d=void 0===u?[]:u,h=t.resultMap,p=void 0===h?{}:h,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=d.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),k=[],S=0;S=c.length;if(this._log("\nCheck Matches: "+T),(g||_.isMatch)&&T){var N=p[a];N?N.output.push({key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(V(i))for(var P=0,j=i.length;P= 0; -} - -function addClass(elem, value) { - var className = spaced(elem.className || ""); - if ( className.indexOf( " " + value + " " ) < 0 ) { - elem.className = trim(className + " " + value); - } -} - -function removeClass(elem, value) { - var className = spaced(elem.className || ""); - className = className.replace(" " + value + " ", " "); - elem.className = trim(className); -} - -function toggleClass(elem, valueOn, valueOff, bool) { - if (bool == null) { bool = ! hasClass(elem, valueOn); } - if (bool) { - removeClass(elem, valueOff); - addClass(elem, valueOn); - } - else { - removeClass(elem, valueOn); - addClass(elem, valueOff); - } - return bool; -} - - -function makeClassToggle(valueOn, valueOff) -{ - return function(elem, bool) { - return toggleClass(elem, valueOn, valueOff, bool); - } -} - -toggleShow = makeClassToggle("show", "hide"); -toggleCollapser = makeClassToggle("collapser", "expander"); - -function toggleSection(id) -{ - var b = toggleShow(document.getElementById("section." + id)); - toggleCollapser(document.getElementById("control." + id), b); - rememberCollapsed(id, b); - return b; -} - -var collapsed = {}; -function rememberCollapsed(id, b) -{ - if(b) - delete collapsed[id] - else - collapsed[id] = null; - - var sections = []; - for(var i in collapsed) - { - if(collapsed.hasOwnProperty(i)) - sections.push(i); - } - // cookie specific to this page; don't use setCookie which sets path=/ - document.cookie = "collapsed=" + escape(sections.join('+')); -} - -function restoreCollapsed() -{ - var cookie = getCookie("collapsed"); - if(!cookie) - return; - - var ids = cookie.split('+'); - for(var i in ids) - { - if(document.getElementById("section." + ids[i])) - toggleSection(ids[i]); - } -} - -function setCookie(name, value) { - document.cookie = name + "=" + escape(value) + ";path=/;"; -} - -function clearCookie(name) { - document.cookie = name + "=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"; -} - -function getCookie(name) { - var nameEQ = name + "="; - var ca = document.cookie.split(';'); - for(var i=0;i < ca.length;i++) { - var c = ca[i]; - while (c.charAt(0)==' ') c = c.substring(1,c.length); - if (c.indexOf(nameEQ) == 0) { - return unescape(c.substring(nameEQ.length,c.length)); - } - } - 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) { - var btn = menu.firstChild.cloneNode(false); - btn.innerHTML = html; - menu.appendChild(btn); - } -} - -function styles() { - var i, a, es = document.getElementsByTagName("link"), rs = []; - for (i = 0; a = es[i]; i++) { - if(a.rel.indexOf("style") != -1 && a.title) { - rs.push(a); - } - } - return rs; -} - -function addStyleMenu() { - var as = styles(); - var i, a, btns = ""; - for(i=0; a = as[i]; i++) { - btns += "
  • " - + a.title + "
    • " - } - if (as.length > 1) { - var h = "
    " - + "Style ▾" - + "
      " + btns + "
    " - + "
    "; - addMenuItem(h); - } -} - -function setActiveStyleSheet(title) { - var as = styles(); - var i, a, found; - for(i=0; a = as[i]; i++) { - a.disabled = true; - // need to do this always, some browsers are edge triggered - if(a.title == title) { - found = a; - } - } - if (found) { - found.disabled = false; - setCookie("haddock-style", title); - } - else { - as[0].disabled = false; - clearCookie("haddock-style"); - } - styleMenu(false); -} - -function resetStyle() { - var s = getCookie("haddock-style"); - if (s) setActiveStyleSheet(s); -} - - -function styleMenu(show) { - var m = document.getElementById('style-menu'); - if (m) toggleShow(m, show); -} - - -function pageLoad() { - addStyleMenu(); - resetStyle(); - restoreCollapsed(); -} - diff --git a/resources/html/quick-jump.css b/resources/html/quick-jump.css new file mode 100644 --- /dev/null +++ b/resources/html/quick-jump.css @@ -0,0 +1,221 @@ +/* @group Fundamentals */ + +.hidden { + display: none; +} + +/* @end */ + +/* @group Search box layout */ + +#search { + position: fixed; + top: 3.2em; + bottom: 0; + left: calc(50% - 22em); + width: 44em; + z-index: 1000; + overflow-y: auto; +} + +@media only screen and (max-width: 999px) { + #search { + top: 5.7em; + } +} + +#search-form, #search-results { + box-shadow: 2px 2px 6px rgb(199, 204, 208); + pointer-events: all; +} + +#search-form input { + font-size: 1.25em; line-height: 2.3em; height: 2.4em; + display: block; + box-sizing: border-box; + width: 100%; + margin: 0; + padding: 0 0.75em; + border: 0.05em solid rgb(151, 179, 202); +} + +#search input:focus { + outline: none; +} + +#search p.error { + color: rgb(107, 24, 24); + font-weight: bold; +} + +#search-results { + box-sizing: border-box; + border: 0.05em solid #b2d5fb; + background: #e8f3ff; + max-height: 80%; + overflow: scroll; +} + +#search-form input + #search-results { + border-top: none; + top: 3em; + max-height: calc(100% - 3em); +} + +/* @end */ + +/* @group search results */ + +#search-results > ul { + margin: 0; + list-style: none; +} + +#search-results > ul > li, +#search-results > p, +#search-results > table { + padding: 0.5em 1em; + margin: 0; +} + +#search-results > ul > li { + border-bottom: 1px solid #b2d5fb; +} + +#search-results > ul > li > ul { + list-style: none; +} + +.search-module h4 { + margin: 0; +} + +.search-module > ul { + margin: 0.5em 0 0.5em 2em; +} + +.search-module > ul > li > a[href] { + display: block; + color: inherit; + padding: 0.25em 0.5em; +} + +.search-module > ul > li > a[href].active-link { + background: #faf9dc; +} + +.search-module a[href]:hover { + text-decoration: none; +} + +.search-result a a { + pointer-events: none; +} + +.search-result ul.subs { + display: inline-block; + margin: 0; padding: 0; +} + +.search-result ul.subs li { + display: none; +} + +.search-result ul.subs::after { + display: inline-block; + content: "..."; + color: rgb(78,98,114); + margin: 0 0.25em; +} + +.more-results { + color: rgb(99, 141, 173); + position: relative; +} + +.more-results::before { + content: "+"; + display: inline-block; + color: #b2d5fb; + font-weight: bold; + font-size: 1.25em; line-height: inherit; + position: absolute; + left: -1em; +} + +/* @end */ + +/* @group Keyboard shortcuts table */ + +.keyboard-shortcuts { + line-height: 1.6em; +} + +.keyboard-shortcuts th { + color: rgb(78,98,114); +} + +.keyboard-shortcuts td:first-child, +.keyboard-shortcuts th:first-child { + text-align: right; + padding-right: 0.6em; +} + +.key { + display: inline-block; + font-size: 0.9em; + min-width: 0.8em; line-height: 1.2em; + text-align: center; + background: #b2d5fb; + border: 1px solid #74a3d6; + padding: 0 0.2em; + margin: 0 0.1em; +} + +/* @end */ + +/* @group Dropdown menus */ + +/* Based on #search styling above. */ + +.dropdown-menu { + position: fixed; + /* Not robust to window size changes. */ + top: 3.2em; + right: 0; + /* To display on top of synopsis menu on right side. */ + z-index: 1000; + border: 0.05em solid #b2d5fb; + background: #e8f3ff; +} + +@media only screen and (max-width: 999px) { + .dropdown-menu { + top: 5.7em; + } +} + +.dropdown-menu * { + margin: 0.1em; +} + +.dropdown-menu button { + border: 1px #5E5184 solid; + border-radius: 3px; + background: #5E5184; + padding: 3px; + color: #f4f4f4; + min-width: 6em; +} + +.dropdown-menu button:hover { + color: #5E5184; + background: #f4f4f4; +} + +.dropdown-menu button:active { + color: #f4f4f4; + background: #5E5184; +} + +/* @end */ diff --git a/resources/html/quick-jump.min.js b/resources/html/quick-jump.min.js new file mode 100644 --- /dev/null +++ b/resources/html/quick-jump.min.js @@ -0,0 +1,2 @@ +!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;ewindow.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return h(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),m}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l 0 and <= 1");d=d.name}else a[d]={weight:1};this._analyze({key:d,value:this.options.getFn(u,d),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,h=void 0===u?[]:u,p=t.resultMap,d=void 0===p?{}:p,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,_=-1,m=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var y=h.search(i);if(this._log('Full text: "'+i+'", score: '+y.score),this.options.tokenize){for(var k=i.split(this.options.tokenSeparator),b=[],x=0;x=c.length;if(this._log("\nCheck Matches: "+O),(g||y.isMatch)&&O){var P=d[a];P?P.output.push({key:n,arrayIndex:r,value:i,score:T,matchedIndices:y.matchedIndices}):(d[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:T,matchedIndices:y.matchedIndices}]},v.push(d[a]))}}else if(U(i))for(var j=0,E=i.length;j throwE msg; Right q -> return q} + qual <- rightOrThrowE (qualification flags) + sinceQual <- rightOrThrowE (sinceQualification flags) - -- inject dynamic-too into flags before we proceed - flags' <- ghc flags $ do + -- Inject dynamic-too into ghc options if the ghc we are using was built with + -- dynamic linking + flags'' <- ghc flags $ do df <- getDynFlags case lookup "GHC Dynamic" (compilerInfo df) of Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + -- Inject `-j` into ghc options, if given to Haddock + flags' <- pure $ case optParCount flags'' of + Nothing -> flags'' + Just Nothing -> Flag_OptGhc "-j" : flags'' + Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags'' + + -- Whether or not to bypass the interface version check + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + + -- Create a temporary directory and redirect GHC output there (unless user + -- requested otherwise). + -- + -- Output dir needs to be set before calling 'depanal' since 'depanal' uses it + -- to compute output file names that are stored in the 'DynFlags' of the + -- resulting 'ModSummary's. + let withDir | Flag_NoTmpCompDir `elem` flags = id + | otherwise = withTempOutputDir + + -- Output warnings about potential misuse of some flags unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags - forM_ (warnings args) $ \warning -> do - hPutStrLn stderr warning - - ghc flags' $ do + mapM_ (hPutStrLn stderr) (optGhcWarnings args) + when noChecks $ + hPutStrLn stderr noCheckWarning + ghc flags' $ withDir $ do dflags <- getDynFlags + logger <- getLogger + !unit_state <- hsc_units <$> getSession + -- If any --show-interface was used, show the given interfaces + forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do + name_cache <- freshNameCache + mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks + forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do + putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) + + -- If we were given source files to generate documentation from, do it if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + let packageInfo = PackageInfo { piPackageName = + fromMaybe (PackageName mempty) (optPackageName flags) + , piPackageVersion = + fromMaybe (makeVersion []) (optPackageVersion flags) + } -- Dump an "interface file" (.haddock file), if requested. forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do writeInterfaceFile path InterfaceFile { ifInstalledIfaces = map toInstalledIface ifaces + , ifPackageInfo = packageInfo , ifLinkEnv = homeLinks } -- Render the interfaces. - liftIO $ renderStep dflags flags qual packages ifaces + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces + -- If we were not given any input files, error if documentation was + -- requested else do when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ throwE "No input file(s)." -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + name_cache <- liftIO $ freshNameCache + packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags qual packages [] + liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] +-- | Run the GHC action using a temporary output directory +withTempOutputDir :: Ghc a -> Ghc a +withTempOutputDir action = do + tmp <- liftIO getTemporaryDirectory + x <- liftIO getProcessID + let dir = tmp ".haddock-" ++ show x + modifySessionDynFlags (setOutputDir dir) + withTempDir dir action + -- | Create warnings about potential misuse of -optghc -warnings :: [String] -> [String] -warnings = map format . filter (isPrefixOf "-optghc") +optGhcWarnings :: [String] -> [String] +optGhcWarnings = map format . filter (isPrefixOf "-optghc") where format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] +-- | Create a warning about bypassing the interface version check +noCheckWarning :: String +noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++ + "Haddock to crash when reading Haddock interface files." withGhc :: [Flag] -> Ghc a -> IO a withGhc flags action = do - libDir <- fmap snd (getGhcDirs flags) + libDir <- fmap (fromMaybe (error "No GhcDir found") . snd) (getGhcDirs flags) -- Catches all GHC source errors, then prints and re-throws them. let handleSrcErrors action' = flip handleSourceError action' $ \err -> do printException err liftIO exitFailure + needHieFiles = Flag_HyperlinkedSource `elem` flags - withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action) + withGhc' libDir needHieFiles (ghcFlags flags) (\_ -> handleSrcErrors action) readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) + -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do - -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + -- Whether or not we bypass the interface file version check + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags - -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map snd packages + -- Read package dependency interface files supplied with --read-interface + name_cache <- hsc_NC <$> getSession + packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks + + -- Create the interfaces for the given modules -- this is the core part of Haddock + let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags qual pkgs interfaces = do - updateHTMLXRefs pkgs +renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption + -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () +renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do + updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> + ( case baseUrl flags of + Nothing -> fst docPath + Just url -> url packageName (ifUnitId ifaceFile) + , ifaceFile)) pkgs) let - ifaceFiles = map snd pkgs - installedIfaces = concatMap ifInstalledIfaces ifaceFiles + installedIfaces = + map + (\(_, showModules, ifaceFilePath, ifaceFile) + -> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile)) + pkgs extSrcMap = Map.fromList $ do - ((_, Just path), ifile) <- pkgs + ((_, Just path), _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags flags qual interfaces installedIfaces extSrcMap - + render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap + where + -- get package name from unit-id + packageName :: Unit -> String + packageName unit = + case lookupUnit unit_state unit of + Nothing -> show unit + Just pkg -> unitPackageNameString pkg -- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO () -render dflags flags qual ifaces installedIfaces extSrcMap = do +render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface] + -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () +render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do let + packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) + $ optPackageName flags + , piPackageVersion = fromMaybe (makeVersion []) + $ optPackageVersion flags + } + title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags + opt_base_url = baseUrl flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags @@ -251,113 +342,190 @@ dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags + logger = setLogFlags log' (initLogFlags dflags') visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ installedIfaces - allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + -- /All/ interfaces including external package modules, grouped by + -- interface file (package). + allPackages :: [PackageInterfaces] + allPackages = [PackageInterfaces + { piPackageInfo = packageInfo + , piVisibility = Visible + , piInstalledInterfaces = map toInstalledIface ifaces + }] + ++ map snd packages - pkgMod = ifaceMod (head ifaces) - pkgKey = moduleUnitId pkgMod - pkgStr = Just (unitIdString pkgKey) - pkgNameVer = modulePackageInfo dflags flags pkgMod + -- /All/ visible interfaces including external package modules, grouped by + -- interface file (package). + allVisiblePackages :: [PackageInterfaces] + allVisiblePackages = [ pinfo { piInstalledInterfaces = + filter (\i -> OptHide `notElem` instOptions i) + piInstalledInterfaces + } + | pinfo@PackageInterfaces + { piVisibility = Visible + , piInstalledInterfaces + } <- allPackages + ] + -- /All/ installed interfaces. + allInstalledIfaces :: [InstalledInterface] + allInstalledIfaces = concatMap (piInstalledInterfaces . snd) packages + + pkgMod = fmap ifaceMod (listToMaybe ifaces) + pkgKey = fmap moduleUnit pkgMod + pkgStr = fmap unitString pkgKey + pkgNameVer = modulePackageInfo unit_state flags pkgMod + pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) + sincePkg = case sinceQual of + External -> pkgName + Always -> Nothing + (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags srcModule' | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap = mkSrcMap $ Map.union + srcMap = Map.union (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) - pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap + pkgSrcMap = Map.mapKeys moduleUnit extSrcMap pkgSrcMap' - | Flag_HyperlinkedSource `elem` flags = - Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap - | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap + | Flag_HyperlinkedSource `elem` flags + , Just k <- pkgKey + = Map.insert k hypSrcModuleNameUrlFormat pkgSrcMap + | Just srcNameUrl <- srcEntity + , Just k <- pkgKey + = Map.insert k srcNameUrl pkgSrcMap | otherwise = pkgSrcMap -- TODO: Get these from the interface files as with srcMap pkgSrcLMap' - | Flag_HyperlinkedSource `elem` flags = - Map.singleton pkgKey hypSrcModuleLineUrlFormat - | Just path <- srcLEntity = Map.singleton pkgKey path + | Flag_HyperlinkedSource `elem` flags + , Just k <- pkgKey + = Map.singleton k hypSrcModuleLineUrlFormat + | Just path <- srcLEntity + , Just k <- pkgKey + = Map.singleton k path | otherwise = Map.empty sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') + installedMap :: Map Module InstalledInterface + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- allInstalledIfaces ] + + -- The user gives use base-4.9.0.0, but the InstalledInterface + -- records the *wired in* identity base. So untranslate it + -- so that we can service the request. + unwire :: Module -> Module + unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } + + reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do + let warn' = hPutStrLn stderr . ("Warning: " ++) + case readP_to_S parseHoleyModule mod_str of + [(m, "")] + | Just iface <- Map.lookup m installedMap + -> return [iface] + | otherwise + -> warn' ("Cannot find reexported module '" ++ mod_str ++ "'") >> return [] + _ -> warn' ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return []) + libDir <- getHaddockLibDir flags - prologue <- getPrologue dflags' flags + !prologue <- force <$> getPrologue dflags' flags themes <- getThemes libDir flags >>= either bye return + let withQuickjump = Flag_QuickJumpIndex `elem` flags + withBaseURL = isJust + . find (\flag -> case flag of + Flag_BaseURL base_url -> + base_url /= "." && base_url /= "./" + _ -> False + ) + $ flags + when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title pkgStr - themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty - copyHtmlBits odir libDir themes + withTiming logger "ppHtmlIndex" (const ()) $ do + _ <- {-# SCC ppHtmlIndex #-} + ppHtmlIndex odir title pkgStr + themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls + withQuickjump + (concatMap piInstalledInterfaces allVisiblePackages) pretty + return () + unless withBaseURL $ + copyHtmlBits odir libDir themes withQuickjump + when (Flag_GenContents `elem` flags) $ do - ppHtmlContents dflags' odir title pkgStr - themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty - (makeContentsQual qual) - copyHtmlBits odir libDir themes + withTiming logger "ppHtmlContents" (const ()) $ do + _ <- {-# SCC ppHtmlContents #-} + ppHtmlContents unit_state odir title pkgStr + themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls + withQuickjump + allVisiblePackages True prologue pretty + sincePkg (makeContentsQual qual) + return () + copyHtmlBits odir libDir themes withQuickjump + when withQuickjump $ void $ + ppJsonIndex odir sourceUrls' opt_wiki_urls + unicode Nothing qual + ifaces + ( nub + . map fst + . filter ((== Visible) . piVisibility . snd) + $ packages) + when (Flag_Html `elem` flags) $ do - ppHtml dflags' title pkgStr visibleIfaces odir - prologue - themes opt_mathjax sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes + withTiming logger "ppHtml" (const ()) $ do + _ <- {-# SCC ppHtml #-} + ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir + prologue + themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url + opt_contents_url opt_index_url unicode sincePkg packageInfo + qual pretty withQuickjump + return () + unless withBaseURL $ do + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do case pkgNameVer of - Nothing -> putStrLn . unlines $ + (Just (PackageName pkgNameFS), mpkgVer) -> + let + pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title + | otherwise = unpackFS pkgNameFS + + pkgVer = + fromMaybe (makeVersion []) mpkgVer + in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) + visibleIfaces odir + _ -> putStrLn . unlines $ [ "haddock: Unable to find a package providing module " - ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle." + ++ maybe "" (moduleNameString . moduleName) pkgMod + ++ ", skipping Hoogle." , "" , " Perhaps try specifying the desired package explicitly" ++ " using the --package-name" , " and --package-version arguments." ] - Just (PackageName pkgNameFS, pkgVer) -> - let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title - | otherwise = unpackFS pkgNameFS - in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue) - visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do - ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style - libDir + withTiming logger "ppLatex" (const ()) $ do + _ <- {-# SCC ppLatex #-} + ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style + libDir + return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do - ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces - --- | From GHC 7.10, this function has a potential to crash with a --- nasty message such as @expectJust getPackageDetails@ because --- package name and versions can no longer reliably be extracted in --- all cases: if the package is not installed yet then this info is no --- longer available. The @--package-name@ and @--package-version@ --- Haddock flags allow the user to specify this information and it is --- returned here if present: if it is not present, the error will --- occur. Nasty but that's how it is for now. Potential TODO. -modulePackageInfo :: DynFlags - -> [Flag] -- ^ Haddock flags are checked as they may - -- contain the package name or version - -- provided by the user which we - -- prioritise - -> Module -> Maybe (PackageName, Data.Version.Version) -modulePackageInfo dflags flags modu = - cmdline <|> pkgDb - where - cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags - pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu) + withTiming logger "ppHyperlinkedSource" (const ()) $ do + _ <- {-# SCC ppHyperlinkedSource #-} + ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces + return () ------------------------------------------------------------------------------- @@ -365,22 +533,22 @@ ------------------------------------------------------------------------------- -readInterfaceFiles :: MonadIO m - => NameCacheAccessor m - -> [(DocPaths, FilePath)] - -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do - catMaybes `liftM` mapM tryReadIface pairs +readInterfaceFiles :: NameCache + -> [(DocPaths, Visibility, FilePath)] + -> Bool + -> IO [(DocPaths, Visibility, FilePath, InterfaceFile)] +readInterfaceFiles name_cache_accessor pairs bypass_version_check = do + catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't - tryReadIface (paths, file) = - readInterfaceFile name_cache_accessor file >>= \case - Left err -> liftIO $ do + tryReadIface (paths, vis, file) = + readInterfaceFile name_cache_accessor file bypass_version_check >>= \case + Left err -> do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return $ Just (paths, f) + Right f -> return (Just (paths, vis, file, f)) ------------------------------------------------------------------------------- @@ -390,84 +558,147 @@ -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. -withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } - let dynflags'' = gopt_unset dynflags' Opt_SplitObjs - defaultCleanupHandler dynflags'' $ do - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags'' - ghcActs dynflags'' +withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a +withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do + logger <- getLogger + dynflags' <- parseGhcFlags logger =<< getSessionDynFlags + + -- We disable pattern match warnings because than can be very + -- expensive to check + let dynflags'' = unsetPatternMatchWarnings $ updOptLevel 0 dynflags' + + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags'' + ghcActs dynflags'' where - parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags - parseGhcFlags dynflags = do + -- ignore sublists of flags that start with "+RTS" and end in "-RTS" + -- + -- See https://github.com/haskell/haddock/issues/666 + filterRtsFlags :: [String] -> [String] + filterRtsFlags flgs = foldr go (const []) flgs True + where go "-RTS" func _ = func True + go "+RTS" func _ = func False + go _ func False = func False + go arg func True = arg : func True + + parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags + parseGhcFlags logger dynflags = do -- TODO: handle warnings? - -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot - -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if - -- we pass any, Haddock will fail. Since StaticFlags are global to the - -- GHC invocation, there's also no way to reparse/save them to set them - -- again properly. - -- - -- This is a bit of a hack until we get rid of the rest of the remaining - -- StaticFlags. See GHC issue #8276. - let flags' = discardStaticFlags flags - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') + let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] + | otherwise = [Opt_Haddock] + dynflags' = (foldl' gopt_set dynflags extra_opts) + { backend = noBackend + , ghcMode = CompManager + , ghcLink = NoLink + } + flags' = filterRtsFlags flags + + (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags') if not (null rest) then throwE ("Couldn't parse GHC options: " ++ unwords flags') - else return dynflags' + else return dynflags'' +unsetPatternMatchWarnings :: DynFlags -> DynFlags +unsetPatternMatchWarnings dflags = + foldl' wopt_unset dflags pattern_match_warnings + where + pattern_match_warnings = + [ Opt_WarnIncompletePatterns + , Opt_WarnIncompleteUniPatterns + , Opt_WarnIncompletePatternsRecUpd + , Opt_WarnOverlappingPatterns + ] + ------------------------------------------------------------------------------- -- * Misc ------------------------------------------------------------------------------- -getHaddockLibDir :: [Flag] -> IO String +getHaddockLibDir :: [Flag] -> IO FilePath getHaddockLibDir flags = case [str | Flag_Lib str <- flags] of [] -> do #ifdef IN_GHC_TREE - getInTreeDir + + -- When in the GHC tree, we should be able to locate the "lib" folder + -- based on the location of the current executable. + base_dir <- getBaseDir -- Provided by GHC + let res_dirs = [ d | Just d <- [base_dir] ] ++ + #else - d <- getDataDir -- provided by Cabal - doesDirectoryExist d >>= \exists -> case exists of - True -> return d - False -> do - -- If directory does not exist then we are probably invoking from - -- ./dist/build/haddock/haddock so we use ./resources as a fallback. - doesDirectoryExist "resources" >>= \exists_ -> case exists_ of - True -> return "resources" - False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n") + + -- When Haddock was installed by @cabal@, the resources (which are listed + -- under @data-files@ in the Cabal file) will have been copied to a + -- special directory. + data_dir <- getDataDir -- Provided by Cabal + let res_dirs = [ data_dir ] ++ + #endif - fs -> return (last fs) + -- When Haddock is built locally (eg. regular @cabal new-build@), the data + -- directory does not exist and we are probably invoking from either + -- @./haddock-api@ or @./@ + [ "resources" + , "haddock-api/resources" + ] -getGhcDirs :: [Flag] -> IO (String, String) + res_dir <- check res_dirs + case res_dir of + Just p -> return p + _ -> die "Haddock's resource directory does not exist!\n" + + fs -> return (last fs) + where + -- Pick the first path that corresponds to a directory that exists + check :: [FilePath] -> IO (Maybe FilePath) + check [] = pure Nothing + check (path : other_paths) = do + exists <- doesDirectoryExist path + if exists then pure (Just path) else check other_paths + +-- | Find the @lib@ directory for GHC and the path to @ghc@ +getGhcDirs :: [Flag] -> IO (Maybe FilePath, Maybe FilePath) getGhcDirs flags = do - case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> do + #ifdef IN_GHC_TREE - libDir <- getInTreeDir - return (ghcPath, libDir) + base_dir <- getBaseDir + let ghc_path = Nothing #else - return (ghcPath, GhcPaths.libdir) + let base_dir = Just GhcPaths.libdir + ghc_path = Just GhcPaths.ghc #endif - xs -> return (ghcPath, last xs) - where + + -- If the user explicitly specifies a lib dir, use that + let ghc_dir = case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> base_dir + xs -> Just (last xs) + + pure (ghc_path, ghc_dir) + + #ifdef IN_GHC_TREE - ghcPath = "not available" -#else - ghcPath = GhcPaths.ghc -#endif +-- | See 'getBaseDir' in "SysTools.BaseDir" +getBaseDir :: IO (Maybe FilePath) +getBaseDir = do + -- Getting executable path can fail. Turn that into 'Nothing' + exec_path_opt <- catch (Just <$> getExecutablePath) + (\(_ :: SomeException) -> pure Nothing) + + -- Check that the path we are about to return actually exists + case exec_path_opt of + Nothing -> pure Nothing + Just exec_path -> do + let base_dir = takeDirectory (takeDirectory exec_path) "lib" + exists <- doesDirectoryExist base_dir + pure (if exists then Just base_dir else Nothing) + +#endif + shortcutFlags :: [Flag] -> IO () shortcutFlags flags = do usage <- getUsage @@ -480,19 +711,19 @@ when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) when (Flag_PrintGhcPath `elem` flags) $ do - dir <- fmap fst (getGhcDirs flags) - bye $ dir ++ "\n" + path <- fmap fst (getGhcDirs flags) + bye $ fromMaybe "not available" path ++ "\n" when (Flag_PrintGhcLibDir `elem` flags) $ do dir <- fmap snd (getGhcDirs flags) - bye $ dir ++ "\n" + bye $ fromMaybe "not available" dir ++ "\n" when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ throwE "Unicode can only be enabled for HTML output." when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ - throwE "-h cannot be used with --gen-index or --gen-contents" + throwE "-h/--html cannot be used with --gen-index or --gen-contents" when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Hoogle `elem` flags) $ @@ -510,38 +741,42 @@ -- | Generate some warnings about potential misuse of @--hyperlinked-source@. hypSrcWarnings :: [Flag] -> IO () hypSrcWarnings flags = do - when (hypSrc && any isSourceUrlFlag flags) $ hPutStrLn stderr $ concat [ "Warning: " , "--source-* options are ignored when " , "--hyperlinked-source is enabled." ] - when (not hypSrc && any isSourceCssFlag flags) $ hPutStrLn stderr $ concat [ "Warning: " , "source CSS file is specified but " , "--hyperlinked-source is disabled." ] - where + hypSrc :: Bool hypSrc = Flag_HyperlinkedSource `elem` flags + + isSourceUrlFlag :: Flag -> Bool isSourceUrlFlag (Flag_SourceBaseURL _) = True isSourceUrlFlag (Flag_SourceModuleURL _) = True isSourceUrlFlag (Flag_SourceEntityURL _) = True isSourceUrlFlag (Flag_SourceLEntityURL _) = True isSourceUrlFlag _ = False + + isSourceCssFlag :: Flag -> Bool isSourceCssFlag (Flag_SourceCss _) = True isSourceCssFlag _ = False -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () +updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) - writeIORef html_xrefs_ref' (Map.fromList mapping') + let !modMap = force $ Map.fromList mapping + !modNameMap = force $ Map.fromList mapping' + writeIORef html_xrefs_ref modMap + writeIORef html_xrefs_ref' modNameMap where - mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages + mapping = [ (instMod iface, html) | (html, ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] mapping' = [ (moduleName m, html) | (m, html) <- mapping ] @@ -550,36 +785,15 @@ getPrologue dflags flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing - [filename] -> withFile filename ReadMode $ \h -> do + [filename] -> do + h <- openFile filename ReadMode hSetEncoding h utf8 - str <- hGetContents h - return . Just $! parseParas dflags str + str <- hGetContents h -- semi-closes the handle + return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" -#ifdef IN_GHC_TREE - -getInTreeDir :: IO String -getInTreeDir = getExecDir >>= \case - Nothing -> error "No GhcDir found" - Just d -> return (d ".." "lib") - - -getExecDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) -getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. - where - try_size size = allocaArray (fromIntegral size) $ \buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> return Nothing - _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf - | otherwise -> try_size (size * 2) - -foreign import stdcall unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 -#else -getExecDir = return Nothing -#endif +rightOrThrowE :: Either String b -> IO b +rightOrThrowE (Left msg) = throwE msg +rightOrThrowE (Right x) = pure x -#endif diff --git a/src/Haddock/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs --- a/src/Haddock/Backends/HaddockDB.hs +++ b/src/Haddock/Backends/HaddockDB.hs @@ -104,16 +104,21 @@ hsep (map ppHsAType b)) context) ppHsType :: HsType -> Doc -ppHsType (HsForAllType Nothing context htype) = +ppHsType (HsForAllType _ Nothing context htype) = hsep [ ppHsContext context, text "=>", ppHsType htype] -ppHsType (HsForAllType (Just tvs) [] htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) -ppHsType (HsForAllType (Just tvs) context htype) = - hsep (text "forall" : map ppHsName tvs ++ text "." : +ppHsType (HsForAllType fvf (Just tvs) [] htype) = + hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf : + [ppHsType htype]) +ppHsType (HsForAllType fvf (Just tvs) context htype) = + hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf : ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] ppHsType t = ppHsBType t + +ppHsForAllSeparator :: ForallVisFlag -> Doc +ppHsForAllSeparator ForallVis = text "->" +ppHsForAllSeparator ForallInvis = text "." ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) = brackets $ ppHsType b diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -12,27 +15,34 @@ -- http://www.haskell.org/hoogle/ ----------------------------------------------------------------------------- module Haddock.Backends.Hoogle ( + -- * Main entry point to Hoogle output generation ppHoogle + + -- * Utilities for generating Hoogle output during interface creation + , ppExportD + , outWith ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..)) -import InstEnv (ClsInst(..)) +import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) import GHC -import Outputable -import NameSet +import GHC.Driver.Ppr +import GHC.Plugins (TopLevelFlag(..)) +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Unit.State import Data.Char -import Data.List +import Data.Foldable (toList) +import Data.List (intercalate, isPrefixOf) import Data.Maybe import Data.Version import System.Directory import System.FilePath -import System.IO prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" @@ -42,57 +52,59 @@ ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do - let filename = package ++ ".txt" + let -- Since Hoogle is line based, we want to avoid breaking long lines. + dflags' = dflags{ pprCols = maxBound } + filename = package ++ ".txt" contents = prefix ++ - docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ showVersion version - | not (null (versionBranch version)) ] ++ - concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + | not (null (versionBranch version)) + ] ++ + concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir - h <- openFile (odir filename) WriteMode - hSetEncoding h utf8 - hPutStr h (unlines contents) - hClose h + writeUtf8File (odir filename) (unlines contents) ppModule :: DynFlags -> Interface -> [String] ppModule dflags iface = "" : ppDocumentation dflags (ifaceDoc iface) ++ ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) + concatMap ppExportItem (ifaceRnExportItems $ iface) ++ + map (fromMaybe "" . haddockClsInstPprHoogle) (ifaceInstances iface) +-- | If the export item is an 'ExportDecl', get the attached Hoogle textual +-- database entries for that export declaration. +ppExportItem :: ExportItem DocNameI -> [String] +ppExportItem (ExportDecl RnExportD { rnExpDHoogle = o }) = o +ppExportItem _ = [] --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a -dropHsDocTy = f +dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn +dropHsDocTy = drop_sig_ty where - g (L src x) = L src (f x) - f (HsForAllTy a e) = HsForAllTy a (g e) - f (HsQualTy a e) = HsQualTy a (g e) - f (HsBangTy a b) = HsBangTy a (g b) - f (HsAppTy a b) = HsAppTy (g a) (g b) - f (HsFunTy a b) = HsFunTy (g a) (g b) - f (HsListTy a) = HsListTy (g a) - f (HsPArrTy a) = HsPArrTy (g a) - f (HsTupleTy a b) = HsTupleTy a (map g b) - f (HsOpTy a b c) = HsOpTy (g a) b (g c) - f (HsParTy a) = HsParTy (g a) - f (HsKindSig a b) = HsKindSig (g a) b - f (HsDocTy a _) = f $ unL a - f x = x - -outHsType :: OutputableBndr a => DynFlags -> HsType a -> String -outHsType dflags = out dflags . dropHsDocTy + drop_sig_ty (HsSig x a b) = HsSig x a (drop_lty b) + drop_sig_ty x@XHsSigType{} = x + drop_lty (L src x) = L src (drop_ty x) -dropComment :: String -> String -dropComment (' ':'-':'-':' ':_) = [] -dropComment (x:xs) = x : dropComment xs -dropComment [] = [] + drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e) + drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e) + drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b) + drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b) + drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b) + drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) + drop_ty (HsListTy x a) = HsListTy x (drop_lty a) + drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b) + drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c) + drop_ty (HsParTy x a) = HsParTy x (drop_lty a) + drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b + drop_ty (HsDocTy _ a _) = drop_ty $ unL a + drop_ty x = x +outHsSigType :: DynFlags -> HsSigType GhcRn -> String +outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy outWith :: Outputable a => (SDoc -> String) -> a -> [Char] outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr @@ -102,60 +114,73 @@ f [] = [] out :: Outputable a => DynFlags -> a -> String -out dflags = outWith $ showSDocUnqual dflags +out dflags = outWith $ showSDoc dflags operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x commaSeparate :: Outputable a => DynFlags -> [a] -> String -commaSeparate dflags = showSDocUnqual dflags . interpp'SP +commaSeparate dflags = showSDoc dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem Name -> [String] -ppExport dflags ExportDecl { expItemDecl = L _ decl - , expItemMbDoc = (dc, _) - , expItemSubDocs = subdocs - , expItemFixities = fixities - } = ppDocumentation dflags dc ++ f decl - where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (SigD sig) = ppSig dflags sig ++ ppFixities - f _ = [] +ppExportD :: DynFlags -> ExportD GhcRn -> [String] +ppExportD dflags + ExportD + { expDDecl = L _ decl + , expDPats = bundledPats + , expDMbDoc = mbDoc + , expDSubDocs = subdocs + , expDFixities = fixities + } + = let + -- Since Hoogle is line based, we want to avoid breaking long lines. + dflags' = dflags{ pprCols = maxBound } + in + concat + [ ppDocumentation dflags' dc ++ f d + | (d, (dc, _)) <- (decl, mbDoc) : bundledPats + ] ++ ppFixities + where + f :: HsDecl GhcRn -> [String] + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (TyClD _ (FamDecl _ d)) = ppFam dflags d + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ] + f (SigD _ sig) = ppSig dflags sig + f _ = [] - ppFixities = concatMap (ppFixity dflags) fixities -ppExport _ _ = [] + ppFixities :: [String] + ppFixities = concatMap (ppFixity dflags) fixities -ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs - = concatMap mkDocSig names - where - mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) - ++ [pp_sig dflags names (hsSigWcType sig)] - getDoc :: Located Name -> [Documentation Name] - getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) - -ppSigWithDoc _ _ _ = [] +ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc dflags sig subdocs = case sig of + TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names + PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names + _ -> [] + where + mkDocSig leader typ n = mkSubdocN dflags n subdocs + [leader ++ pp_sig dflags [n] typ] -ppSig :: DynFlags -> Sig Name -> [String] +ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ) = - operator prettyNames ++ " :: " ++ outHsType dflags typ + operator prettyNames ++ " :: " ++ outHsSigType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods +ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] +ppClass dflags decl@(ClassDecl {}) subdocs = + (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds} + ++ ppTyFams) : ppMethods where ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl @@ -165,97 +190,97 @@ ppTyFams | null $ tcdATs decl = "" - | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat - [ map ppr (tcdATs decl) - , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl) + | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat + [ map pprTyFam (tcdATs decl) + , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl) ] + pprTyFam :: LFamilyDecl GhcRn -> SDoc + pprTyFam (L _ at) = vcat' $ map text $ + mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at) + whereWrapper elems = vcat' [ text "where" <+> lbrace - , nest 4 . vcat . map (<> semi) $ elems + , nest 4 . vcat . map (Outputable.<> semi) $ elems , rbrace ] - - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name - tyFamEqnToSyn tfe = SynDecl - { tcdLName = tfe_tycon tfe - , tcdTyVars = tfe_pats tfe - , tcdRhs = tfe_rhs tfe - , tcdFVs = emptyNameSet - } - - -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = - [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls] +ppClass _ _non_cls_decl _ = [] +ppFam :: DynFlags -> FamilyDecl GhcRn -> [String] +ppFam dflags decl@(FamilyDecl { fdInfo = info }) + = [out dflags decl'] where - -- As per #168, we don't want safety information about the class - -- in Hoogle output. The easiest way to achieve this is to set the - -- safety information to a state where the Outputable instance - -- produces no output which means no overlap and unsafe (or [safe] - -- is generated). - cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty - , isSafeOverlap = False } } + decl' = case info of + -- We don't need to print out a closed type family's equations + -- for Hoogle, so pretend it doesn't have any. + ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } + _ -> decl -ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs - = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : - concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) +ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] +ppData dflags decl@DataDecl { tcdLName = name, tcdTyVars = tvs, tcdFixity = fixity, tcdDataDefn = defn } subdocs + = out dflags (ppDataDefnHeader (pp_vanilla_decl_head name tvs fixity) defn) : + concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where - - -- GHC gives out "data Bar =", we want to delete the equals - -- also writes data : a b, when we want data (:) a b - showData d = unwords $ map f $ if last xs == "=" then init xs else xs - where - xs = words $ out dflags d - nam = out dflags $ tyClDeclLName d - f w = if w == nam then operator nam else w ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... -lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] -ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con@ConDeclH98 {} +ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] +ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' } -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args' where - f (PrefixCon args) = [typeSig name $ args ++ [resType]] - f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] + f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat + [(concatMap (lookupCon dflags subdocs . noLocA . foExt . unLoc) (cd_fld_names r)) ++ + [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy x y) - apps = foldl1 (\x y -> reL $ HsAppTy x y) + funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y) + apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ + outHsSigType dflags (unL $ mkEmptySigType $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unL $ getConNames con - - resType = apps $ map (reL . HsTyVar . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + name = commaSeparate dflags . toList $ unL <$> getConNames con -ppCtor dflags _dat subdocs con@ConDeclGADT {} - = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f - where - f = [typeSig name (hsib_body $ con_type con)] + tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty + tyVarArg _ = panic "ppCtor" - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) - name = out dflags $ map unL $ getConNames con + resType = apps $ map reL $ + (HsTyVar noAnn NotPromoted (reL (tcdName dat))) : + map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) +ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names + , con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty }) + = concatMap (lookupCon dflags subdocs) names ++ [typeSig] + where + typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty + name = out dflags $ unL <$> names + con_sig_ty = HsSig noExtField outer_bndrs theta_ty where + theta_ty = case mcxt of + Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) + Nothing -> tau_ty + tau_ty = foldr mkFunTy res_ty $ + case args of PrefixConGADT pos_args -> map hsScaledThing pos_args + RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- @@ -278,7 +303,14 @@ lines header ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d +mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s +mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s + where + getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) + data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show @@ -304,8 +336,8 @@ markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, - markupModule = box (TagInline "a") . str, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), + markupModule = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label), markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupBold = box (TagInline "b"), @@ -314,14 +346,15 @@ markupMathInline = const $ str "", markupMathDisplay = const $ str "", markupUnorderedList = box (TagL 'u'), - markupOrderedList = box (TagL 'o'), + markupOrderedList = box (TagL 'o') . map snd, markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, - markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), + markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel), markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, - markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h, + markupTable = \(Table _ _) -> str "TODO: table" } diff --git a/src/Haddock/Backends/Hyperlinker.hs b/src/Haddock/Backends/Hyperlinker.hs --- a/src/Haddock/Backends/Hyperlinker.hs +++ b/src/Haddock/Backends/Hyperlinker.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource , module Haddock.Backends.Hyperlinker.Types @@ -6,50 +8,98 @@ import Haddock.Types +import Haddock.Utils (writeUtf8File, out, verbose, Verbosity) +import Haddock.InterfaceFile import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils - -import Text.XHtml hiding (()) +import Haddock.Backends.Xhtml.Utils ( renderToString ) import Data.Maybe import System.Directory import System.FilePath +import GHC.Iface.Ext.Types ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) +import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result ) +import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile ) +import Data.Map as M +import GHC.Data.FastString ( mkFastString ) +import GHC.Unit.Module ( Module, moduleName ) + -- | Generate hyperlinked source for given interfaces. -- -- Note that list of interfaces should also contain interfaces normally hidden -- when generating documentation. Otherwise this could lead to dead links in -- produced source. -ppHyperlinkedSource :: FilePath -- ^ Output directory +ppHyperlinkedSource :: Verbosity + -> FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML - -> SrcMap -- ^ Paths to sources + -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do +ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces + mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir + srcs = (srcs', M.mapKeys moduleName srcs') -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface - -> IO () -ppHyperlinkedModuleSource srcdir pretty srcs iface = - case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . html . render' $ tokens - Nothing -> return () +ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO () +ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of + Just hfp -> do + -- Parse the GHC-produced HIE file + nc <- freshNameCache + HieFile { hie_hs_file = file + , hie_asts = HieASTs asts + , hie_types = types + , hie_hs_src = rawSrc + } <- hie_file_result + <$> (readHieFile nc hfp) + + -- Get the AST and tokens corresponding to the source file we want + let fileFs = mkFastString file + mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup (HiePath (mkFastString file)) asts + tokens' = parse df file rawSrc + ast = fromMaybe (emptyHieAst fileFs) mast + fullAst = recoverFullIfaceTypes df types ast + + -- Warn if we didn't find an AST, but there were still ASTs + if M.null asts + then pure () + else out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + + -- The C preprocessor can double the backslashes on tokens (see #19236), + -- which means the source spans will not be comparable and we will not + -- be able to associate the HieAST with the correct tokens. + -- + -- We work around this by setting the source span of the tokens to the file + -- name from the HieAST + let tokens = fmap (\tk -> tk {tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens' + + -- Produce and write out the hyperlinked sources + writeUtf8File path . renderToString pretty . render' fullAst $ tokens + Nothing -> return () where + df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs - html = if pretty then renderHtml else showHtml path = srcdir hypSrcModuleFile (ifaceMod iface) + + emptyHieAst fileFs = Node + { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + , nodeChildren = [] + , sourcedNodeInfo = SourcedNodeInfo mempty + } -- | Name of CSS file in output directory. srcCssFile :: FilePath diff --git a/src/Haddock/Backends/Hyperlinker/Ast.hs b/src/Haddock/Backends/Hyperlinker/Ast.hs deleted file mode 100644 --- a/src/Haddock/Backends/Hyperlinker/Ast.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - - -module Haddock.Backends.Hyperlinker.Ast (enrich) where - - -import Haddock.Syb -import Haddock.Backends.Hyperlinker.Types - -import qualified GHC - -import Control.Applicative -import Data.Data -import Data.Maybe - - --- | Add more detailed information to token stream using GHC API. -enrich :: GHC.RenamedSource -> [Token] -> [RichToken] -enrich src = - map $ \token -> RichToken - { rtkToken = token - , rtkDetails = enrichToken token detailsMap - } - where - detailsMap = concatMap ($ src) - [ variables - , types - , decls - , binds - , imports - ] - --- | A map containing association between source locations and "details" of --- this location. --- --- For the time being, it is just a list of pairs. However, looking up things --- in such structure has linear complexity. We cannot use any hashmap-like --- stuff because source locations are not ordered. In the future, this should --- be replaced with interval tree data structure. -type DetailsMap = [(GHC.SrcSpan, TokenDetails)] - -lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) - -enrichToken :: Token -> DetailsMap -> Maybe TokenDetails -enrichToken (Token typ _ spn) dm - | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm -enrichToken _ _ = Nothing - --- | Obtain details map for variables ("normally" used identifiers). -variables :: GHC.RenamedSource -> DetailsMap -variables = - everything (<|>) (var `combine` rec) - where - var term = case cast term of - (Just (GHC.L sspan (GHC.HsVar name))) -> - pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> - pure (sspan, RtkVar name) - _ -> empty - rec term = case cast term of - Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) -> - pure (sspan, RtkVar name) - _ -> empty - --- | Obtain details map for types. -types :: GHC.RenamedSource -> DetailsMap -types = - everything (<|>) ty - where - ty term = case cast term of - (Just (GHC.L sspan (GHC.HsTyVar name))) -> - pure (sspan, RtkType (GHC.unLoc name)) - _ -> empty - --- | Obtain details map for identifier bindings. --- --- That includes both identifiers bound by pattern matching or declared using --- ordinary assignment (in top-level declarations, let-expressions and where --- clauses). -binds :: GHC.RenamedSource -> DetailsMap -binds = - everything (<|>) (fun `combine` pat `combine` tvar) - where - fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> - pure (sspan, RtkBind name) - _ -> empty - pat term = case cast term of - (Just (GHC.L sspan (GHC.VarPat name))) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> - [(sspan, RtkVar name)] ++ everything (<|>) rec recs - (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> - pure (sspan, RtkBind name) - _ -> empty - rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> - pure (sspan, RtkVar name) - _ -> empty - tvar term = case cast term of - (Just (GHC.L sspan (GHC.UserTyVar name))) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> - pure (sspan, RtkBind name) - _ -> empty - --- | Obtain details map for top-level declarations. -decls :: GHC.RenamedSource -> DetailsMap -decls (group, _, _, _) = concatMap ($ group) - [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everything (<|>) fun . GHC.hs_valds - , everything (<|>) (con `combine` ins) - ] - where - typ (GHC.L _ t) = case t of - GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ -> pure . decl $ name - GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam - GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs - fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) - | GHC.isExternalName name -> pure (sspan, RtkDecl name) - _ -> empty - con term = case cast term of - (Just cdcl) -> - map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl - Nothing -> empty - ins term = case cast term of - (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> - pure . tyref $ GHC.tfe_tycon eqn - _ -> empty - fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.Name) - -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field - Nothing -> empty - sig (GHC.L _ (GHC.TypeSig names _)) = map decl names - sig _ = [] - decl (GHC.L sspan name) = (sspan, RtkDecl name) - tyref (GHC.L sspan name) = (sspan, RtkType name) - --- | Obtain details map for import declarations. --- --- This map also includes type and variable details for items in export and --- import lists. -imports :: GHC.RenamedSource -> DetailsMap -imports src@(_, imps, _, _) = - everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps - where - ie term = case cast term of - (Just (GHC.IEVar v)) -> pure $ var v - (Just (GHC.IEThingAbs t)) -> pure $ typ t - (Just (GHC.IEThingAll t)) -> pure $ typ t - (Just (GHC.IEThingWith t _ vs _fls)) -> - [typ t] ++ map var vs - _ -> empty - typ (GHC.L sspan name) = (sspan, RtkType name) - var (GHC.L sspan name) = (sspan, RtkVar name) - imp idecl | not . GHC.ideclImplicit $ idecl = - let (GHC.L sspan name) = GHC.ideclName idecl - in Just (sspan, RtkModule name) - imp _ = Nothing - --- | Check whether token stream span matches GHC source span. --- --- Currently, it is implemented as checking whether "our" span is contained --- in GHC span. The reason for that is because GHC span are generally wider --- and may spread across couple tokens. For example, @(>>=)@ consists of three --- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable --- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@ --- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span --- associated with @quux@ contains all five elements. -matches :: Span -> GHC.SrcSpan -> Bool -matches tspan (GHC.RealSrcSpan aspan) - | saspan <= stspan && etspan <= easpan = True - where - stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan) - etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan) - saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) - easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) -matches _ _ = False diff --git a/src/Haddock/Backends/Hyperlinker/Parser.hs b/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,214 +1,406 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Control.Applicative ( Alternative(..) ) +import Data.List ( isPrefixOf, isSuffixOf ) -import Data.Char -import Data.List -import Data.Maybe +import qualified Data.ByteString as BS -import Haddock.Backends.Hyperlinker.Types +import GHC.Platform +import GHC.Types.SourceText +import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic +import GHC.Utils.Error ( pprLocMsgEnvelopeDefault ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Parser.Errors.Ppr () +import qualified GHC.Types.Error as E +import GHC.Parser.Lexer as Lexer + ( P(..), ParseResult(..), PState(..), Token(..) + , initParserState, lexer, mkParserOpts, getPsErrorMessages) +import GHC.Data.Bag ( bagToList ) +import GHC.Utils.Outputable ( text, ($$) ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr ( showSDoc ) +import GHC.Types.SrcLoc +import GHC.Data.StringBuffer ( StringBuffer, atEnd ) +import Haddock.Backends.Hyperlinker.Types as T +import Haddock.GhcUtils -- | Turn source code string into a stream of more descriptive tokens. -- --- Result should retain original file layout (including comments, whitespace, --- etc.), i.e. the following "law" should hold: --- --- @concat . map 'tkValue' . 'parse' = id@ -parse :: String -> [Token] -parse = tokenize . tag . chunk - --- | Split raw source string to more meaningful chunks. --- --- This is the initial stage of tokenization process. Each chunk is either --- a comment (including comment delimiters), a whitespace string, preprocessor --- macro (and all its content until the end of a line) or valid Haskell lexeme. -chunk :: String -> [String] -chunk [] = [] -chunk str@(c:_) - | isSpace c = - let (space, mcpp, rest) = spanSpaceOrCpp str - in [space] ++ maybeToList mcpp ++ chunk rest -chunk str - | "--" `isPrefixOf` str = chunk' $ spanToNewline str - | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str - | otherwise = case lex' str of - (tok:_) -> chunk' tok - [] -> [str] +-- Result should retain original file layout (including comments, +-- whitespace, and CPP). +parse + :: DynFlags -- ^ Flags for this module + -> FilePath -- ^ Path to the source of this module + -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module + -> [T.Token] +parse dflags fpath bs = case unP (go False []) initState of + POk _ toks -> reverse toks + PFailed pst -> + let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in + panic $ showSDoc dflags $ + text "Hyperlinker parse error:" $$ pprLocMsgEnvelopeDefault err where - chunk' (c, rest) = c:(chunk rest) --- | A bit better lexer then the default, i.e. handles DataKinds quotes -lex' :: ReadS String -lex' ('\'' : '\'' : rest) = [("''", rest)] -lex' str@('\'' : '\\' : _ : '\'' : _) = lex str -lex' str@('\'' : _ : '\'' : _) = lex str -lex' ('\'' : rest) = [("'", rest)] -lex' str = lex str + initState = initParserState pflags buf start + buf = stringBufferFromByteString bs + start = mkRealSrcLoc (mkFastString fpath) 1 1 + arch_os = platformArchOS (targetPlatform dflags) + pflags = mkParserOpts (extensionFlags dflags) + (initDiagOpts dflags) + (supportedLanguagesAndExtensions arch_os) + (safeImportsOn dflags) + False -- lex Haddocks as comment tokens + True -- produce comment tokens + False -- produce position pragmas tokens --- | Split input to "first line" string and the rest of it. --- --- Ideally, this should be done simply with @'break' (== '\n')@. However, --- Haskell also allows line-unbreaking (or whatever it is called) so things --- are not as simple and this function deals with that. -spanToNewline :: String -> (String, String) -spanToNewline [] = ([], []) -spanToNewline ('\\':'\n':str) = - let (str', rest) = spanToNewline str - in ('\\':'\n':str', rest) -spanToNewline str@('\n':_) = ("", str) -spanToNewline (c:str) = - let (str', rest) = spanToNewline str - in (c:str', rest) + go :: Bool -- ^ are we currently in a pragma? + -> [T.Token] -- ^ tokens accumulated so far (in reverse) + -> P [T.Token] + go inPrag toks = do + (b, _) <- getInput + if not (atEnd b) + then do + mtok <- runMaybeT (parseCppLine <|> parsePlainTok inPrag) + (newToks, inPrag') <- case mtok of + Nothing -> unknownLine + Just a -> pure a + go inPrag' (newToks ++ toks) + else + pure toks --- | Split input to whitespace string, (optional) preprocessor directive and --- the rest of it. --- --- Again, using something like @'span' 'isSpace'@ would be nice to chunk input --- to whitespace. The problem is with /#/ symbol - if it is placed at the very --- beginning of a line, it should be recognized as preprocessor macro. In any --- other case, it is ordinary Haskell symbol and can be used to declare --- operators. Hence, while dealing with whitespace we also check whether there --- happens to be /#/ symbol just after a newline character - if that is the --- case, we begin treating the whole line as preprocessor macro. -spanSpaceOrCpp :: String -> (String, Maybe String, String) -spanSpaceOrCpp ('\n':'#':str) = - let (str', rest) = spanToNewline str - in ("\n", Just $ '#':str', rest) -spanSpaceOrCpp (c:str') - | isSpace c = - let (space, mcpp, rest) = spanSpaceOrCpp str' - in (c:space, mcpp, rest) -spanSpaceOrCpp str = ("", Nothing, str) + -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens + wrappedLexer :: P (RealLocated Lexer.Token) + wrappedLexer = Lexer.lexer False andThen + where andThen (L (RealSrcSpan s _) t) + | srcSpanStartLine s /= srcSpanEndLine s || + srcSpanStartCol s /= srcSpanEndCol s + = pure (L s t) + andThen (L (RealSrcSpan s _) ITeof) = pure (L s ITeof) + andThen _ = wrappedLexer --- | Split input to comment content (including delimiters) and the rest. --- --- Again, some more logic than simple 'span' is required because of Haskell --- comment nesting policy. -chunkComment :: Int -> String -> (String, String) -chunkComment _ [] = ("", "") -chunkComment depth ('{':'-':str) = - let (c, rest) = chunkComment (depth + 1) str - in ("{-" ++ c, rest) -chunkComment depth ('-':'}':str) - | depth == 1 = ("-}", str) - | otherwise = - let (c, rest) = chunkComment (depth - 1) str - in ("-}" ++ c, rest) -chunkComment depth (e:str) = - let (c, rest) = chunkComment depth str - in (e:c, rest) + -- | Try to parse a CPP line (can fail) + parseCppLine :: MaybeT P ([T.Token], Bool) + parseCppLine = MaybeT $ do + (b, l) <- getInput + case tryCppLine l b of + Just (cppBStr, l', b') + -> let cppTok = T.Token { tkType = TkCpp + , tkValue = cppBStr + , tkSpan = mkRealSrcSpan l l' } + in setInput (b', l') *> pure (Just ([cppTok], False)) + _ -> return Nothing --- | Assign source location for each chunk in given stream. -tag :: [String] -> [(Span, String)] -tag = - reverse . snd . foldl aux (Position 1 1, []) - where - aux (pos, cs) str = - let pos' = foldl move pos str - in (pos', (Span pos pos', str):cs) - move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } - move pos _ = pos { posCol = posCol pos + 1 } + -- | Try to parse a regular old token (can fail) + parsePlainTok :: Bool -> MaybeT P ([T.Token], Bool) -- return list is only ever 0-2 elements + parsePlainTok inPrag = do + (bInit, lInit) <- lift getInput + L sp tok <- tryP (Lexer.lexer False return) + (bEnd, _) <- lift getInput + case sp of + UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed + RealSrcSpan rsp _ -> do + let typ = if inPrag then TkPragma else classify tok + RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real + (spaceBStr, bStart) = spanPosition lInit lStart bInit + inPragDef = inPragma inPrag tok --- | Turn unrecognised chunk stream to more descriptive token stream. -tokenize :: [(Span, String)] -> [Token] -tokenize = - map aux - where - aux (sp, str) = Token - { tkType = classify str - , tkValue = str - , tkSpan = sp - } + (bEnd', inPrag') <- case tok of --- | Classify given string as appropriate Haskell token. --- --- This method is based on Haskell 98 Report lexical structure description: --- https://www.haskell.org/onlinereport/lexemes.html --- --- However, this is probably far from being perfect and most probably does not --- handle correctly all corner cases. -classify :: String -> TokenType -classify str - | "--" `isPrefixOf` str = TkComment - | "{-#" `isPrefixOf` str = TkPragma - | "{-" `isPrefixOf` str = TkComment -classify "''" = TkSpecial -classify "'" = TkSpecial -classify str@(c:_) - | isSpace c = TkSpace - | isDigit c = TkNumber - | c `elem` special = TkSpecial - | str `elem` glyphs = TkGlyph - | all (`elem` symbols) str = TkOperator - | c == '#' = TkCpp - | c == '"' = TkString - | c == '\'' = TkChar -classify str - | str `elem` keywords = TkKeyword - | isIdentifier str = TkIdentifier - | otherwise = TkUnknown + -- Update internal line + file position if this is a LINE pragma + ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL { il_value = line })) <- tryP wrappedLexer + L _ (ITstring _ file) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer -keywords :: [String] -keywords = - [ "as" - , "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "else" - , "hiding" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "qualified" - , "then" - , "type" - , "where" - , "forall" - , "family" - , "mdo" - ] + let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) -glyphs :: [String] -glyphs = - [ ".." - , ":" - , "::" - , "=" - , "\\" - , "|" - , "<-" - , "->" - , "@" - , "~" - , "~#" - , "=>" - , "-" - , "!" - ] + pure (bEnd'', False) -special :: [Char] -special = "()[]{},;`" + -- Update internal column position if this is a COLUMN pragma + ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL { il_value = col })) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer --- TODO: Add support for any Unicode symbol or punctuation. --- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators -symbols :: [Char] -symbols = "!#$%&*+./<=>?@\\^|-~:" + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) -isIdentifier :: String -> Bool -isIdentifier (s:str) - | (isLower' s || isUpper s) && all isAlphaNum' str = True - where - isLower' c = isLower c || c == '_' - isAlphaNum' c = isAlphaNum c || c == '_' || c == '\'' -isIdentifier _ = False + pure (bEnd'', False) + + _ -> pure (bEnd, inPragDef) + + let tokBStr = splitStringBuffer bStart bEnd' + plainTok = T.Token { tkType = typ + , tkValue = tokBStr + , tkSpan = rsp } + spaceTok = T.Token { tkType = TkSpace + , tkValue = spaceBStr + , tkSpan = mkRealSrcSpan lInit lStart } + + pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag') + + -- | Parse whatever remains of the line as an unknown token (can't fail) + unknownLine :: P ([T.Token], Bool) + unknownLine = do + (b, l) <- getInput + let (unkBStr, l', b') = spanLine l b + unkTok = T.Token { tkType = TkUnknown + , tkValue = unkBStr + , tkSpan = mkRealSrcSpan l l' } + setInput (b', l') + pure ([unkTok], False) + + +-- | Get the input +getInput :: P (StringBuffer, RealSrcLoc) +getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, psRealLoc srcLoc) + +-- | Set the input +setInput :: (StringBuffer, RealSrcLoc) -> P () +setInput (buf, srcLoc) = + P $ \p@PState{ loc = PsLoc _ buf_loc } -> + POk (p { buffer = buf, loc = PsLoc srcLoc buf_loc }) () + +tryP :: P a -> MaybeT P a +tryP (P f) = MaybeT $ P $ \s -> case f s of + POk s' a -> POk s' (Just a) + PFailed _ -> POk s Nothing + +tryOrElse :: Alternative f => a -> f a -> f a +tryOrElse x p = p <|> pure x + +-- | Classify given tokens as appropriate Haskell token type. +classify :: Lexer.Token -> TokenType +classify tok = + case tok of + ITas -> TkKeyword + ITcase -> TkKeyword + ITclass -> TkKeyword + ITdata -> TkKeyword + ITdefault -> TkKeyword + ITderiving -> TkKeyword + ITdo {} -> TkKeyword + ITelse -> TkKeyword + IThiding -> TkKeyword + ITforeign -> TkKeyword + ITif -> TkKeyword + ITimport -> TkKeyword + ITin -> TkKeyword + ITinfix -> TkKeyword + ITinfixl -> TkKeyword + ITinfixr -> TkKeyword + ITinstance -> TkKeyword + ITlet -> TkKeyword + ITmodule -> TkKeyword + ITnewtype -> TkKeyword + ITof -> TkKeyword + ITqualified -> TkKeyword + ITthen -> TkKeyword + ITtype -> TkKeyword + ITvia -> TkKeyword + ITwhere -> TkKeyword + + ITforall {} -> TkKeyword + ITexport -> TkKeyword + ITlabel -> TkKeyword + ITdynamic -> TkKeyword + ITsafe -> TkKeyword + ITinterruptible -> TkKeyword + ITunsafe -> TkKeyword + ITstdcallconv -> TkKeyword + ITccallconv -> TkKeyword + ITcapiconv -> TkKeyword + ITprimcallconv -> TkKeyword + ITjavascriptcallconv -> TkKeyword + ITmdo {} -> TkKeyword + ITfamily -> TkKeyword + ITrole -> TkKeyword + ITgroup -> TkKeyword + ITby -> TkKeyword + ITusing -> TkKeyword + ITpattern -> TkKeyword + ITstatic -> TkKeyword + ITstock -> TkKeyword + ITanyclass -> TkKeyword + + ITunit -> TkKeyword + ITsignature -> TkKeyword + ITdependency -> TkKeyword + ITrequires -> TkKeyword + + ITinline_prag {} -> TkPragma + ITopaque_prag {} -> TkPragma + ITspec_prag {} -> TkPragma + ITspec_inline_prag {} -> TkPragma + ITsource_prag {} -> TkPragma + ITrules_prag {} -> TkPragma + ITwarning_prag {} -> TkPragma + ITdeprecated_prag {} -> TkPragma + ITline_prag {} -> TkPragma + ITcolumn_prag {} -> TkPragma + ITscc_prag {} -> TkPragma + ITunpack_prag {} -> TkPragma + ITnounpack_prag {} -> TkPragma + ITann_prag {} -> TkPragma + ITcomplete_prag {} -> TkPragma + ITclose_prag -> TkPragma + IToptions_prag {} -> TkPragma + ITinclude_prag {} -> TkPragma + ITlanguage_prag -> TkPragma + ITminimal_prag {} -> TkPragma + IToverlappable_prag {} -> TkPragma + IToverlapping_prag {} -> TkPragma + IToverlaps_prag {} -> TkPragma + ITincoherent_prag {} -> TkPragma + ITctype {} -> TkPragma + + ITdotdot -> TkGlyph + ITcolon -> TkGlyph + ITdcolon {} -> TkGlyph + ITequal -> TkGlyph + ITlam -> TkGlyph + ITlcase -> TkGlyph + ITlcases -> TkGlyph + ITvbar -> TkGlyph + ITlarrow {} -> TkGlyph + ITrarrow {} -> TkGlyph + ITlolly {} -> TkGlyph + ITat -> TkGlyph + ITtilde -> TkGlyph + ITdarrow {} -> TkGlyph + ITminus -> TkGlyph + ITprefixminus -> TkGlyph + ITbang -> TkGlyph + ITdot -> TkOperator + ITproj {} -> TkOperator + ITstar {} -> TkOperator + ITtypeApp -> TkGlyph + ITpercent -> TkGlyph + + ITbiglam -> TkGlyph + + ITocurly -> TkSpecial + ITccurly -> TkSpecial + ITvocurly -> TkSpecial + ITvccurly -> TkSpecial + ITobrack -> TkSpecial + ITopabrack -> TkSpecial + ITcpabrack -> TkSpecial + ITcbrack -> TkSpecial + IToparen -> TkSpecial + ITcparen -> TkSpecial + IToubxparen -> TkSpecial + ITcubxparen -> TkSpecial + ITsemi -> TkSpecial + ITcomma -> TkSpecial + ITunderscore -> TkIdentifier + ITbackquote -> TkSpecial + ITsimpleQuote -> TkSpecial + + ITvarid {} -> TkIdentifier + ITconid {} -> TkIdentifier + ITvarsym {} -> TkOperator + ITconsym {} -> TkOperator + ITqvarid {} -> TkIdentifier + ITqconid {} -> TkIdentifier + ITqvarsym {} -> TkOperator + ITqconsym {} -> TkOperator + + ITdupipvarid {} -> TkUnknown + ITlabelvarid {} -> TkUnknown + + ITchar {} -> TkChar + ITstring {} -> TkString + ITinteger {} -> TkNumber + ITrational {} -> TkNumber + + ITprimchar {} -> TkChar + ITprimstring {} -> TkString + ITprimint {} -> TkNumber + ITprimword {} -> TkNumber + ITprimfloat {} -> TkNumber + ITprimdouble {} -> TkNumber + + ITopenExpQuote {} -> TkSpecial + ITopenPatQuote -> TkSpecial + ITopenDecQuote -> TkSpecial + ITopenTypQuote -> TkSpecial + ITcloseQuote {} -> TkSpecial + ITopenTExpQuote {} -> TkSpecial + ITcloseTExpQuote -> TkSpecial + ITdollar -> TkSpecial + ITdollardollar -> TkSpecial + ITtyQuote -> TkSpecial + ITquasiQuote {} -> TkUnknown + ITqQuasiQuote {} -> TkUnknown + + ITproc -> TkKeyword + ITrec -> TkKeyword + IToparenbar {} -> TkGlyph + ITcparenbar {} -> TkGlyph + ITlarrowtail {} -> TkGlyph + ITrarrowtail {} -> TkGlyph + ITLarrowtail {} -> TkGlyph + ITRarrowtail {} -> TkGlyph + + ITcomment_line_prag -> TkUnknown + ITunknown {} -> TkUnknown + ITeof -> TkUnknown + + ITlineComment {} -> TkComment + ITdocComment {} -> TkComment + ITdocOptions {} -> TkComment + + -- The lexer considers top-level pragmas as comments (see `pragState` in + -- the GHC lexer for more), so we have to manually reverse this. The + -- following is a hammer: it smashes _all_ pragma-like block comments into + -- pragmas. + ITblockComment c _ + | isPrefixOf "{-#" c + , isSuffixOf "#-}" c -> TkPragma + | otherwise -> TkComment + +-- | Classify given tokens as beginning pragmas (or not). +inPragma :: Bool -- ^ currently in pragma + -> Lexer.Token -- ^ current token + -> Bool -- ^ new information about whether we are in a pragma +inPragma _ ITclose_prag = False +inPragma True _ = True +inPragma False tok = + case tok of + ITinline_prag {} -> True + ITopaque_prag {} -> True + ITspec_prag {} -> True + ITspec_inline_prag {} -> True + ITsource_prag {} -> True + ITrules_prag {} -> True + ITwarning_prag {} -> True + ITdeprecated_prag {} -> True + ITline_prag {} -> True + ITcolumn_prag {} -> True + ITscc_prag {} -> True + ITunpack_prag {} -> True + ITnounpack_prag {} -> True + ITann_prag {} -> True + ITcomplete_prag {} -> True + IToptions_prag {} -> True + ITinclude_prag {} -> True + ITlanguage_prag -> True + ITminimal_prag {} -> True + IToverlappable_prag {} -> True + IToverlapping_prag {} -> True + IToverlaps_prag {} -> True + ITincoherent_prag {} -> True + ITctype {} -> True + + _ -> False + diff --git a/src/Haddock/Backends/Hyperlinker/Renderer.hs b/src/Haddock/Backends/Hyperlinker/Renderer.hs --- a/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -7,16 +9,21 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import qualified GHC -import qualified Name as GHC -import qualified Unique as GHC +import qualified Data.ByteString as BS +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo ) +import GHC.Unit.Module ( ModuleName, moduleNameString ) +import GHC.Types.Name ( getOccString, isInternalName, Name, nameModule, nameUnique ) +import GHC.Types.SrcLoc +import GHC.Types.Unique ( getKey ) +import GHC.Utils.Encoding ( utf8DecodeByteString ) + import System.FilePath.Posix (()) -import Data.List -import Data.Maybe -import Data.Monoid import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List as List import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html @@ -24,48 +31,24 @@ type StyleClass = String - -render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] - -> Html -render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens - - -data TokenGroup - = GrpNormal Token - | GrpRich TokenDetails [Token] - - --- | Group consecutive tokens pointing to the same element. --- --- We want to render qualified identifiers as one entity. For example, --- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for --- better user experience when highlighting and clicking links, these tokens --- should be regarded as one identifier. Therefore, before rendering we must --- group consecutive elements pointing to the same 'GHC.Name' (note that even --- dot token has it if it is part of qualified name). -groupTokens :: [RichToken] -> [TokenGroup] -groupTokens [] = [] -groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest) -groupTokens ((RichToken tok (Just det)):rest) = - let (grp, rest') = span same rest - in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest') - where - same (RichToken _ (Just det')) = det == det' - same _ = False - +-- | Produce the HTML corresponding to a hyperlinked Haskell source +render + :: Maybe FilePath -- ^ path to the CSS file + -> Maybe FilePath -- ^ path to the JS file + -> SrcMaps -- ^ Paths to sources + -> HieAST PrintedType -- ^ ASTs from @.hie@ files + -> [Token] -- ^ tokens to render + -> Html +render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens -body :: SrcMap -> [RichToken] -> Html -body srcs tokens = - Html.body . Html.pre $ hypsrc +body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +body srcs ast tokens = Html.body . Html.pre $ hypsrc where - hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens - + hypsrc = renderWithAst srcs ast tokens header :: Maybe FilePath -> Maybe FilePath -> Html -header mcss mjs - | isNothing mcss && isNothing mjs = Html.noHtml -header mcss mjs = - Html.header $ css mcss <> js mjs +header Nothing Nothing = Html.noHtml +header mcss mjs = Html.header $ css mcss <> js mjs where css Nothing = Html.noHtml css (Just cssFile) = Html.thelink Html.noHtml ! @@ -80,34 +63,137 @@ ] -tokenGroup :: SrcMap -> TokenGroup -> Html -tokenGroup _ (GrpNormal tok@(Token { .. })) - | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue - | otherwise = tokenSpan tok ! attrs +splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token]) +splitTokens ast toks = (before,during,after) where - attrs = [ multiclass . tokenStyle $ tkType ] -tokenGroup srcs (GrpRich det tokens) = - externalAnchor det . internalAnchor det . hyperlink srcs det $ content + (before,rest) = span leftOf toks + (during,after) = span inAst rest + leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp + inAst t = nodeSp `containsSpan` tkSpan t + nodeSp = nodeSpan ast + +-- | Turn a list of tokens into hyperlinked sources, threading in relevant link +-- information from the 'HieAST'. +renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html +renderWithAst srcs Node{..} toks = anchored $ case toks of + + [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok + + -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators + -- as multiple tokens. + -- + -- * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens) + -- * @(+) 1 2@ turns into @[(, +, ), 1, 2]@ (excluding space tokens) + -- + -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In + -- order to make sure these get hyperlinked properly, we intercept these + -- special sequences of tokens and merge them into just one identifier or + -- operator token. + [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2] + | realSrcSpanStart s1 == realSrcSpanStart nodeSpan + , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan + -> richToken srcs nodeInfo + (Token{ tkValue = "`" <> tkValue tok <> "`" + , tkType = TkOperator + , tkSpan = nodeSpan }) + [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2] + | realSrcSpanStart s1 == realSrcSpanStart nodeSpan + , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan + -> richToken srcs nodeInfo + (Token{ tkValue = "(" <> tkValue tok <> ")" + , tkType = TkOperator + , tkSpan = nodeSpan }) + + _ -> go nodeChildren toks where - content = mconcat . map (richToken det) $ tokens + nodeInfo = maybe emptyNodeInfo id (Map.lookup SourceInfo $ getSourcedNodeInfo sourcedNodeInfo) + go _ [] = mempty + go [] xs = foldMap renderToken xs + go (cur:rest) xs = + foldMap renderToken before <> renderWithAst srcs cur during <> go rest after + where + (before,during,after) = splitTokens cur xs + anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) + anchorOne n dets c = externalAnchor n d $ internalAnchor n d c + where d = identInfo dets +renderToken :: Token -> Html +renderToken Token{..} + | BS.null tkValue = mempty + | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' + | otherwise = tokenSpan ! [ multiclass style ] + where + tkValue' = filterCRLF $ utf8DecodeByteString tkValue + style = tokenStyle tkType + tokenSpan = Html.thespan (Html.toHtml tkValue') -richToken :: TokenDetails -> Token -> Html -richToken det tok = - tokenSpan tok ! [ multiclass style ] + +-- | Given information about the source position of definitions, render a token +richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken srcs details Token{..} + | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' + | otherwise = annotate details $ linked content where - style = (tokenStyle . tkType) tok ++ richTokenStyle det + tkValue' = filterCRLF $ utf8DecodeByteString tkValue + content = tokenSpan ! [ multiclass style ] + tokenSpan = Html.thespan (Html.toHtml tkValue') + style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts + contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details -tokenSpan :: Token -> Html -tokenSpan = Html.thespan . Html.toHtml . tkValue + -- pick an arbitrary non-evidence identifier to hyperlink with + identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details + notEvidence = not . any isEvidenceContext . identInfo + -- If we have name information, we can make links + linked = case identDet of + Just (n,_) -> hyperlink srcs n + Nothing -> id -richTokenStyle :: TokenDetails -> [StyleClass] -richTokenStyle (RtkVar _) = ["hs-var"] -richTokenStyle (RtkType _) = ["hs-type"] -richTokenStyle _ = [] +-- | Remove CRLFs from source +filterCRLF :: String -> String +filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs +filterCRLF (c:cs) = c : filterCRLF cs +filterCRLF [] = [] +annotate :: NodeInfo PrintedType -> Html -> Html +annotate ni content = + Html.thespan (annot <> content) ! [ Html.theclass "annot" ] + where + annot + | not (null annotation) = + Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ] + | otherwise = mempty + annotation = typ ++ identTyps + typ = unlines (nodeType ni) + typedIdents = [ (n,t) | (n, c@(identType -> Just t)) <- Map.toList $ nodeIdentifiers ni + , not (any isEvidenceContext $ identInfo c) ] + identTyps + | length typedIdents > 1 || null (nodeType ni) + = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents + | otherwise = "" + + printName :: Either ModuleName Name -> String + printName = either moduleNameString getOccString + +richTokenStyle + :: Bool -- ^ are we lacking a type annotation? + -> ContextInfo -- ^ in what context did this token show up? + -> [StyleClass] +richTokenStyle True Use = ["hs-type"] +richTokenStyle False Use = ["hs-var"] +richTokenStyle _ RecField{} = ["hs-var"] +richTokenStyle _ PatternBind{} = ["hs-var"] +richTokenStyle _ MatchBind{} = ["hs-var"] +richTokenStyle _ TyVarBind{} = ["hs-type"] +richTokenStyle _ ValBind{} = ["hs-var"] +richTokenStyle _ TyDecl = ["hs-type"] +richTokenStyle _ ClassTyDecl{} = ["hs-type"] +richTokenStyle _ Decl{} = ["hs-var"] +richTokenStyle _ IEThing{} = [] -- could be either a value or type +richTokenStyle _ EvidenceVarBind{} = [] +richTokenStyle _ EvidenceVarUse{} = [] + tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] tokenStyle TkKeyword = ["hs-keyword"] @@ -124,59 +210,78 @@ tokenStyle TkUnknown = [] multiclass :: [StyleClass] -> HtmlAttr -multiclass = Html.theclass . intercalate " " +multiclass = Html.theclass . unwords -externalAnchor :: TokenDetails -> Html -> Html -externalAnchor (RtkDecl name) content = - Html.anchor content ! [ Html.name $ externalAnchorIdent name ] -externalAnchor _ content = content +externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html +externalAnchor (Right name) contexts content + | not (isInternalName name) + , any isBinding contexts + = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ] +externalAnchor _ _ content = content -internalAnchor :: TokenDetails -> Html -> Html -internalAnchor (RtkBind name) content = - Html.anchor content ! [ Html.name $ internalAnchorIdent name ] -internalAnchor _ content = content +isBinding :: ContextInfo -> Bool +isBinding (ValBind RegularBind _ _) = True +isBinding PatternBind{} = True +isBinding Decl{} = True +isBinding (RecField RecFieldDecl _) = True +isBinding TyVarBind{} = True +isBinding ClassTyDecl{} = True +isBinding _ = False -externalAnchorIdent :: GHC.Name -> String -externalAnchorIdent = hypSrcNameUrl +internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html +internalAnchor (Right name) contexts content + | isInternalName name + , any isBinding contexts + = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ] +internalAnchor _ _ content = content -internalAnchorIdent :: GHC.Name -> String -internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique +externalAnchorIdent :: Name -> String +externalAnchorIdent = hypSrcNameUrl -hyperlink :: SrcMap -> TokenDetails -> Html -> Html -hyperlink srcs details = case rtkName details of - Left name -> - if GHC.isInternalName name - then internalHyperlink name - else externalNameHyperlink srcs name - Right name -> externalModHyperlink srcs name +internalAnchorIdent :: Name -> String +internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique -internalHyperlink :: GHC.Name -> Html -> Html -internalHyperlink name content = - Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] +-- | Generate the HTML hyperlink for an identifier +hyperlink :: SrcMaps -> Identifier -> Html -> Html +hyperlink (srcs, srcs') ident = case ident of + Right name | isInternalName name -> internalHyperlink name + | otherwise -> externalNameHyperlink name + Left name -> externalModHyperlink name -externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of - Just SrcLocal -> Html.anchor content ! - [ Html.href $ hypSrcModuleNameUrl mdl name ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ path hypSrcModuleNameUrl mdl name ] - Nothing -> content where - mdl = GHC.nameModule name + -- In a Nix environment, we have file:// URLs with absolute paths + makeHyperlinkUrl url | List.isPrefixOf "file://" url = url + makeHyperlinkUrl url = ".." url -externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html -externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of - Just SrcLocal -> Html.anchor content ! - [ Html.href $ hypSrcModuleUrl' name ] - Just (SrcExternal path) -> Html.anchor content ! - [ Html.href $ path hypSrcModuleUrl' name ] - Nothing -> content + internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] + externalNameHyperlink name content = case Map.lookup mdl srcs of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleNameUrl mdl name ] + Just (SrcExternal path) -> + let hyperlinkUrl = makeHyperlinkUrl path hypSrcModuleNameUrl mdl name + in Html.anchor content ! + [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing hyperlinkUrl ] + Nothing -> content + where + mdl = nameModule name + externalModHyperlink moduleName content = + case Map.lookup moduleName srcs' of + Just SrcLocal -> Html.anchor content ! + [ Html.href $ hypSrcModuleUrl' moduleName ] + Just (SrcExternal path) -> + let hyperlinkUrl = makeHyperlinkUrl path hypSrcModuleUrl' moduleName + in Html.anchor content ! + [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing hyperlinkUrl ] + Nothing -> content + + renderSpace :: Int -> String -> Html -renderSpace _ [] = Html.noHtml -renderSpace line ('\n':rest) = mconcat - [ Html.thespan . Html.toHtml $ "\n" +renderSpace !_ "" = Html.noHtml +renderSpace !line ('\n':rest) = mconcat + [ Html.thespan (Html.toHtml '\n') , lineAnchor (line + 1) , renderSpace (line + 1) rest ] @@ -186,4 +291,4 @@ lineAnchor :: Int -> Html -lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ] +lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ] diff --git a/src/Haddock/Backends/Hyperlinker/Types.hs b/src/Haddock/Backends/Hyperlinker/Types.hs --- a/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/src/Haddock/Backends/Hyperlinker/Types.hs @@ -1,30 +1,26 @@ +{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Types where - import qualified GHC -import Data.Map (Map) -import qualified Data.Map as Map +import Data.ByteString ( ByteString ) +import Data.Map (Map) data Token = Token { tkType :: TokenType - , tkValue :: String - , tkSpan :: Span + , tkValue :: ByteString -- ^ UTF-8 encoded + , tkSpan :: {-# UNPACK #-} !Span } deriving (Show) -data Position = Position - { posRow :: !Int - , posCol :: !Int - } - deriving (Show) +pattern BacktickTok, OpenParenTok, CloseParenTok :: Span -> Token +pattern BacktickTok sp = Token TkSpecial "`" sp +pattern OpenParenTok sp = Token TkSpecial "(" sp +pattern CloseParenTok sp = Token TkSpecial ")" sp -data Span = Span - { spStart :: Position - , spEnd :: Position - } - deriving (Show) +type Position = GHC.RealSrcLoc +type Span = GHC.RealSrcSpan data TokenType = TkIdentifier @@ -42,29 +38,6 @@ | TkUnknown deriving (Show, Eq) - -data RichToken = RichToken - { rtkToken :: Token - , rtkDetails :: Maybe TokenDetails - } - -data TokenDetails - = RtkVar GHC.Name - | RtkType GHC.Name - | RtkBind GHC.Name - | RtkDecl GHC.Name - | RtkModule GHC.ModuleName - deriving (Eq) - - -rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName -rtkName (RtkVar name) = Left name -rtkName (RtkType name) = Left name -rtkName (RtkBind name) = Left name -rtkName (RtkDecl name) = Left name -rtkName (RtkModule name) = Right name - - -- | Path for making cross-package hyperlinks in generated sources. -- -- Used in 'SrcMap' to determine whether module originates in current package @@ -74,15 +47,5 @@ | SrcLocal -- | Mapping from modules to cross-package source paths. --- --- This mapping is actually a pair of maps instead of just one map. The reason --- for this is because when hyperlinking modules in import lists we have no --- 'GHC.Module' available. On the other hand, we can't just use map with --- 'GHC.ModuleName' as indices because certain modules may have common name --- but originate in different packages. Hence, we use both /rich/ and /poor/ --- versions, where the /poor/ is just projection of /rich/ one cached in pair --- for better performance. -type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) +type SrcMaps = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) -mkSrcMap :: Map GHC.Module SrcPath -> SrcMap -mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) diff --git a/src/Haddock/Backends/Hyperlinker/Utils.hs b/src/Haddock/Backends/Hyperlinker/Utils.hs --- a/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Utils ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile' , hypSrcModuleUrl, hypSrcModuleUrl' @@ -6,21 +7,35 @@ , hypSrcModuleNameUrl, hypSrcModuleLineUrl , hypSrcModuleUrlFormat , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat - ) where + , spliceURL, spliceURL' + -- * HIE file processing + , PrintedType + , recoverFullIfaceTypes + ) where +import Haddock.Utils import Haddock.Backends.Xhtml.Utils import GHC -import FastString -import System.FilePath.Posix (()) +import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) +import GHC.Iface.Type +import GHC.Types.Name ( getOccFS, getOccString ) +import GHC.Driver.Ppr ( showSDoc ) +import GHC.Types.Var ( VarBndr(..), visArg, invisArg, TypeOrConstraint(..) ) +import System.FilePath.Posix ((), (<.>)) +import qualified Data.Array as A + + +{-# INLINE hypSrcDir #-} hypSrcDir :: FilePath hypSrcDir = "src" +{-# INLINE hypSrcModuleFile #-} hypSrcModuleFile :: Module -> FilePath -hypSrcModuleFile = hypSrcModuleFile' . moduleName +hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html" hypSrcModuleFile' :: ModuleName -> FilePath hypSrcModuleFile' mdl = spliceURL' @@ -32,20 +47,19 @@ hypSrcModuleUrl' :: ModuleName -> String hypSrcModuleUrl' = hypSrcModuleFile' +{-# INLINE hypSrcNameUrl #-} hypSrcNameUrl :: Name -> String -hypSrcNameUrl name = spliceURL - Nothing Nothing (Just name) Nothing nameFormat +hypSrcNameUrl = escapeStr . getOccString +{-# INLINE hypSrcLineUrl #-} hypSrcLineUrl :: Int -> String -hypSrcLineUrl line = spliceURL - Nothing Nothing Nothing (Just spn) lineFormat - where - loc = mkSrcLoc nilFS line 1 - spn = mkSrcSpan loc loc +hypSrcLineUrl line = "line-" ++ show line +{-# INLINE hypSrcModuleNameUrl #-} hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +{-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line @@ -66,3 +80,65 @@ lineFormat :: String lineFormat = "line-%{LINE}" + + +-- * HIE file processing + +-- This belongs in GHC.Iface.Ext.Utils... + +-- | Pretty-printed type, ready to be turned into HTML by @xhtml@ +type PrintedType = String + +-- | Expand the flattened HIE AST into one where the types printed out and +-- ready for end-users to look at. +-- +-- Using just primitives found in GHC's HIE utilities, we could write this as +-- follows: +-- +-- > 'recoverFullIfaceTypes' dflags hieTypes hieAst +-- > = 'fmap' (\ti -> 'showSDoc' df . +-- > 'pprIfaceType' $ +-- > 'recoverFullType' ti hieTypes) +-- > hieAst +-- +-- However, this is very inefficient (both in time and space) because the +-- multiple calls to 'recoverFullType' don't share intermediate results. This +-- function fixes that. +recoverFullIfaceTypes + :: DynFlags + -> A.Array TypeIndex HieTypeFlat -- ^ flat types + -> HieAST TypeIndex -- ^ flattened AST + -> HieAST PrintedType -- ^ full AST +recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast + where + + -- Splitting this out into its own array is also important: we don't want + -- to pretty print the same type many times + printed :: A.Array TypeIndex PrintedType + printed = fmap (showSDoc df . pprIfaceType) unflattened + + -- The recursion in 'unflattened' is crucial - it's what gives us sharing + -- between the IfaceType's produced + unflattened :: A.Array TypeIndex IfaceType + unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened + + -- Unfold an 'HieType' whose subterms have already been unfolded + go :: HieType IfaceType -> IfaceType + go (HTyVarTy n) = IfaceTyVar (getOccFS n) + go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) + in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t + go (HFunTy w a b) = IfaceFunTy (visArg TypeLike) w a b -- t1 -> t2 + go (HQualTy con b) = IfaceFunTy (invisArg TypeLike) many_ty con b -- c => t + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar "" + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs + hieToIfaceArgs (HieArgs args) = go' args + where + go' [] = IA_Nil + go' ((True ,x):xs) = IA_Arg x Required $ go' xs + go' ((False,x):xs) = IA_Arg x Specified $ go' xs diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -1,1270 +1,1454 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.LaTeX --- Copyright : (c) Simon Marlow 2010, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.LaTeX ( - ppLaTeX -) where - - -import Haddock.Types -import Haddock.Utils -import Haddock.GhcUtils -import Pretty hiding (Doc, quote) -import qualified Pretty - -import GHC -import OccName -import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) -import FastString ( unpackFS, unpackLitString, zString ) -import Outputable ( panic) - -import qualified Data.Map as Map -import System.Directory -import System.FilePath -import Data.Char -import Control.Monad -import Data.Maybe -import Data.List - -import Haddock.Doc (combineDocumentation) - --- import Debug.Trace - -{- SAMPLE OUTPUT - -\haddockmoduleheading{\texttt{Data.List}} -\hrulefill -{\haddockverb\begin{verbatim} -module Data.List ( - (++), head, last, tail, init, null, length, map, reverse, - ) where\end{verbatim}} -\hrulefill - -\section{Basic functions} -\begin{haddockdesc} -\item[\begin{tabular}{@{}l} -head\ ::\ {\char 91}a{\char 93}\ ->\ a -\end{tabular}]\haddockbegindoc -Extract the first element of a list, which must be non-empty. -\par - -\end{haddockdesc} -\begin{haddockdesc} -\item[\begin{tabular}{@{}l} -last\ ::\ {\char 91}a{\char 93}\ ->\ a -\end{tabular}]\haddockbegindoc -Extract the last element of a list, which must be finite and non-empty. -\par - -\end{haddockdesc} --} - - -{- TODO - * don't forget fixity!! --} - -ppLaTeX :: String -- Title - -> Maybe String -- Package name - -> [Interface] - -> FilePath -- destination directory - -> Maybe (Doc GHC.RdrName) -- prologue text, maybe - -> Maybe String -- style file - -> FilePath - -> IO () - -ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir - = do - createDirectoryIfMissing True odir - when (isNothing maybe_style) $ - copyFile (libdir "latex" haddockSty) (odir haddockSty) - ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces - mapM_ (ppLaTeXModule title odir) visible_ifaces - - -haddockSty :: FilePath -haddockSty = "haddock.sty" - - -type LaTeX = Pretty.Doc - - -ppLaTeXTop - :: String - -> Maybe String - -> FilePath - -> Maybe (Doc GHC.RdrName) - -> Maybe String - -> [Interface] - -> IO () - -ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do - - let tex = vcat [ - text "\\documentclass{book}", - text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), - text "\\begin{document}", - text "\\begin{titlepage}", - text "\\begin{haddocktitle}", - text doctitle, - text "\\end{haddocktitle}", - case prologue of - Nothing -> empty - Just d -> vcat [text "\\begin{haddockprologue}", - rdrDocToLaTeX d, - text "\\end{haddockprologue}"], - text "\\end{titlepage}", - text "\\tableofcontents", - vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], - text "\\end{document}" - ] - - mods = sort (map (moduleBasename.ifaceMod) ifaces) - - filename = odir (fromMaybe "haddock" packageStr <.> "tex") - - writeFile filename (show tex) - - -ppLaTeXModule :: String -> FilePath -> Interface -> IO () -ppLaTeXModule _title odir iface = do - createDirectoryIfMissing True odir - let - mdl = ifaceMod iface - mdl_str = moduleString mdl - - exports = ifaceRnExportItems iface - - tex = vcat [ - text "\\haddockmoduleheading" <> braces (text mdl_str), - text "\\label{module:" <> text mdl_str <> char '}', - text "\\haddockbeginheader", - verb $ vcat [ - text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ - map exportListItem $ - filter forSummary exports), - text " ) where" - ], - text "\\haddockendheader" $$ text "", - description, - body - ] - - description - = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface - - body = processExports exports - -- - writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) - - -string_txt :: TextDetails -> String -> String -string_txt (Chr c) s = c:s -string_txt (Str s1) s2 = s1 ++ s2 -string_txt (PStr s1) s2 = unpackFS s1 ++ s2 -string_txt (ZStr s1) s2 = zString s1 ++ s2 -string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - - -exportListItem :: ExportItem DocName -> LaTeX -exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } - = sep (punctuate comma . map ppDocBinder $ declNames decl) <> - case subdocs of - [] -> empty - _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) -exportListItem (ExportNoDecl y []) - = ppDocBinder y -exportListItem (ExportNoDecl y subs) - = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) -exportListItem (ExportModule mdl) - = text "module" <+> text (moduleString mdl) -exportListItem _ - = error "exportListItem" - - --- Deal with a group of undocumented exports together, to avoid lots --- of blank vertical space between them. -processExports :: [ExportItem DocName] -> LaTeX -processExports [] = empty -processExports (decl : es) - | Just sig <- isSimpleSig decl - = multiDecl [ ppTypeSig (map getName names) typ False - | (names,typ) <- sig:sigs ] $$ - processExports es' - where (sigs, es') = spanWith isSimpleSig es -processExports (ExportModule mdl : es) - = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ - processExports es' - where (mdls, es') = spanWith isExportModule es -processExports (e : es) = - processExport e $$ processExports es - - -isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) - , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) -isSimpleSig _ = Nothing - - -isExportModule :: ExportItem DocName -> Maybe Module -isExportModule (ExportModule m) = Just m -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 (ExportNoDecl y []) - = ppDocName y -processExport (ExportNoDecl y subs) - = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) -processExport (ExportModule mdl) - = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing -processExport (ExportDoc doc) - = docToLaTeX $ _doc doc - - -ppDocGroup :: Int -> LaTeX -> LaTeX -ppDocGroup lev doc = sec lev <> braces doc - where sec 1 = text "\\section" - sec 2 = text "\\subsection" - sec 3 = text "\\subsubsection" - sec _ = text "\\paragraph" - - -declNames :: LHsDecl DocName -> [DocName] -declNames (L _ decl) = case decl of - TyClD d -> [tcdName d] - SigD (TypeSig lnames _ ) -> map unLoc lnames - SigD (PatSynSig lname _) -> [unLoc lname] - ForD (ForeignImport (L _ n) _ _ _) -> [n] - ForD (ForeignExport (L _ n) _ _ _) -> [n] - _ -> error "declaration not supported by declNames" - - -forSummary :: (ExportItem DocName) -> Bool -forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True - - -moduleLaTeXFile :: Module -> FilePath -moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" - - -moduleBasename :: Module -> FilePath -moduleBasename mdl = map (\c -> if c == '.' then '-' else c) - (moduleNameString (moduleName mdl)) - - -------------------------------------------------------------------------------- --- * Decls -------------------------------------------------------------------------------- - - -ppDecl :: LHsDecl DocName - -> DocForDecl DocName - -> [DocInstance DocName] - -> [(DocName, DocForDecl DocName)] - -> [(DocName, Fixity)] - -> LaTeX - -ppDecl (L loc decl) (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 - TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode --- Family instances happen via FamInst now --- TyClD d@(TySynonym {}) --- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode --- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) - (hsSigWcType t) unicode - SigD (PatSynSig lname ty) -> - ppLPatSig loc (doc, fnArgsDoc) lname ty unicode - ForD d -> ppFor loc (doc, fnArgsDoc) d unicode - InstD _ -> empty - _ -> error "declaration not supported by ppDecl" - where - unicode = False - - -ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> - TyClDecl DocName -> Bool -> LaTeX -ppTyFam _ _ _ _ _ = - error "type family declarations are currently not supported by --latex" - - -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = - ppFunSig loc doc [name] (hsSigType typ) unicode -ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" --- error "foreign declarations are currently not supported by --latex" - - -------------------------------------------------------------------------------- --- * Type Synonyms -------------------------------------------------------------------------------- - - --- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX - -ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars - , tcdRhs = ltype }) unicode - = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode - where - hdr = hsep (keyword "type" - : ppDocBinder name - : map ppSymName (tyvarNames ltyvars)) - full = hdr <+> char '=' <+> ppLType unicode ltype - -ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" - - -------------------------------------------------------------------------------- --- * Function signatures -------------------------------------------------------------------------------- - - -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName - -> Bool -> LaTeX -ppFunSig loc doc docnames (L _ typ) unicode = - ppTypeOrFunSig loc docnames typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names - , dcolon unicode) - unicode - where - names = map getName docnames - -ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> LHsSigType DocName - -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode - = declWithDoc pref1 (documentationToLaTeX doc) - where - pref1 = hsep [ keyword "pattern" - , ppDocBinder name - , dcolon unicode - , ppLType unicode (hsSigType ty) - ] - -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName - -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) - -> Bool -> LaTeX -ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) - unicode - | Map.null argDocs = - declWithDoc pref1 (documentationToLaTeX doc) - | otherwise = - declWithDoc pref2 $ Just $ - text "\\haddockbeginargs" $$ - do_args 0 sep0 typ $$ - text "\\end{tabulary}\\par" $$ - fromMaybe empty (documentationToLaTeX doc) - where - do_largs n leader (L _ t) = do_args n leader t - - arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - - do_args :: Int -> LaTeX -> HsType DocName -> LaTeX - do_args _n leader (HsForAllTy tvs ltype) - = decltt leader - <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) - <+> ppLType unicode ltype - do_args n leader (HsQualTy lctxt ltype) - = decltt leader - <-> ppLContextNoArrow lctxt unicode <+> nl $$ - do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy lt r) - = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ - do_largs (n+1) (arrow unicode) r - do_args n leader t - = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl - - -ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX -ppTypeSig nms ty unicode = - hsep (punctuate comma $ map ppSymName nms) - <+> dcolon unicode - <+> ppType unicode ty - - -ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarName) - - -tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit - - -declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX -declWithDoc decl doc = - text "\\begin{haddockdesc}" $$ - text "\\item[\\begin{tabular}{@{}l}" $$ - text (latexMonoFilter (show decl)) $$ - text "\\end{tabular}]" <> - (if isNothing doc then empty else text "\\haddockbegindoc") $$ - maybe empty id doc $$ - text "\\end{haddockdesc}" - - --- in a group of decls, we don't put them all in the same tabular, --- because that would prevent the group being broken over a page --- boundary (breaks Foreign.C.Error for example). -multiDecl :: [LaTeX] -> LaTeX -multiDecl decls = - text "\\begin{haddockdesc}" $$ - vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" - | decl <- decls ] $$ - text "\\end{haddockdesc}" - - -------------------------------------------------------------------------------- --- * Rendering Doc -------------------------------------------------------------------------------- - - -maybeDoc :: Maybe (Doc DocName) -> LaTeX -maybeDoc = maybe empty docToLaTeX - - --- for table cells, we strip paragraphs out to avoid extra vertical space --- and don't add a quote environment. -rDoc :: Maybe (Doc DocName) -> LaTeX -rDoc = maybeDoc . fmap latexStripTrailingWhitespace - - -------------------------------------------------------------------------------- --- * Class declarations -------------------------------------------------------------------------------- - - -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] - -> Bool -> LaTeX -ppClassHdr summ lctxt n tvs fds unicode = - keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames tvs) - <+> ppFds fds unicode - - -ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX -ppFds fds unicode = - if null fds then empty else - char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) - where - fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> - hsep (map (ppDocName . unLoc) vars2) - - -ppClassDecl :: [DocInstance DocName] -> SrcSpan - -> Documentation DocName -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> LaTeX -ppClassDecl instances loc doc subdocs - (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds - , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode - = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ - instancesBit - where - classheader - | null lsigs = hdr unicode - | otherwise = hdr unicode <+> keyword "where" - - hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds - - body = catMaybes [documentationToLaTeX doc, body_] - - body_ - | null lsigs, null ats, null at_defs = Nothing - | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" - - methodTable = - text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode - | L _ (TypeSig lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? - - instancesBit = ppDocInstances unicode instances - -ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - -ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX -ppDocInstances _unicode [] = empty -ppDocInstances unicode (i : rest) - | Just ihead <- isUndocdInstance i - = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ - ppDocInstances unicode rest' - | otherwise - = ppDocInstance unicode i $$ ppDocInstances unicode rest - where - (is, rest') = spanWith isUndocdInstance rest - -isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing,_) = Just i -isUndocdInstance _ = Nothing - --- | Print a possibly commented instance. The instance header is printed inside --- an 'argBox'. The comment is printed to the right of the box in normal comment --- style. -ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, doc, _) = - declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) - - -ppInstDecl :: Bool -> InstHead DocName -> LaTeX -ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead - - -ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode (InstHead {..}) = case ihdInstType of - ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ - TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs - DataInst _ -> error "data instances not supported by --latex yet" - where - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode - tibody = maybe empty (\t -> equals <+> ppType unicode t) - -lookupAnySubdoc :: (Eq name1) => - name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 -lookupAnySubdoc n subdocs = case lookup n subdocs of - Nothing -> noDocForDecl - Just docs -> docs - - -------------------------------------------------------------------------------- --- * Data & newtype declarations -------------------------------------------------------------------------------- - - -ppDataDecl :: [DocInstance DocName] -> - [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> - LaTeX -ppDataDecl instances subdocs _loc doc dataDecl unicode - - = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) - (if null body then Nothing else Just (vcat body)) - $$ instancesBit - - where - cons = dd_cons (tcdDataDefn dataDecl) - resTy = (unLoc . head) cons - - body = catMaybes [constrBit, doc >>= documentationToLaTeX] - - (whereBit, leaders) - | null cons = (empty,[]) - | otherwise = case resTy of - ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) - _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) - - constrBit - | null cons = Nothing - | otherwise = Just $ - text "\\haddockbeginconstrs" $$ - vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ - text "\\end{tabulary}\\par" - - instancesBit = ppDocInstances unicode instances - - --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then empty else ppForall) - <+> - (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") - where - ppForall = case forall of - True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - False -> empty - - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = - leader <-> - case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - - header_ = ppConstrHdr False tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case getConNames con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = - leader <-> - doGADTCon (hsib_body $ con_type con) - - where - doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode resTy - ) <-> rDoc mbDoc - - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case getConNames con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst -{- old - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L loc con) = - leader <-> - case con_res con of - ResTyH98 -> case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl - - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) - ) <-> rDoc mbDoc - - - header_ = ppConstrHdr (con_explicit con) tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) - | otherwise = ty - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case con_names con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) --} - -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField names ltype _) = - decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) - <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc - where - -- don't use cd_fld_doc for same reason we don't use con_doc above - -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst - --- {- --- ppHsFullConstr :: HsConDecl -> LaTeX --- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = --- declWithDoc False doc ( --- hsep ((ppHsConstrHdr tvs ctxt +++ --- ppHsBinder False nm) : map ppHsBangType typeList) --- ) --- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = --- td << vanillaTable << ( --- case doc of --- Nothing -> aboves [hdr, fields_html] --- Just _ -> aboves [hdr, constr_doc, fields_html] --- ) --- --- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) --- --- constr_doc --- | isJust doc = docBox (docToLaTeX (fromJust doc)) --- | otherwise = LaTeX.emptyTable --- --- fields_html = --- td << --- table ! [width "100%", cellpadding 0, cellspacing 8] << ( --- aboves (map ppFullField (concat (map expandField fields))) --- ) --- -} --- --- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX --- ppShortField summary unicode (ConDeclField (L _ name) ltype _) --- = tda [theclass "recfield"] << ( --- ppBinder summary (docNameOcc name) --- <+> dcolon unicode <+> ppLType unicode ltype --- ) --- --- {- --- ppFullField :: HsFieldDecl -> LaTeX --- ppFullField (HsFieldDecl [n] ty doc) --- = declWithDoc False doc ( --- ppHsBinder False n <+> dcolon <+> ppHsBangType ty --- ) --- ppFullField _ = error "ppFullField" --- --- expandField :: HsFieldDecl -> [HsFieldDecl] --- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --- -} - - --- | Print the LHS of a data\/newtype declaration. --- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX -ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars - , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode - = -- newtype or data - (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> - -- context - ppLContext ctxt unicode <+> - -- T a b c ..., or a :+: b - ppAppDocNameNames False name (tyvarNames tyvars) -ppDataHeader _ _ = error "ppDataHeader: illegal argument" - --------------------------------------------------------------------------------- --- * Type applications --------------------------------------------------------------------------------- - - --- | Print an application of a DocName and two lists of HsTypes (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX -ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) - - --- | Print an application of a DocName and a list of Names -ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX -ppAppDocNameNames _summ n ns = - ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName - - --- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX -ppTypeApp n [] (t1:t2:rest) ppDN ppT - | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) - | operator = opApp - where - operator = isNameSym . getName $ n - opApp = ppT t1 <+> ppDN n <+> ppT t2 - -ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) - - -------------------------------------------------------------------------------- --- * Contexts -------------------------------------------------------------------------------- - - -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc - -ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX -ppContextNoLocsMaybe [] _ = Nothing -ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode - -ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX -ppContextNoArrow cxt unicode = fromMaybe empty $ - ppContextNoLocsMaybe (map unLoc cxt) unicode - - -ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX -ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ - ppContextNoLocsMaybe cxt unicode - - -ppContext :: HsContext DocName -> Bool -> LaTeX -ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode - - -pp_hs_context :: [HsType DocName] -> Bool -> LaTeX -pp_hs_context [] _ = empty -pp_hs_context [p] unicode = ppType unicode p -pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) - - -------------------------------------------------------------------------------- --- * Types and contexts -------------------------------------------------------------------------------- - - -ppBang :: HsSrcBang -> LaTeX -ppBang (HsSrcBang _ _ SrcStrict) = char '!' -ppBang (HsSrcBang _ _ SrcLazy) = char '~' -ppBang _ = empty - - -tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX -tupleParens HsUnboxedTuple = ubxParenList -tupleParens _ = parenList - - -------------------------------------------------------------------------------- --- * Rendering of HsType --- --- Stolen from Html and tweaked for LaTeX generation -------------------------------------------------------------------------------- - - -pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX -ppLType unicode y = ppType unicode (unLoc y) -ppLParendType unicode y = ppParendType unicode (unLoc y) -ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) - - -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX -ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode -ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode -ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode - -ppLKind :: Bool -> LHsKind DocName -> LaTeX -ppLKind unicode y = ppKind unicode (unLoc y) - -ppKind :: Bool -> HsKind DocName -> LaTeX -ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode - - --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX -ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode - - -ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot - , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - sep [ ppLContext ctxt unicode - , ppr_mono_lty pREC_TOP ty unicode ] - -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode - where - ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op - occName = nameOccName . getName . unLoc $ op - -ppr_mono_ty ctxt_prec (HsParTy ty) unicode --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' - -ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u - -ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" - - -ppr_tylit :: HsTyLit -> Bool -> LaTeX -ppr_tylit (HsNumTy _ n) _ = integer n -ppr_tylit (HsStrTy _ s) _ = text (show s) - -- XXX: Ok in verbatim, but not otherwise - -- XXX: Do something with Unicode parameter? - - -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX -ppr_fun_ty ctxt_prec ty1 ty2 unicode - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode - p2 = ppr_mono_lty pREC_TOP ty2 unicode - in - maybeParen ctxt_prec pREC_FUN $ - sep [p1, arrow unicode <+> p2] - - -------------------------------------------------------------------------------- --- * Names -------------------------------------------------------------------------------- - - -ppBinder :: OccName -> LaTeX -ppBinder n - | isInfixName n = parens $ ppOccName n - | otherwise = ppOccName n - -isInfixName :: OccName -> Bool -isInfixName n = isVarSym n || isConSym n - -ppSymName :: Name -> LaTeX -ppSymName name - | isNameSym name = parens $ ppName name - | otherwise = ppName name - - -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString - -ppIPName :: HsIPName -> LaTeX -ppIPName ip = text $ unpackFS $ hsIPNameFS ip - -ppOccName :: OccName -> LaTeX -ppOccName = text . occNameString - - -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc - - -ppDocName :: DocName -> LaTeX -ppDocName = ppOccName . nameOccName . getName - - -ppLDocName :: Located DocName -> LaTeX -ppLDocName (L _ d) = ppDocName d - - -ppDocBinder :: DocName -> LaTeX -ppDocBinder = ppBinder . nameOccName . getName - - -ppName :: Name -> LaTeX -ppName = ppOccName . nameOccName - - -latexFilter :: String -> String -latexFilter = foldr latexMunge "" - - -latexMonoFilter :: String -> String -latexMonoFilter = foldr latexMonoMunge "" - - -latexMunge :: Char -> String -> String -latexMunge '#' s = "{\\char '43}" ++ s -latexMunge '$' s = "{\\char '44}" ++ s -latexMunge '%' s = "{\\char '45}" ++ s -latexMunge '&' s = "{\\char '46}" ++ s -latexMunge '~' s = "{\\char '176}" ++ s -latexMunge '_' s = "{\\char '137}" ++ s -latexMunge '^' s = "{\\char '136}" ++ s -latexMunge '\\' s = "{\\char '134}" ++ s -latexMunge '{' s = "{\\char '173}" ++ s -latexMunge '}' s = "{\\char '175}" ++ s -latexMunge '[' s = "{\\char 91}" ++ s -latexMunge ']' s = "{\\char 93}" ++ s -latexMunge c s = c : s - - -latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s -latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s - - -------------------------------------------------------------------------------- --- * Doc Markup -------------------------------------------------------------------------------- - - -parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) -parLatexMarkup ppId = Markup { - markupParagraph = \p v -> p v <> text "\\par" $$ text "", - markupEmpty = \_ -> empty, - markupString = \s v -> text (fixString v s), - markupAppend = \l r v -> l v <> r v, - markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), - markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> emph (p v), - markupEmphasis = \p v -> emph (p v), - markupBold = \p v -> bold (p v), - markupMonospaced = \p _ -> tt (p Mono), - markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \p _ -> markupPic p, - markupMathInline = \p _ -> markupMathInline p, - markupMathDisplay = \p _ -> markupMathDisplay p, - markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", - markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), - markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \l _ -> markupLink l, - markupAName = \_ _ -> empty, - markupProperty = \p _ -> quote $ verb $ text p, - markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p) - } - where - header 1 d = text "\\section*" <> braces d - header 2 d = text "\\subsection*" <> braces d - header l d - | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d - header l _ = error $ "impossible header level in LaTeX generation: " ++ show l - - fixString Plain s = latexFilter s - fixString Verb s = s - fixString Mono s = latexMonoFilter s - - markupLink (Hyperlink url mLabel) = case mLabel of - Just label -> text "\\href" <> braces (text url) <> braces (text label) - Nothing -> text "\\url" <> braces (text url) - - -- Is there a better way of doing this? Just a space is an aribtrary choice. - markupPic (Picture uri title) = parens (imageText title) - where - imageText Nothing = beg - imageText (Just t) = beg <> text " " <> text t - - beg = text "image: " <> text uri - - markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)" - - markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" - - markupId ppId_ id v = - case v of - Verb -> theid - Mono -> theid - Plain -> text "\\haddockid" <> braces theid - where theid = ppId_ id - - -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName - - -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName - - -docToLaTeX :: Doc DocName -> LaTeX -docToLaTeX doc = markup latexMarkup doc Plain - - -documentationToLaTeX :: Documentation DocName -> Maybe LaTeX -documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation - - -rdrDocToLaTeX :: Doc RdrName -> LaTeX -rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain - - -data StringContext = Plain | Verb | Mono - - -latexStripTrailingWhitespace :: Doc a -> Doc a -latexStripTrailingWhitespace (DocString s) - | null s' = DocEmpty - | otherwise = DocString s - where s' = reverse (dropWhile isSpace (reverse s)) -latexStripTrailingWhitespace (DocAppend l r) - | DocEmpty <- r' = latexStripTrailingWhitespace l - | otherwise = DocAppend l r' - where - r' = latexStripTrailingWhitespace r -latexStripTrailingWhitespace (DocParagraph p) = - latexStripTrailingWhitespace p -latexStripTrailingWhitespace other = other - - -------------------------------------------------------------------------------- --- * LaTeX utils -------------------------------------------------------------------------------- - - -itemizedList :: [LaTeX] -> LaTeX -itemizedList items = - text "\\begin{itemize}" $$ - vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" - - -enumeratedList :: [LaTeX] -> LaTeX -enumeratedList items = - text "\\begin{enumerate}" $$ - vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" - - -descriptionList :: [(LaTeX,LaTeX)] -> LaTeX -descriptionList items = - text "\\begin{description}" $$ - vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ - text "\\end{description}" - - -tt :: LaTeX -> LaTeX -tt ltx = text "\\haddocktt" <> braces ltx - - -decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - - -emph :: LaTeX -> LaTeX -emph ltx = text "\\emph" <> braces ltx - -bold :: LaTeX -> LaTeX -bold ltx = text "\\textbf" <> braces ltx - -verb :: LaTeX -> LaTeX -verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" - -- NB. swallow a trailing \n in the verbatim text by appending the - -- \end{verbatim} directly, otherwise we get spurious blank lines at the - -- end of code blocks. - - -quote :: LaTeX -> LaTeX -quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" - - -dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX -dcolon unicode = text (if unicode then "∷" else "::") -arrow unicode = text (if unicode then "→" else "->") -darrow unicode = text (if unicode then "⇒" else "=>") -forallSymbol unicode = text (if unicode then "∀" else "forall") - - -dot :: LaTeX -dot = char '.' - - -parenList :: [LaTeX] -> LaTeX -parenList = parens . hsep . punctuate comma - - -ubxParenList :: [LaTeX] -> LaTeX -ubxParenList = ubxparens . hsep . punctuate comma - - -ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" - - -pabrackets :: LaTeX -> LaTeX -pabrackets h = text "[:" <> h <> text ":]" +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.LaTeX +-- Copyright : (c) Simon Marlow 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.LaTeX ( + ppLaTeX, +) where + +import Documentation.Haddock.Markup +import Haddock.Doc (combineDocumentation) +import Haddock.Types +import Haddock.Utils +import Haddock.GhcUtils +import GHC.Utils.Ppr hiding (Doc, quote) +import qualified GHC.Utils.Ppr as Pretty + +import GHC hiding (fromMaybeContext ) +import GHC.Types.Name.Occurrence +import GHC.Types.Name ( nameOccName ) +import GHC.Types.Name.Reader ( rdrNameOcc ) +import GHC.Core.Type ( Specificity(..) ) +import GHC.Data.FastString ( unpackFS ) + +import qualified Data.Map as Map +import System.Directory +import System.FilePath +import Data.Char +import Control.Monad +import Data.Maybe +import Data.List ( sort ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Foldable ( toList ) +import Prelude hiding ((<>)) + +{- SAMPLE OUTPUT + +\haddockmoduleheading{\texttt{Data.List}} +\hrulefill +{\haddockverb\begin{verbatim} +module Data.List ( + (++), head, last, tail, init, null, length, map, reverse, + ) where\end{verbatim}} +\hrulefill + +\section{Basic functions} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +head\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the first element of a list, which must be non-empty. +\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +last\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the last element of a list, which must be finite and non-empty. +\par + +\end{haddockdesc} +-} + + +{- TODO + * don't forget fixity!! +-} + +ppLaTeX :: String -- Title + -> Maybe String -- Package name + -> [Interface] + -> FilePath -- destination directory + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- style file + -> FilePath + -> IO () + +ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir + = do + createDirectoryIfMissing True odir + when (isNothing maybe_style) $ + copyFile (libdir "latex" haddockSty) (odir haddockSty) + ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces + mapM_ (ppLaTeXModule title odir) visible_ifaces + + +haddockSty :: FilePath +haddockSty = "haddock.sty" + + +type LaTeX = Pretty.Doc + +-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 +-- often overflows the line). +latex2String :: LaTeX -> String +latex2String = fullRender (PageMode True) 90 1 txtPrinter "" + +ppLaTeXTop + :: String + -> Maybe String + -> FilePath + -> Maybe (Doc GHC.RdrName) + -> Maybe String + -> [Interface] + -> IO () + +ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do + + let tex = vcat [ + text "\\documentclass{book}", + text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), + text "\\begin{document}", + text "\\begin{titlepage}", + text "\\begin{haddocktitle}", + text doctitle, + text "\\end{haddocktitle}", + case prologue of + Nothing -> empty + Just d -> vcat [text "\\begin{haddockprologue}", + rdrDocToLaTeX d, + text "\\end{haddockprologue}"], + text "\\end{titlepage}", + text "\\tableofcontents", + vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], + text "\\end{document}" + ] + + mods = sort (map (moduleBasename.ifaceMod) ifaces) + + filename = odir (fromMaybe "haddock" packageStr <.> "tex") + + writeUtf8File filename (show tex) + + +ppLaTeXModule :: String -> FilePath -> Interface -> IO () +ppLaTeXModule _title odir iface = do + createDirectoryIfMissing True odir + let + mdl = ifaceMod iface + mdl_str = moduleString mdl + + exports = ifaceRnExportItems iface + + tex = vcat [ + text "\\haddockmoduleheading" <> braces (text mdl_str), + text "\\label{module:" <> text mdl_str <> char '}', + text "\\haddockbeginheader", + verb $ vcat [ + text "module" <+> text mdl_str <+> lparen, + text " " <> fsep (punctuate (char ',') $ + map exportListItem $ + filter forSummary exports), + text " ) where" + ], + text "\\haddockendheader" $$ text "", + description, + body + ] + + description + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface + + body = processExports exports + -- + writeUtf8File (odir moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex) + +-- | Prints out an entry in a module export list. +exportListItem :: ExportItem DocNameI -> LaTeX +exportListItem + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ( ExportD + { expDDecl = decl + , expDSubDocs = subdocs + } + ) + } + ) + ) + = let (leader, names) = declNames decl + in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) +exportListItem (ExportNoDecl y []) + = ppDocBinder y +exportListItem (ExportNoDecl y subs) + = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) +exportListItem (ExportModule mdl) + = text "module" <+> text (moduleString mdl) +exportListItem _ + = error "exportListItem" + + +-- Deal with a group of undocumented exports together, to avoid lots +-- of blank vertical space between them. +processExports :: [ExportItem DocNameI] -> LaTeX +processExports [] = empty +processExports (decl : es) + | Just sig <- isSimpleSig decl + = multiDecl [ ppTypeSig (map getName names) typ False + | (names,typ) <- sig:sigs ] $$ + processExports es' + where (sigs, es') = spanWith isSimpleSig es +processExports (ExportModule mdl : es) + = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ + processExports es' + where (mdls, es') = spanWith isExportModule es +processExports (e : es) = + processExport e $$ processExports es + + +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) +isSimpleSig + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDDecl = L _ (SigD _ (TypeSig _ lnames t)) + , expDMbDoc = (Documentation Nothing Nothing, argDocs) + } + } + ) + ) + | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) +isSimpleSig _ = Nothing + + +isExportModule :: ExportItem DocNameI -> Maybe Module +isExportModule (ExportModule m) = Just m +isExportModule _ = Nothing + + +processExport :: ExportItem DocNameI -> LaTeX +processExport (ExportGroup lev _id0 doc) + = ppDocGroup lev (docToLaTeX doc) +processExport (ExportDecl (RnExportD (ExportD decl pats doc subdocs insts fixities _splice) _)) + = ppDecl decl pats doc insts subdocs fixities +processExport (ExportNoDecl y []) + = ppDocName y +processExport (ExportNoDecl y subs) + = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) +processExport (ExportModule mdl) + = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing +processExport (ExportDoc doc) + = docToLaTeX $ _doc doc + + +ppDocGroup :: Int -> LaTeX -> LaTeX +ppDocGroup lev doc = sec lev <> braces doc + where sec 1 = text "\\section" + sec 2 = text "\\subsection" + sec 3 = text "\\subsubsection" + sec _ = text "\\paragraph" + + +-- | Given a declaration, extract out the names being declared +declNames :: LHsDecl DocNameI + -> ( LaTeX -- to print before each name in an export list + , [DocName] -- names being declared + ) +declNames (L _ decl) = case decl of + TyClD _ d -> (empty, [tcdNameI d]) + SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) + ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) + ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n]) + _ -> error "declaration not supported by declNames" + + +forSummary :: (ExportItem DocNameI) -> Bool +forSummary (ExportGroup _ _ _) = False +forSummary (ExportDoc _) = False +forSummary _ = True + + +moduleLaTeXFile :: Module -> FilePath +moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" + + +moduleBasename :: Module -> FilePath +moduleBasename mdl = map (\c -> if c == '.' then '-' else c) + (moduleNameString (moduleName mdl)) + + +------------------------------------------------------------------------------- +-- * Decls +------------------------------------------------------------------------------- + +-- | Pretty print a declaration +ppDecl :: LHsDecl DocNameI -- ^ decl to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ all pattern decls + -> DocForDecl DocName -- ^ documentation for decl + -> [DocInstance DocNameI] -- ^ all instances + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs + -> [(DocName, Fixity)] -- ^ all fixities + -> LaTeX + +ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode + TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode + SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD _ d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ _ -> empty + DerivD _ _ -> empty + _ -> error "declaration not supported by ppDecl" + where + unicode = False + + +ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX +ppFor doc (ForeignImport _ (L _ name) typ _) unicode = + ppFunSig Nothing doc [name] typ unicode +ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +-- error "foreign declarations are currently not supported by --latex" + + +------------------------------------------------------------------------------- +-- * Type families +------------------------------------------------------------------------------- + +-- | Pretty-print a data\/type family declaration +ppFamDecl :: Bool -- ^ is the family associated? + -> Documentation DocName -- ^ this decl's docs + -> [DocInstance DocNameI] -- ^ relevant instances + -> TyClDecl DocNameI -- ^ family to print + -> Bool -- ^ unicode + -> LaTeX +ppFamDecl associated doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + where + body = catMaybes [familyEqns, documentationToLaTeX doc] + + whereBit = case fdInfo (tcdFam decl) of + ClosedTypeFamily _ -> keyword "where" + _ -> empty + + familyEqns + | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + , not (null eqns) + = Just (text "\\haddockbeginargs" $$ + vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ + text "\\end{tabulary}\\par") + | otherwise = Nothing + + -- Individual equations of a closed type family + ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) + = hsep [ ppAppNameTypeArgs n ts unicode + , equals + , ppType unicode (unLoc rhs) + ] + + instancesBit = ppDocInstances unicode instances + +-- | Print the LHS of a type\/data family declaration. +ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX +ppFamHeader (FamilyDecl { fdLName = L _ name + , fdTyVars = tvs + , fdInfo = info + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity }) + unicode associated = + famly leader <+> famName <+> famSig <+> injAnn + where + leader = case info of + OpenTypeFamily -> keyword "type" + ClosedTypeFamily _ -> keyword "type" + DataFamily -> keyword "data" + + famly | associated = id + | otherwise = (<+> keyword "family") + + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) + + famSig = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon unicode <+> ppLKind unicode kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr + + injAnn = case injectivity of + Nothing -> empty + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|") + : ppLDocName lhs + : arrow unicode + : map ppLDocName rhs) + Just _ -> empty + + + +------------------------------------------------------------------------------- +-- * Type Synonyms +------------------------------------------------------------------------------- + + +-- we skip type patterns for now +ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX + +ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) unicode + = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode + where + hdr = hsep (keyword "type" + : ppDocBinder name + : map ppSymName (tyvarNames ltyvars)) + full = hdr <+> char '=' <+> ppLType unicode ltype + +ppTySyn _ _ _ = error "declaration not supported by ppTySyn" + + +------------------------------------------------------------------------------- +-- * Function signatures +------------------------------------------------------------------------------- + + +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsSigType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = + ppTypeOrFunSig typ doc + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names + , dcolon unicode + ) + unicode + where + names = map getName docnames + lead = maybe id (<+>) leader + +-- | Pretty-print a pattern synonym +ppLPatSig :: DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsSigType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppLPatSig doc docnames ty unicode + = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode + +-- | Pretty-print a type, adding documentation to the whole type and its +-- arguments as needed. +ppTypeOrFunSig :: HsSigType DocNameI + -> DocForDecl DocName -- ^ documentation + -> ( LaTeX -- first-line (no-argument docs only) + , LaTeX -- first-line (argument docs only) + , LaTeX -- type prefix (argument docs only) + ) + -> Bool -- ^ unicode + -> LaTeX +ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode + | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = declWithDoc pref2 $ Just $ + text "\\haddockbeginargs" $$ + vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$ + text "\\end{tabulary}\\par" $$ + fromMaybe empty (documentationToLaTeX doc) + +-- | This splits up a type signature along @->@ and adds docs (when they exist) +-- to the arguments. The output is a list of (leader/seperator, argument and +-- its doc) +ppSubSigLike :: Bool -- ^ unicode + -> HsSigType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) + -> LaTeX -- ^ seperator (beginning of first line) + -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) +ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ + where + do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> + [ ( decltt leader + , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode) + <+> ppLType unicode ltype + ) ] + HsOuterImplicit{} -> do_largs n leader ltype + + do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)] + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs + + do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] + do_args _n leader (HsForAllTy _ tele ltype) + = [ ( decltt leader + , decltt (ppHsForAllTelescope tele unicode) + <+> ppLType unicode ltype + ) ] + do_args n leader (HsQualTy _ lctxt ltype) + = ( decltt leader + , decltt (ppLContextNoArrow lctxt unicode) <+> nl + ) : do_largs n (darrow unicode) ltype + + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) + = [ (decltt ldr, latex <+> nl) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let latex = ppSideBySideField subdocs unicode field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + do_args n leader (HsFunTy _ _w lt r) + = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ',' + gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}' + gadtOpen = char '{' + + +ppTypeSig :: [Name] -> HsSigType DocNameI -> Bool -> LaTeX +ppTypeSig nms ty unicode = + hsep (punctuate comma $ map ppSymName nms) + <+> dcolon unicode + <+> ppSigType unicode ty + +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX +ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty +ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode = + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot + +ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX +ppHsForAllTelescope tele unicode = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars bndrs) <> dot + + +ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX] +ppTyVars = map (ppSymName . getName . hsLTyVarNameI) + + +tyvarNames :: LHsQTyVars DocNameI -> [Name] +tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit + + +declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX +declWithDoc decl doc = + text "\\begin{haddockdesc}" $$ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" $$ + maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ + text "\\end{haddockdesc}" + + +-- in a group of decls, we don't put them all in the same tabular, +-- because that would prevent the group being broken over a page +-- boundary (breaks Foreign.C.Error for example). +multiDecl :: [LaTeX] -> LaTeX +multiDecl decls = + text "\\begin{haddockdesc}" $$ + vcat [ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" + | decl <- decls ] $$ + text "\\end{haddockdesc}" + + +------------------------------------------------------------------------------- +-- * Rendering Doc +------------------------------------------------------------------------------- + + +maybeDoc :: Maybe (Doc DocName) -> LaTeX +maybeDoc = maybe empty docToLaTeX + + +-- for table cells, we strip paragraphs out to avoid extra vertical space +-- and don't add a quote environment. +rDoc :: Maybe (Doc DocName) -> LaTeX +rDoc = maybeDoc . fmap latexStripTrailingWhitespace + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] + -> Bool -> LaTeX +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty) + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode + +-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX +ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX +ppFds fds unicode = + if null fds then empty else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (FunDep _ vars1 vars2) + = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> + hsep (map (ppDocName . unLoc) vars2) + fundep (XFunDep _) = error "ppFds" + + +-- TODO: associated type defaults, docs on default methods +ppClassDecl :: [DocInstance DocNameI] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocNameI -> Bool -> LaTeX +ppClassDecl instances doc subdocs + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode + = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ + instancesBit + where + classheader + | null lsigs = hdr unicode + | otherwise = hdr unicode <+> keyword "where" + + hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds + + body = catMaybes [documentationToLaTeX doc, body_] + + body_ + | null lsigs, null ats, null at_defs = Nothing + | null ats, null at_defs = Just methodTable + | otherwise = Just (atTable $$ methodTable) + + atTable = + text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ + vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True + | L _ decl <- ats + , let name = unLoc . fdLName $ decl + doc = lookupAnySubdoc name subdocs + ] + + + methodTable = + text "\\haddockpremethods{}" <> emph (text "Methods") $$ + vcat [ ppFunSig leader doc names typ unicode + | L _ (ClassOpSig _ is_def lnames typ) <- lsigs + , let doc | is_def = noDocForDecl + | otherwise = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. + + instancesBit = ppDocInstances unicode instances + +ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + +ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX +ppDocInstances _unicode [] = empty +ppDocInstances unicode (i : rest) + | Just ihead <- isUndocdInstance i + = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ + ppDocInstances unicode rest' + | otherwise + = ppDocInstance unicode i $$ ppDocInstances unicode rest + where + (is, rest') = spanWith isUndocdInstance rest + +isUndocdInstance :: DocInstance a -> Maybe (InstHead a) +isUndocdInstance (i,Nothing,_,_) = Just i +isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i +isUndocdInstance _ = Nothing + +-- | Print a possibly commented instance. The instance header is printed inside +-- an 'argBox'. The comment is printed to the right of the box in normal comment +-- style. +ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX +ppDocInstance unicode (instHead, doc, _, _) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) + + +ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX +ppInstDecl unicode (InstHead {..}) = case ihdInstType of + ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ + TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs + DataInst dd -> + let cons = dd_cons (tcdDataDefn dd) + pref = case cons of { NewTypeCon _ -> keyword "newtype"; DataTypeCons _ _ -> keyword "data" } + in pref <+> keyword "instance" <+> typ + where + typ = ppAppNameTypes ihdClsName ihdTypes unicode + tibody = maybe empty (\t -> equals <+> ppType unicode t) + +lookupAnySubdoc :: (Eq name1) => + name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 +lookupAnySubdoc n subdocs = case lookup n subdocs of + Nothing -> noDocForDecl + Just docs -> docs + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + +-- | Pretty-print a data declaration +ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, DocForDecl DocName)] -- ^ relevant decl docs + -> Maybe (Documentation DocName) -- ^ this decl's docs + -> TyClDecl DocNameI -- ^ data decl to print + -> Bool -- ^ unicode + -> LaTeX +ppDataDecl pats instances subdocs doc dataDecl unicode = + declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + + where + cons = dd_cons (tcdDataDefn dataDecl) + + body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit] + + (whereBit, leaders) + | null cons + , null pats = (empty,[]) + | null cons = (text "where", repeat empty) + | otherwise = case toList cons of + L _ ConDeclGADT{} : _ -> (text "where", repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + + constrBit + | null cons = Nothing + | otherwise = Just $ + text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$ + text "\\haddockbeginconstrs" $$ + vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders (toList cons)) $$ + text "\\end{tabulary}\\par" + + patternBit + | null pats = Nothing + | otherwise = Just $ + text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ + text "\\haddockbeginconstrs" $$ + vcat [ empty <-> ppSideBySidePat lnames typ d unicode + | (SigD _ (PatSynSig _ lnames typ), d) <- pats + ] $$ + text "\\end{tabulary}\\par" + + instancesBit = ppDocInstances unicode instances + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Bool -- ^ unicode + -> LaTeX +ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt + where + ppForall + | null tvs || not forall_ = empty + | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode + + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space + + +-- | Pretty-print a constructor +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs + -> Bool -- ^ unicode + -> LaTeX -- ^ prefix to decl + -> LConDecl DocNameI -- ^ constructor decl + -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> decltt decl <-> rDoc mbDoc <+> nl + $$ fieldPart + where + -- Find the name of a constructors in the decl (`getConName` always returns + -- a non-empty list) + L _ aConName :| _ = getConNamesI con + + occ = toList $ nameOccName . getName . unLoc <$> getConNamesI con + + ppOcc = cat (punctuate comma (map ppBinder occ)) + ppOccInfix = cat (punctuate comma (map ppBinderInfix occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + -- First line of the constructor (no doc, no fields, single-line) + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = tyVars + , con_forall = forall_ + , con_mb_cxt = cxt + } -> let context = fromMaybeContext cxt + header_ = ppConstrHdr forall_ tyVars context unicode + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon _ args + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppOcc + , hsep (map (ppLParendType unicode . hsScaledThing) args) + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ <+> ppOcc + + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppLParendType unicode (hsScaledThing arg1) + , ppOccInfix + , ppLParendType unicode (hsScaledThing arg2) + ] + + ConDeclGADT{} + | hasArgDocs || not (isEmpty fieldPart) -> ppOcc + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLSigType unicode (getGADTConType con) + ] + + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ _ -> doConstrArgsWithDocs [] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + _ -> empty + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> doRecordFields fields + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2]) + _ -> empty + + doRecordFields fields = + vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl + | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields + ] + $$ + empty <-> tt (text "\\qquad \\}") <+> nl + + doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of + ConDeclH98{} -> + [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + [ l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) + ] + + + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = case getConNamesI con of + cn:|_ -> lookup (unLoc cn) subdocs >>= + fmap _doc . combineDocumentation . fst + + +-- | Pretty-print a record field +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX +ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = + decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names)) + <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + -- Where there is more than one name, they all have the same documentation + mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + + +-- | Pretty-print a bundled pattern synonym +ppSideBySidePat :: [LocatedN DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> Bool -- ^ unicode + -> LaTeX +ppSideBySidePat lnames typ (doc, argDocs) unicode = + decltt decl <-> rDoc mDoc <+> nl + $$ fieldPart + where + hasArgDocs = not $ Map.null argDocs + ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppLSigType unicode typ + ] + + fieldPart + | not hasArgDocs = empty + | otherwise = vcat + [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode) + ] + + mDoc = fmap _doc $ combineDocumentation doc + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX +ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars + , tcdDataDefn = HsDataDefn { dd_cons = cons, dd_ctxt = ctxt } }) unicode + = -- newtype or data + (case cons of + { NewTypeCon _ -> keyword "newtype" + ; DataTypeCons False _ -> keyword "data" + ; DataTypeCons True _ -> keyword "type" <+> keyword "data" + }) <+> + -- context + ppLContext ctxt unicode <+> + -- T a b c ..., or a :+: b + ppAppDocNameNames False name (tyvarNames tyvars) +ppDataHeader _ _ = error "ppDataHeader: illegal argument" + + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX +ppAppDocNameTyVarBndrs unicode n vs = + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc) + where + ppDN = ppBinder . nameOccName . getName + + +-- | Print an application of a DocName to its list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) + +ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX +ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode + = ppTypeApp n args ppDocName (ppLHsTypeArg unicode) +ppAppNameTypeArgs n args unicode + = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args) + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX +ppAppDocNameNames _summ n ns = + ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX +ppTypeApp n (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN n <+> ppT t2 + +ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX +ppLContext Nothing _ = empty +ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode + +ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX +ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode + +ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX +ppContextNoLocsMaybe [] _ = Nothing +ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode + +ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX +ppContextNoArrow cxt unicode = fromMaybe empty $ + ppContextNoLocsMaybe (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX +ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode + + +ppContext :: HsContext DocNameI -> Bool -> LaTeX +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppCtxType unicode p +pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) + + +------------------------------------------------------------------------------- +-- * Types and contexts +------------------------------------------------------------------------------- + + +ppBang :: HsSrcBang -> LaTeX +ppBang (HsSrcBang _ _ SrcStrict) = char '!' +ppBang (HsSrcBang _ _ SrcLazy) = char '~' +ppBang _ = empty + + +tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +sumParens :: [LaTeX] -> LaTeX +sumParens = ubxparens . hsep . punctuate (text " |") + + +------------------------------------------------------------------------------- +-- * Rendering of HsType +-- +-- Stolen from Html and tweaked for LaTeX generation +------------------------------------------------------------------------------- + +ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX +ppLType unicode y = ppType unicode (unLoc y) +ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) + +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX +ppLSigType unicode y = ppSigType unicode (unLoc y) + +ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX +ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode +ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode + +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX +ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode + +ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX +ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty +ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode ki +ppLHsTypeArg _ (HsArgPar _) = text "" + +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name + ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name + ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) = + parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) = + braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + +ppLKind :: Bool -> LHsKind DocNameI -> LaTeX +ppLKind unicode y = ppKind unicode (unLoc y) + +ppKind :: Bool -> HsKind DocNameI -> LaTeX +ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode + = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode + , ppr_mono_lty ltype unicode ] + +ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX +ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode + + +ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX +ppr_mono_ty (HsForAllTy _ tele ty) unicode + = sep [ ppHsForAllTelescope tele unicode + , ppr_mono_lty ty unicode ] +ppr_mono_ty (HsQualTy _ ctxt ty) unicode + = sep [ ppLContext (Just ctxt) unicode + , ppr_mono_lty ty unicode ] +ppr_mono_ty (HsFunTy _ mult ty1 ty2) u + = sep [ ppr_mono_lty ty1 u + , arr <+> ppr_mono_lty ty2 u ] + where arr = case mult of + HsLinearArrow _ -> lollipop u + HsUnrestrictedArrow _ -> arrow u + HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u + +ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty (HsTyVar _ IsPromoted (L _ name)) _ = char '\'' <> ppDocName name +ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) +ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u +ppr_mono_ty (HsSpliceTy v _) _ = dataConCantHappen v +ppr_mono_ty (HsRecTy {}) _ = text "{..}" +ppr_mono_ty (XHsType {}) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode + = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] + +ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode + = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode] + +ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode + = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode + where + ppr_op_prom | isPromoted prom + = char '\'' <> ppr_op + | otherwise + = ppr_op + ppr_op | isSymOcc (getOccName op) = ppLDocName op + | otherwise = char '`' <> ppLDocName op <> char '`' + +ppr_mono_ty (HsParTy _ ty) unicode + = parens (ppr_mono_lty ty unicode) +-- = ppr_mono_lty ty unicode + +ppr_mono_ty (HsDocTy _ ty _) unicode + = ppr_mono_lty ty unicode + +ppr_mono_ty (HsWildCardTy _) _ = char '_' + +ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u +ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) + + +ppr_tylit :: HsTyLit DocNameI -> Bool -> LaTeX +ppr_tylit (HsNumTy _ n) _ = integer n +ppr_tylit (HsStrTy _ s) _ = text (show s) +ppr_tylit (HsCharTy _ c) _ = text (show c) + -- XXX: Ok in verbatim, but not otherwise + -- XXX: Do something with Unicode parameter? + + +------------------------------------------------------------------------------- +-- * Names +------------------------------------------------------------------------------- + + +ppBinder :: OccName -> LaTeX +ppBinder n + | isSymOcc n = parens $ ppOccName n + | otherwise = ppOccName n + +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isSymOcc n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] + +ppSymName :: Name -> LaTeX +ppSymName name + | isNameSym name = parens $ ppName name + | otherwise = ppName name + + +ppIPName :: HsIPName -> LaTeX +ppIPName = text . ('?':) . unpackFS . hsIPNameFS + +ppOccName :: OccName -> LaTeX +ppOccName = text . occNameString + + +ppDocName :: DocName -> LaTeX +ppDocName = ppOccName . nameOccName . getName + +ppLDocName :: GenLocated l DocName -> LaTeX +ppLDocName (L _ d) = ppDocName d + + +ppDocBinder :: DocName -> LaTeX +ppDocBinder = ppBinder . nameOccName . getName + + +ppName :: Name -> LaTeX +ppName = ppOccName . nameOccName + + +latexFilter :: String -> String +latexFilter = foldr latexMunge "" + + +latexMonoFilter :: String -> String +latexMonoFilter = foldr latexMonoMunge "" + + +latexMunge :: Char -> String -> String +latexMunge '#' s = "{\\char '43}" ++ s +latexMunge '$' s = "{\\char '44}" ++ s +latexMunge '%' s = "{\\char '45}" ++ s +latexMunge '&' s = "{\\char '46}" ++ s +latexMunge '~' s = "{\\char '176}" ++ s +latexMunge '_' s = "{\\char '137}" ++ s +latexMunge '^' s = "{\\char '136}" ++ s +latexMunge '\\' s = "{\\char '134}" ++ s +latexMunge '{' s = "{\\char '173}" ++ s +latexMunge '}' s = "{\\char '175}" ++ s +latexMunge '[' s = "{\\char 91}" ++ s +latexMunge ']' s = "{\\char 93}" ++ s +latexMunge c s = c : s + + +latexMonoMunge :: Char -> String -> String +latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s +latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s +latexMonoMunge '\n' s = '\\' : '\\' : s +latexMonoMunge c s = latexMunge c s + + +------------------------------------------------------------------------------- +-- * Doc Markup +------------------------------------------------------------------------------- + + +latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX) +latexMarkup = Markup + { markupParagraph = \p v -> blockElem (p v (text "\\par")) + , markupEmpty = \_ -> id + , markupString = \s v -> inlineElem (text (fixString v s)) + , markupAppend = \l r v -> l v . r v + , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) + , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) + , markupModule = + \(ModLink m mLabel) v -> + case mLabel of + Just lbl -> inlineElem . tt $ lbl v empty + Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m + in (tt (text mdl))) + , markupWarning = \p v -> p v + , markupEmphasis = \p v -> inlineElem (emph (p v empty)) + , markupBold = \p v -> inlineElem (bold (p v empty)) + , markupMonospaced = \p v -> inlineElem (markupMonospace p v) + , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p)) + , markupPic = \p _ -> inlineElem (markupPic p) + , markupMathInline = \p _ -> inlineElem (markupMathInline p) + , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p)) + , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) + , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) + , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) + , markupAName = \_ _ -> id -- TODO + , markupProperty = \p _ -> blockElem (quote (verb (text p))) + , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e))) + , markupHeader = \(Header l h) p -> blockElem (header l (h p empty)) + , markupTable = \(Table h b) p -> blockElem (table h b p) + } + where + blockElem :: LaTeX -> LaTeX -> LaTeX + blockElem = ($$) + + inlineElem :: LaTeX -> LaTeX -> LaTeX + inlineElem = (<>) + + header 1 d = text "\\section*" <> braces d + header 2 d = text "\\subsection*" <> braces d + header l d + | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d + header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + + table _ _ _ = text "{TODO: Table}" + + fixString Plain s = latexFilter s + fixString Verb s = s + fixString Mono s = latexMonoFilter s + + markupMonospace p Verb = p Verb empty + markupMonospace p _ = tt (p Mono empty) + + markupLink url mLabel = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces label + Nothing -> text "\\url" <> braces (text url) + + -- Is there a better way of doing this? Just a space is an arbitrary choice. + markupPic (Picture uri title) = parens (imageText title) + where + imageText Nothing = beg + imageText (Just t) = beg <> text " " <> text t + + beg = text "image: " <> text uri + + markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)" + + markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" + + markupId v wrappedOcc = + case v of + Verb -> text i + Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i) + Plain -> text "\\haddockid" <> braces (text . latexFilter $ i) + where i = showWrapped occNameString wrappedOcc + +docToLaTeX :: Doc DocName -> LaTeX +docToLaTeX doc = markup latexMarkup doc Plain empty + +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation + + +rdrDocToLaTeX :: Doc RdrName -> LaTeX +rdrDocToLaTeX doc = markup latexMarkup doc Plain empty + + +data StringContext + = Plain -- ^ all special characters have to be escape + | Mono -- ^ on top of special characters, escape space characters + | Verb -- ^ don't escape anything + + +latexStripTrailingWhitespace :: Doc a -> Doc a +latexStripTrailingWhitespace (DocString s) + | null s' = DocEmpty + | otherwise = DocString s + where s' = reverse (dropWhile isSpace (reverse s)) +latexStripTrailingWhitespace (DocAppend l r) + | DocEmpty <- r' = latexStripTrailingWhitespace l + | otherwise = DocAppend l r' + where + r' = latexStripTrailingWhitespace r +latexStripTrailingWhitespace (DocParagraph p) = + latexStripTrailingWhitespace p +latexStripTrailingWhitespace other = other + + +------------------------------------------------------------------------------- +-- * LaTeX utils +------------------------------------------------------------------------------- + + +itemizedList :: [LaTeX] -> LaTeX +itemizedList items = + text "\\vbox{\\begin{itemize}" $$ + vcat (map (text "\\item" $$) items) $$ + text "\\end{itemize}}" + + +enumeratedList :: [LaTeX] -> LaTeX +enumeratedList items = + text "\\vbox{\\begin{enumerate}" $$ + vcat (map (text "\\item " $$) items) $$ + text "\\end{enumerate}}" + + +descriptionList :: [(LaTeX,LaTeX)] -> LaTeX +descriptionList items = + text "\\vbox{\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ + text "\\end{description}}" + + +tt :: LaTeX -> LaTeX +tt ltx = text "\\haddocktt" <> braces ltx + + +decltt :: LaTeX -> LaTeX +decltt ltx = text "\\haddockdecltt" <> braces (text filtered) + where filtered = latexMonoFilter (latex2String ltx) + +emph :: LaTeX -> LaTeX +emph ltx = text "\\emph" <> braces ltx + +bold :: LaTeX -> LaTeX +bold ltx = text "\\textbf" <> braces ltx + +-- TODO: @verbatim@ is too much since +-- +-- * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX +-- representing that markup gets printed verbatim +-- * Verbatim environments are not supported everywhere (example: not nested +-- inside a @tabulary@ environment) +verb :: LaTeX -> LaTeX +verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" + -- NB. swallow a trailing \n in the verbatim text by appending the + -- \end{verbatim} directly, otherwise we get spurious blank lines at the + -- end of code blocks. + + +quote :: LaTeX -> LaTeX +quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" + + +dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX +dcolon unicode = text (if unicode then "∷" else "::") +arrow unicode = text (if unicode then "→" else "->") +lollipop unicode = text (if unicode then "⊸" else "%1 ->") +darrow unicode = text (if unicode then "⇒" else "=>") +forallSymbol unicode = text (if unicode then "∀" else "forall") +starSymbol unicode = text (if unicode then "★" else "*") +atSign unicode = text (if unicode then "@" else "@") + +multAnnotation :: LaTeX +multAnnotation = text "%" + +dot :: LaTeX +dot = char '.' + + +parenList :: [LaTeX] -> LaTeX +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [LaTeX] -> LaTeX +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: LaTeX -> LaTeX +ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -11,10 +11,17 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, + ppJsonIndex ) where @@ -27,108 +34,154 @@ import Haddock.Backends.Xhtml.Themes import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils +import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo) import Haddock.ModuleTree +import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Version import Haddock.Utils +import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as XHtml import Haddock.GhcUtils import Control.Monad ( when, unless ) +import qualified Data.ByteString.Builder as Builder +import Control.DeepSeq (force) +import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, intercalate, isPrefixOf, intersperse ) +import Data.Either ( partitionEithers ) +import Data.Foldable ( traverse_, foldl') +import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe -import System.FilePath hiding ( () ) import System.Directory -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) +import System.FilePath hiding ( () ) +import qualified System.IO as IO +import qualified System.FilePath as FilePath +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set hiding ( Set ) import Data.Ord ( comparing ) -import DynFlags (Language(..)) -import GHC hiding ( NoLink, moduleInfo ) -import Name -import Module +import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor ) +import GHC.Types.Name +import GHC.Unit.State -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- - -ppHtml :: DynFlags +ppHtml :: UnitState -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] + -> [InstalledInterface] -- ^ Reexported interfaces -> FilePath -- ^ Destination directory -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki) + -> BaseURL -- ^ The base URL (--base-url) -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> Maybe String -- ^ Package name + -> PackageInfo -- ^ Package info -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) + -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces odir prologue +ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode - qual debug = do + maybe_base_url maybe_contents_url maybe_index_url unicode + pkg packageInfo qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i when (isNothing maybe_contents_url) $ - ppHtmlContents dflags odir doctitle maybe_package + ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) + withQuickjump + [PackageInterfaces + { piPackageInfo = packageInfo + , piVisibility = Visible + , piInstalledInterfaces = map toInstalledIface visible_ifaces + ++ reexported_ifaces + }] False -- we don't want to display the packages in a single-package contents - prologue debug (makeContentsQual qual) + prologue debug pkg (makeContentsQual qual) - when (isNothing maybe_index_url) $ + when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) debug + withQuickjump + (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual + visible_ifaces [] + mapM_ (ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url + maybe_contents_url maybe_index_url withQuickjump + unicode pkg qual debug) visible_ifaces -copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () -copyHtmlBits odir libdir themes = do +copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () +copyHtmlBits odir libdir themes withQuickjump = do let libhtmldir = joinPath [libdir, "html"] copyCssFile f = copyFile f (combine odir (takeFileName f)) copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) - copyLibFile jsFile + copyLibFile haddockJsFile + copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) + when withQuickjump (copyLibFile jsQuickJumpFile) return () -headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html -headHtml docTitle miniPage themes mathjax_url = - header << [ - meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], - thetitle << docTitle, - styleSheet themes, - script ! [src jsFile, thetype "text/javascript"] << noHtml, - script ! [src mjUrl, thetype "text/javascript"] << noHtml, - script ! [thetype "text/javascript"] - -- NB: Within XHTML, the content of script tags needs to be - -- a section. Will break if the miniPage name could - -- have "" in it! - << primHtml ( - "//\nwindow.onload = function () {pageLoad();" - ++ setSynopsis ++ "};\n//\n") +headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html +headHtml docTitle themes mathjax_url base_url = + header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url) + << + [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] + , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] + , thetitle << docTitle + , styleSheet base_url themes + , thelink ! [ rel "stylesheet" + , thetype "text/css" + , href (withBaseURL base_url quickJumpCssFile) ] + << noHtml + , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml + , script ! [ src (withBaseURL base_url haddockJsFile) + , emptyAttr "async" + , thetype "text/javascript" ] + << noHtml + , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf + , script ! [src mjUrl, thetype "text/javascript"] << noHtml ] 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 + fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700" + mjUrl = fromMaybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" mathjax_url + mjConf = unwords [ "MathJax.Hub.Config({" + , "tex2jax: {" + , "processClass: \"mathjax\"," + , "ignoreClass: \".*\"" + , "}" + , "});" ] +quickJumpButtonLi :: Bool -- ^ With Quick Jump? + -> Maybe Html +-- The TypeScript should replace this
  • element, given its id. However, in +-- case it does not, the element is given content here too. +quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"] + << anchor ! [href "#"] << "Quick Jump" +quickJumpButtonLi False = Nothing + srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = Just (anchor ! [href src_base_url] << "Source") @@ -167,20 +220,18 @@ bodyHtml :: String -> Maybe Interface -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String + -> Bool -- ^ With Quick Jump? -> Html -> Html bodyHtml doctitle iface maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url + withQuickjump pageContent = - body ! [theclass "no-frame"] << [ + body << [ divPackageHeader << [ - unordList (catMaybes [ - srcButton maybe_source_url iface, - wikiButton maybe_wiki_url (ifaceMod <$> iface), - contentsButton maybe_contents_url, - indexButton maybe_index_url]) - ! [theclass "links", identifier "page-menu"], - nonEmptySectionName << doctitle + nonEmptySectionName << doctitle, + ulist ! [theclass "links", identifier "page-menu"] + << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis) ], divContent << pageContent, divFooter << paragraph << ( @@ -189,7 +240,13 @@ (" version " ++ projectVersion) ) ] - + where + otherButtonLis = (fmap . fmap) (li <<) + [ srcButton maybe_source_url iface + , wikiButton maybe_wiki_url (ifaceMod <$> iface) + , contentsButton maybe_contents_url + , indexButton maybe_index_url + ] moduleInfo :: Interface -> Html moduleInfo iface = @@ -210,10 +267,7 @@ ("Language", lg) ] ++ extsForm where - lg inf = case hmi_language inf of - Nothing -> Nothing - Just Haskell98 -> Just "Haskell98" - Just Haskell2010 -> Just "Haskell2010" + lg inf = fmap show (hmi_language inf) multilineRow :: String -> [String] -> HtmlTable multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs) @@ -246,7 +300,7 @@ ppHtmlContents - :: DynFlags + :: UnitState -> FilePath -> String -> Maybe String @@ -255,82 +309,244 @@ -> Maybe String -> SourceURLs -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) + -> Bool -- ^ With Quick Jump? + -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool + -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () -ppHtmlContents dflags odir doctitle _maybe_package +ppHtmlContents state 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] + maybe_source_url maybe_wiki_url withQuickjump + packages showPkgs prologue debug pkg qual = do + let trees = + [ ( piPackageInfo pinfo + , mkModuleTree state showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- piInstalledInterfaces pinfo + , not (instIsSig iface) + ] + ) + | pinfo <- packages + ] + sig_trees = + [ ( piPackageInfo pinfo + , mkModuleTree state showPkgs + [(instMod iface, toInstalledDescription iface) + | iface <- piInstalledInterfaces pinfo + , instIsSig iface + ] + ) + | pinfo <- packages + ] html = - headHtml doctitle Nothing themes mathjax_url +++ + headHtml doctitle themes mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url - Nothing maybe_index_url << [ - ppPrologue qual doctitle prologue, - ppModuleTree qual tree + Nothing maybe_index_url withQuickjump << [ + ppPrologue pkg qual doctitle prologue, + ppSignatureTrees pkg qual sig_trees, + ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + where + -- Extract a module's short description. + toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) + toInstalledDescription = fmap mkMeta . hmi_description . instInfo -ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html -ppPrologue _ _ Nothing = noHtml -ppPrologue qual title (Just doc) = - divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) +ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html +ppPrologue _ _ _ Nothing = noHtml +ppPrologue pkg qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) +ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html +ppSignatureTrees _ _ tss | all (null . snd) tss = mempty +ppSignatureTrees pkg qual [(info, ts)] = + divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts) +ppSignatureTrees pkg qual tss = + divModuleList << + (sectionName << "Signatures" + +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts + | (i, (info, ts)) <- zip [(1::Int)..] tss + ]) -ppModuleTree :: Qualification -> [ModuleTree] -> Html -ppModuleTree qual ts = - divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) +ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html +ppSignatureTree _ _ _ _ [] = mempty +ppSignatureTree pkg qual p info ts = + divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) +ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html +ppModuleTrees _ _ tss | all (null . snd) tss = mempty +ppModuleTrees pkg qual [(info, ts)] = + divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts) +ppModuleTrees pkg qual tss = + divPackageList << + (sectionName << "Packages" + +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts + | (i, (info, ts)) <- zip [(1::Int)..] tss + ]) -mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html -mkNodeList qual ss p ts = case ts of +ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html +ppModuleTree _ _ _ _ [] = mempty +ppModuleTree pkg qual p info ts = + divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) + + +mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList pkg qual ss p ts = case ts of [] -> noHtml - _ -> unordList (zipWith (mkNode qual ss) ps ts) + _ -> unordList (zipWith (mkNode pkg qual ss) ps ts) where ps = [ p ++ '.' : show i | i <- [(1::Int)..]] -mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg srcPkg short ts) = +mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html +mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_:_, False) -> collapseControl p True "module" + (_:_, Nothing) -> collapseControl p "module" (_, _ ) -> [theclass "module"] cBtn = case (ts, leaf) of - (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml + ([] , Just _) -> thespan ! [theclass "noexpander"] << spaceHtml (_, _ ) -> noHtml -- We only need an explicit collapser button when the module name -- is also a leaf, and so is a link to a module page. Indeed, the -- spaceHtml is a minor hack and does upset the layout a fraction. htmlModule = thespan ! modAttrs << (cBtn +++ - if leaf - then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) - (mkModuleName mdl)) - else toHtml s + case leaf of + Just m -> ppModule m + Nothing -> toHtml s ) - mdl = intercalate "." (reverse (s:ss)) - - shortDescr = maybe noHtml (origDocToHtml qual) short + shortDescr = maybe noHtml (origDocToHtml pkg qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg - subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" - - + subtree = + if null ts then noHtml else + collapseDetails p DetailsOpen ( + thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++ + mkNodeList pkg qual (s:ss) p ts + ) -------------------------------------------------------------------------------- -- * Generate the index -------------------------------------------------------------------------------- +data JsonIndexEntry = JsonIndexEntry { + jieHtmlFragment :: String, + jieName :: String, + jieModule :: String, + jieLink :: String + } + deriving Show +instance ToJSON JsonIndexEntry where + toJSON JsonIndexEntry + { jieHtmlFragment + , jieName + , jieModule + , jieLink } = + Object + [ "display_html" .= String jieHtmlFragment + , "name" .= String jieName + , "module" .= String jieModule + , "link" .= String jieLink + ] + +instance FromJSON JsonIndexEntry where + parseJSON = withObject "JsonIndexEntry" $ \v -> + JsonIndexEntry + <$> v .: "display_html" + <*> v .: "name" + <*> v .: "module" + <*> v .: "link" + +ppJsonIndex :: FilePath + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Bool + -> Maybe Package + -> QualOption + -> [Interface] + -> [FilePath] -- ^ file paths to interface files + -- (--read-interface) + -> IO () +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do + createDirectoryIfMissing True odir + (errors, installedIndexes) <- + partitionEithers + <$> traverse + (\ifaceFile -> do + let indexFile = takeDirectory ifaceFile + FilePath. "doc-index.json" + a <- doesFileExist indexFile + if a then + bimap (indexFile,) (map (fixLink ifaceFile)) + <$> eitherDecodeFile @[JsonIndexEntry] indexFile + else + return (Right []) + ) + installedIfacesPaths + traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err) + errors + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> + Builder.hPutBuilder + h (encodeToBuilder (encodeIndexes (concat installedIndexes))) + where + encodeIndexes :: [JsonIndexEntry] -> Value + encodeIndexes installedIndexes = + toJSON + (concatMap fromInterface ifaces + ++ installedIndexes) + + fromInterface :: Interface -> [JsonIndexEntry] + fromInterface iface = + mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface + where + aliases = ifaceModuleAliases iface + qual = makeModuleQual qual_opt aliases mdl + mdl = ifaceMod iface + + mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry + mkIndex mdl qual item + | Just item_html <- processExport True links_info unicode pkg qual item + = Just JsonIndexEntry + { jieHtmlFragment = showHtmlFragment item_html + , jieName = unwords (map getOccString names) + , jieModule = moduleString mdl + , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names)) + } + | otherwise = Nothing + where + names = exportName item ++ exportSubs item + + exportSubs :: ExportItem DocNameI -> [IdP DocNameI] + exportSubs (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDSubDocs } })) = map fst expDSubDocs + exportSubs _ = [] + + exportName :: ExportItem DocNameI -> [IdP DocNameI] + exportName (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDDecl } })) = getMainDeclBinderI (unLoc expDDecl) + exportName ExportNoDecl { expItemName } = [expItemName] + exportName _ = [] + + nameLink :: NamedThing name => Module -> name -> String + nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName + + links_info = (maybe_source_url, maybe_wiki_url) + + -- update link using relative path to output directory + fixLink :: FilePath + -> JsonIndexEntry -> JsonIndexEntry + fixLink ifaceFile jie = + jie { jieLink = makeRelative odir (takeDirectory ifaceFile) + FilePath. jieLink jie } + ppHtmlIndex :: FilePath -> String -> Maybe String @@ -339,11 +555,12 @@ -> Maybe String -> SourceURLs -> WikiURLs + -> Bool -- ^ With Quick Jump? -> [InstalledInterface] -> Bool -> IO () ppHtmlIndex odir doctitle _maybe_package themes - maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do let html = indexPage split_indices Nothing (if split_indices then [] else index) @@ -353,16 +570,16 @@ mapM_ (do_sub_index index) initialChars -- Let's add a single large index as well for those who don't know exactly what they're looking for: let mergedhtml = indexPage False Nothing index - writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) - writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html) where indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url +++ + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url - maybe_contents_url Nothing << [ + maybe_contents_url Nothing withQuickjump << [ if showLetters then indexInitialLetterLinks else noHtml, if null items then noHtml else divIndex << [sectionName << indexName ch, buildIndex items] @@ -396,7 +613,7 @@ do_sub_index this_ix c = unless (null index_part) $ - writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] @@ -411,14 +628,34 @@ -- that export that entity. Each of the modules exports the entity -- in a visible or invisible way (hence the Bool). full_index :: Map String (Map GHC.Name [(Module,Bool)]) - full_index = Map.fromListWith (flip (Map.unionWith (++))) - (concatMap getIfaceIndex ifaces) + full_index = foldl' f Map.empty ifaces + where + f :: Map String (Map Name [(Module, Bool)]) + -> InstalledInterface + -> Map String (Map Name [(Module, Bool)]) + f !idx iface = + Map.unionWith + (Map.unionWith (\a b -> let !x = force $ a ++ b in x)) + idx + (getIfaceIndex iface) + + getIfaceIndex :: InstalledInterface -> Map String (Map Name [(Module, Bool)]) getIfaceIndex iface = - [ (getOccString name - , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) - | name <- instExports iface ] + foldl' f Map.empty (instExports iface) where + f :: Map String (Map Name [(Module, Bool)]) + -> Name + -> Map String (Map Name [(Module, Bool)]) + f !idx name = + let !vis = name `Set.member` visible + in + Map.insertWith + (Map.unionWith (++)) + (getOccString name) + (Map.singleton name [(mdl, vis)]) + idx + mdl = instMod iface visible = Set.fromList (instVisibleExports iface) @@ -459,46 +696,49 @@ ppHtmlModule :: FilePath -> String -> Themes - -> Maybe String -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> QualOption + -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL + -> Maybe String -> Maybe String + -> Bool -- ^ With Quick Jump? + -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes - maybe_mathjax_url maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug iface = do + maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url + maybe_contents_url maybe_index_url withQuickjump + unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface mdl_str = moduleString mdl + mdl_str_annot = mdl_str ++ if ifaceIsSig iface + then " (signature)" + else "" + 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 (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url +++ + headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), - ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + maybe_contents_url maybe_index_url withQuickjump << [ + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug + writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) -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) +signatureDocURL :: String +signatureDocURL = "https://wiki.haskell.org/Module_signature" -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html -ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual - = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual + = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++ description +++ synopsis +++ divInterface (maybe_doc_hdr +++ bdy +++ orphans) @@ -507,7 +747,17 @@ -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDMbDoc = + ( Documentation mDoc mWarn, _ ) + } + } + ) + ) = isJust mDoc || isJust mWarn has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True @@ -516,17 +766,19 @@ description | isNoHtml doc = doc | otherwise = divDescription $ sectionName << "Description" +++ doc - where doc = docSection Nothing qual (ifaceRnDoc iface) + where doc = docSection Nothing pkg qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis | no_doc_at_all = noHtml | otherwise = divSynopsis $ - paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ - shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports - ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + collapseDetails "syn" DetailsClosed ( + thesummary << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode pkg qual) exports + ) ! collapseToggle "syn" "" + ) -- if the documentation doesn't begin with a section header, then -- add one ("Documentation"). @@ -538,76 +790,40 @@ bdy = foldr (+++) noHtml $ - mapMaybe (processExport False linksInfo unicode qual) exports + mapMaybe (processExport False linksInfo unicode pkg qual) exports orphans = - ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual + ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg 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 +ppModuleContents :: Maybe Package -- ^ This package + -> Qualification + -> [ExportItem DocNameI] + -> Bool -- ^ Orphans sections -> Html -ppModuleContents qual exports orphan +ppModuleContents pkg qual exports orphan | null sections && not orphan = noHtml | otherwise = contentsDiv where - contentsDiv = divTableOfContents << ( - sectionName << "Contents" +++ - unordList (sections ++ orphanSection)) + contentsDiv = divTableOfContents << (divContentsList << ( + (sectionName << "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] +++ + unordList (sections ++ orphanSection))) (sections, _leftovers{-should be []-}) = process 0 exports orphanSection | orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ] | otherwise = [] - process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI]) process _ [] = ([], []) process n items@(ExportGroup lev id0 doc : rest) | lev <= n = ( [], items ) | otherwise = ( html:secs, rest2 ) where html = linkedAnchor (groupId id0) - << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs + << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs (ssecs, rest1) = process lev rest (secs, rest2) = process n rest1 process n (_ : rest) = process n rest @@ -617,32 +833,55 @@ -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: -numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI] numberSectionHeadings = go 1 - where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es + = case collectAnchors doc of + [] -> ExportGroup lev (show n) doc : go (n+1) es + (a:_) -> ExportGroup lev a doc : go (n+1) es go n (other:es) = other : go n es + collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String] + collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b + collectAnchors (DocAName a) = [a] + collectAnchors _ = [] -processExport :: Bool -> LinksInfo -> Bool -> Qualification - -> ExportItem DocName -> Maybe Html -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 _ _ qual (ExportNoDecl y []) +processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification + -> ExportItem DocNameI -> Maybe Html +processExport _ _ _ _ _ + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD + { expDDecl = L _ (InstD {}) + } + } + ) + ) + = Nothing -- Hide empty instances +processExport summary links unicode pkg qual + ( ExportDecl + ( RnExportD + { rnExpDExpD = + ExportD decl pats doc subdocs insts fixities splice + } + ) + ) + = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual +processExport summary _ _ pkg qual (ExportGroup lev id0 doc) + = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +processExport summary _ _ _ qual (ExportNoDecl y []) = processDeclOneLiner summary $ ppDocName qual Prefix True y -processExport summary _ _ qual (ExportNoDecl y subs) +processExport summary _ _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual Prefix True y +++ parenList (map (ppDocName qual Prefix True) subs) -processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection_ Nothing qual doc -processExport summary _ _ _ (ExportModule mdl) +processExport summary _ _ pkg qual (ExportDoc doc) + = nothingIf summary $ docSection_ Nothing pkg qual doc +processExport summary _ _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl @@ -664,7 +903,8 @@ processDeclOneLiner False = Just . divTopDecl . declElem groupHeading :: Int -> String -> Html -> Html -groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] +groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId] + where grpId = groupId id0 groupTag :: Int -> Html -> Html groupTag lev diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,1051 +1,1312 @@ {-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Decl --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Decl ( - ppDecl, - - ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances, - tyvarNames -) where - -import Haddock.Backends.Xhtml.DocMarkup -import Haddock.Backends.Xhtml.Layout -import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils -import Haddock.GhcUtils -import Haddock.Types -import Haddock.Doc (combineDocumentation) - -import Data.List ( intersperse, sort ) -import qualified Data.Map as Map -import Data.Maybe -import Text.XHtml hiding ( name, title, p, quote ) - -import GHC -import GHC.Exts -import Name -import BooleanFormula -import RdrName ( rdrNameOcc ) - -ppDecl :: Bool -> LinksInfo -> LHsDecl 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 - 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@(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 - (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname - ty fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual - InstD _ -> noHtml - _ -> error "declaration not supported by ppDecl" - - -ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities - splice unicode qual - -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual - where - pp_typ = ppLType unicode qual typ - -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> LHsSigType DocName -> - [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual - | summary = pref1 - | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing qual doc - where - pref1 = hsep [ keyword "pattern" - , ppBinder summary occname - , dcolon unicode - , ppLType unicode qual (hsSigType typ) - ] - - occname = nameOccName . getName $ name - -ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> - Splice -> Unicode -> Qualification -> Html -ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual = - ppTypeOrFunSig summary links loc docnames typ doc - ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode - , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames - , dcolon unicode - ) - splice unicode qual - where - occnames = map (nameOccName . getName) docnames - addFixities html - | summary = html - | otherwise = html <+> ppFixities fixities qual - - -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName - -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual - | summary = pref1 - | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc - | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc - where - curName = getName <$> listToMaybe docnames - argDoc n = Map.lookup n argDocs - - do_largs n leader (L _ t) = do_args n leader t - - do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy tvs ltype) - = do_largs n leader' ltype - where - leader' = leader <+> ppForAll tvs unicode qual - - do_args n leader (HsQualTy lctxt ltype) - | null (unLoc lctxt) - = do_largs n leader ltype - | otherwise - = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) - : do_largs n (darrow unicode) ltype - - do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) - : do_largs (n+1) (arrow unicode) r - do_args n leader t - = [(leader <+> ppType unicode qual t, argDoc n, [])] - -ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html -ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of - [] -> noHtml - ts -> forallSymbol unicode <+> hsep ts +++ dot - where ppKTv n k = parens $ - ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k - -ppFixities :: [(DocName, Fixity)] -> Qualification -> Html -ppFixities [] _ = noHtml -ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge - where - ppFix (ns, p, d) = thespan ! [theclass "fixity"] << - (toHtml d <+> toHtml (show p) <+> ppNames ns) - - ppDir InfixR = "infixr" - ppDir InfixL = "infixl" - ppDir InfixN = "infix" - - ppNames = case fs of - _:[] -> const noHtml -- Don't display names for fixities on single names - _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) - - uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs - , let d' = ppDir d - , then group by Down (p,d') using groupWith ] - - rightEdge = thespan ! [theclass "rightedge"] << noHtml - - --- | Pretty-print type variables. -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] -ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs - -tyvarNames :: LHsQTyVars DocName -> [Name] -tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit - - -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> ForeignDecl DocName -> [(DocName, Fixity)] - -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities - splice unicode qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual -ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" - - --- we skip type patterns for now -ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan - -> DocForDecl DocName -> TyClDecl DocName - -> Splice -> Unicode -> Qualification -> Html -ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars - , tcdRhs = ltype }) - splice unicode qual - = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc - (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual - where - hdr = hsep ([keyword "type", ppBinder summary occ] - ++ ppTyVars (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppLType unicode qual ltype - occ = nameOccName . getName $ name - fixs - | summary = noHtml - | otherwise = ppFixities fixities qual -ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" - - -ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html -ppTypeSig summary nms pp_ty unicode = - concatHtml htmlNames <+> dcolon unicode <+> pp_ty - where - htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - - -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan - -> [DocName] -> HsType DocName - -> Html -ppSimpleSig links splice unicode qual loc names typ = - topDeclElem' names $ ppTypeSig True occNames ppTyp unicode - where - topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual typ - occNames = map getOccName names - - --------------------------------------------------------------------------------- --- * Type families --------------------------------------------------------------------------------- - - -ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html -ppFamilyInfo assoc OpenTypeFamily - | assoc = keyword "type" - | otherwise = keyword "type family" -ppFamilyInfo assoc DataFamily - | assoc = keyword "data" - | otherwise = keyword "data family" -ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" - - -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName - -> Unicode -> Qualification -> Html -ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdResultSig = L _ result - , fdInjectivityAnn = injectivity }) - unicode qual = - (case info of - OpenTypeFamily - | associated -> keyword "type" - | otherwise -> keyword "type family" - DataFamily - | associated -> keyword "data" - | otherwise -> keyword "data family" - ClosedTypeFamily _ - -> keyword "type family" - ) <+> - - ppFamDeclBinderWithVars summary unicode qual d <+> - ppResultSig result unicode qual <+> - - (case injectivity of - Nothing -> noHtml - Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn - ) <+> - - (case info of - ClosedTypeFamily _ -> keyword "where ..." - _ -> mempty - ) - -ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html -ppResultSig result unicode qual = case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr - -ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName - -> Html -ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = - ppFamilyInfo True pfdInfo <+> - ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> - ppResultSig (unLoc pfdKindSig) unicode qual - -ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html -ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = - char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> - hsep (map (ppLDocName qual Raw) rhs) - - -ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> - [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html -ppTyFam summary associated links instances fixities loc doc decl splice unicode qual - - | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit - - where - docname = unLoc $ fdLName decl - - header_ = topDeclElem links loc splice [docname] $ - ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual - - instancesBit - | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl - , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns - - | otherwise - = ppInstances links (OriginFamily docname) instances splice unicode qual - - -- Individual equation of a closed type family - ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsIB { hsib_body = ts }} - = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual - <+> equals <+> ppType unicode qual (unLoc rhs) - , Nothing, [] ) - - - -ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification - -> PseudoFamilyDecl DocName - -> Html -ppPseudoFamilyDecl links splice unicode qual - decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = - wrapper $ ppPseudoFamilyHeader unicode qual decl - where - wrapper = topDeclElem links loc splice [name] - - --------------------------------------------------------------------------------- --- * Associated Types --------------------------------------------------------------------------------- - - -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName - -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppAssocType summ links doc (L loc decl) fixities splice unicode qual = - ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual - - --------------------------------------------------------------------------------- --- * TyClDecl helpers --------------------------------------------------------------------------------- - --- | Print a type family and its variables -ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html -ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = - ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs) - --- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html -ppDataBinderWithVars summ decl = - ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) - --------------------------------------------------------------------------------- --- * Type applications --------------------------------------------------------------------------------- - -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html -ppAppDocNameTyVarBndrs summ unicode qual n vs = - ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual) - where - ppDN notation = ppBinderFixity notation summ . nameOccName . getName - ppBinderFixity Infix = ppBinderInfix - ppBinderFixity _ = ppBinder - --- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] - -> Unicode -> Qualification -> Html -ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) - - --- | Print an application of a 'DocName' and a list of 'Names' -ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html -ppAppDocNameNames summ n ns = - ppTypeApp n [] ns ppDN ppTyName - where - ppDN notation = ppBinderFixity notation summ . nameOccName . getName - ppBinderFixity Infix = ppBinderInfix - ppBinderFixity _ = ppBinder - --- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html -ppTypeApp n [] (t1:t2:rest) ppDN ppT - | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) - | operator = opApp - where - operator = isNameSym . getName $ n - opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 - -ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) - - -------------------------------------------------------------------------------- --- * Contexts -------------------------------------------------------------------------------- - - -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc - -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ - ppContextNoLocsMaybe (map unLoc cxt) unicode qual - - -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ - ppContextNoLocsMaybe cxt unicode qual - - -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html -ppContextNoLocsMaybe [] _ _ = Nothing -ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual - -ppContext :: HsContext DocName -> Unicode -> Qualification -> Html -ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual - - -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html -ppHsContext [] _ _ = noHtml -ppHsContext [p] unicode qual = ppCtxType unicode qual p -ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) - - -------------------------------------------------------------------------------- --- * Class declarations -------------------------------------------------------------------------------- - - -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] - -> Unicode -> Qualification -> Html -ppClassHdr summ lctxt n tvs fds unicode qual = - keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames tvs) - <+> ppFds fds unicode qual - - -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html -ppFds fds unicode qual = - if null fds then noHtml else - char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) - where - fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 - ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) - -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan - -> [(DocName, DocForDecl DocName)] - -> Splice -> Unicode -> Qualification -> Html -ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs - , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc - subdocs splice unicode qual = - if not (any isUserLSig sigs) && null ats - then (if summary then id else topDeclElem links loc splice [nm]) hdr - else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") - +++ shortSubDecls False - ( - [ ppAssocType summary links doc at [] splice unicode qual | at <- ats - , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ - - -- ToDo: add associated type defaults - - [ ppFunSig summary links loc doc names (hsSigWcType typ) - [] splice unicode qual - | L _ (TypeSig lnames typ) <- sigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? - ) - where - hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual - nm = unLoc lname -ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - - - -ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] - -> SrcSpan -> Documentation DocName - -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName - -> Splice -> Unicode -> Qualification -> Html -ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) - splice unicode qual - | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual - | otherwise = classheader +++ docSection Nothing qual d - +++ minimalBit +++ atBit +++ methodBit +++ instancesBit - where - sigs = map unLoc lsigs - - classheader - | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) - | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) - - -- Only the fixity relevant to the class header - fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - - nm = tcdName decl - - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - - methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) - subfixs splice unicode qual - | L _ (ClassOpSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - subfixs = [ f | n <- names - , f@(n',_) <- fixities - , n == n' ] - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? - - minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of - -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] - -> noHtml - - -- Minimal complete definition = the only shown method - Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] - -> noHtml - - -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml "Nothing" - - m : _ -> subMinimal $ ppMinimal False m - _ -> noHtml - - ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs - where wrap | p = parens | otherwise = id - ppMinimal p (Parens x) = ppMinimal p (unLoc x) - - instancesBit = ppInstances links (OriginClass nm) instances - splice unicode qual - -ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - - -ppInstances :: LinksInfo - -> InstOrigin DocName -> [DocInstance DocName] - -> Splice -> Unicode -> Qualification - -> Html -ppInstances links origin instances splice unicode qual - = subInstances qual instName links True (zipWith instDecl [1..] instances) - -- force Splice = True to use line URLs - where - instName = getOccString origin - instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) - instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) - - -ppOrphanInstances :: LinksInfo - -> [DocInstance DocName] - -> Splice -> Unicode -> Qualification - -> Html -ppOrphanInstances links instances splice unicode qual - = subOrphanInstances qual links True (zipWith instDecl [1..] instances) - where - instOrigin :: InstHead name -> InstOrigin name - instOrigin inst = OriginClass (ihdClsName inst) - - instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) - instDecl no (inst, mdoc, loc) = - ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) - - -ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification - -> Maybe (MDoc DocName) - -> InstOrigin DocName - -> Bool -- ^ Is instance orphan - -> Int -- ^ Normal - -> InstHead DocName - -> SubDecl -ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = - case ihdInstType of - ClassInst { .. } -> - ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ - , mdoc - , [subInstDetails iid ats sigs] - ) - where - sigs = ppInstanceSigs links splice unicode qual clsiSigs - ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys - TypeInst rhs -> - ( subInstHead iid ptype - , mdoc - , [subFamInstDetails iid prhs] - ) - where - ptype = keyword "type" <+> typ - prhs = ptype <+> maybe noHtml - (\t -> equals <+> ppType unicode qual t) rhs - DataInst dd -> - ( subInstHead iid pdata - , mdoc - , [subFamInstDetails iid pdecl]) - where - pdata = keyword "data" <+> typ - pdecl = pdata <+> ppShortDataDecl False True dd unicode qual - where - iid = instanceId origin no orphan ihd - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual - - -ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> [PseudoFamilyDecl DocName] - -> [Html] -ppInstanceAssocTys links splice unicode qual = - map ppFamilyDecl' - where - ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual - - -ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> [Sig DocName] - -> [Html] -ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames typ <- sigs - let names = map unLoc lnames - L loc rtyp = get_type typ - return $ ppSimpleSig links splice unicode qual loc names rtyp - where - get_type = hswc_body . hsib_body - - -lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 -lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n - - -instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String -instanceId origin no orphan ihd = concat $ - [ "o:" | orphan ] ++ - [ qual origin - , ":" ++ getOccString origin - , ":" ++ (occNameString . getOccName . ihdClsName) ihd - , ":" ++ show no - ] - where - qual (OriginClass _) = "ic" - qual (OriginData _) = "id" - qual (OriginFamily _) = "if" - - -------------------------------------------------------------------------------- --- * Data & newtype declarations -------------------------------------------------------------------------------- - - --- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html -ppShortDataDecl summary dataInst dataDecl unicode qual - - | [] <- cons = dataHeader - - | [lcon] <- cons, isH98, - (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual - = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - - | isH98 = dataHeader - +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) - - | otherwise = (dataHeader <+> keyword "where") - +++ shortSubDecls dataInst (map doGADTConstr cons) - - where - dataHeader - | dataInst = noHtml - | otherwise = ppDataHeader summary dataDecl unicode qual - doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual - doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - - cons = dd_cons (tcdDataDefn dataDecl) - isH98 = case unLoc (head cons) of - ConDeclH98 {} -> True - ConDeclGADT{} -> False - - -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> - Splice -> Unicode -> Qualification -> Html -ppDataDecl summary links instances fixities subdocs loc doc dataDecl - splice unicode qual - - | summary = ppShortDataDecl summary False dataDecl unicode qual - | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit - - where - docname = tcdName dataDecl - cons = dd_cons (tcdDataDefn dataDecl) - isH98 = case unLoc (head cons) of - ConDeclH98 {} -> True - ConDeclGADT{} -> False - - header_ = topDeclElem links loc splice [docname] $ - ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix - - fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual - - whereBit - | null cons = noHtml - | otherwise = if isH98 then noHtml else keyword "where" - - constrBit = subConstructors qual - [ ppSideBySideConstr subdocs subfixs unicode qual c - | c <- cons - , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNames (unLoc c)))) fixities - ] - - instancesBit = ppInstances links (OriginData docname) instances - splice unicode qual - - - -ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html -ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot - where - (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual - - --- returns three pieces: header, body, footer so that header & footer can be --- incorporated into the declaration -ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con of - ConDeclH98{} -> case con_details con of - PrefixCon args -> - (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual) args), noHtml, noHtml) - RecCon (L _ fields) -> - (header_ unicode qual +++ ppOcc <+> char '{', - doRecordFields fields, - char '}') - InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppOccInfix, ppLParendType unicode qual arg2], - noHtml, noHtml) - - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) - - where - resTy = hsib_body (con_type con) - - doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - - header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder summary one - _ -> hsep (punctuate comma (map (ppBinder summary) occ)) - - ppOccInfix = case occ of - [one] -> ppBinderInfix summary one - _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - - ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) - tyVars = tyvarNames ltvs - lcontext = fromMaybe (noLoc []) (con_cxt con) - context = unLoc lcontext - forall_ = False - - --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode - -> Qualification -> Html -ppConstrHdr forall_ tvs ctxt unicode qual - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") - where - ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " - | otherwise = noHtml - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) - = (decl, mbDoc, fieldPart) - where - decl = case con of - ConDeclH98{} -> case con_details con of - PrefixCon args -> - hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual) args) - <+> fixity - - RecCon _ -> header_ +++ ppOcc <+> fixity - - InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual arg1, - ppOccInfix, - ppLParendType unicode qual arg2] - <+> fixity - - ConDeclGADT{} -> doGADTCon resTy - - resTy = hsib_body (con_type con) - - fieldPart = case getConDetails con of - RecCon (L _ fields) -> [doRecordFields fields] - _ -> [] - - doRecordFields fields = subFields qual - (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - - doGADTCon :: Located (HsType DocName) -> Html - doGADTCon ty = ppOcc <+> dcolon unicode - -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual ty - <+> fixity - - fixity = ppFixities fixities qual - header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder False one - _ -> hsep (punctuate comma (map (ppBinder False) occ)) - - ppOccInfix = case occ of - [one] -> ppBinderInfix False one - _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) - forall_ = False - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= - combineDocumentation . fst - - -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification - -> ConDeclField DocName -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, - mbDoc, - []) - where - -- don't use cd_fld_doc for same reason we don't use con_doc above - -- Where there is more than one name, they all have the same documentation - mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst - - -ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html -ppShortField summary unicode qual (ConDeclField names ltype _) - = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) - <+> dcolon unicode <+> ppLType unicode qual ltype - - --- | Print the LHS of a data\/newtype declaration. --- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html -ppDataHeader summary decl@(DataDecl { tcdDataDefn = - HsDataDefn { dd_ND = nd - , dd_ctxt = ctxt - , dd_kindSig = ks } }) - unicode qual - = -- newtype or data - (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) - <+> - -- context - ppLContext ctxt unicode qual <+> - -- T a b c ..., or a :+: b - ppDataBinderWithVars summary decl - <+> case ks of - Nothing -> mempty - Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x - -ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" - --------------------------------------------------------------------------------- --- * Types and contexts --------------------------------------------------------------------------------- - - -ppBang :: HsSrcBang -> Html -ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" -ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" -ppBang _ = noHtml - - -tupleParens :: HsTupleSort -> [Html] -> Html -tupleParens HsUnboxedTuple = ubxParenList -tupleParens _ = parenList - - --------------------------------------------------------------------------------- --- * Rendering of HsType --------------------------------------------------------------------------------- - - -pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC -pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type - -- (as opposed to (ctx1, ctx2) => type) -pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = 3 :: Int -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = 4 :: Int -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> Html -> Html -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification - -> Located (HsType DocName) -> Html -ppLType unicode qual y = ppType unicode qual (unLoc y) -ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) -ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) - - -ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification - -> HsType DocName -> Html -ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual -ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual -ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual - -ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html -ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = - ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar name kind) = - parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> - ppLKind unicode qual kind) - -ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html -ppLKind unicode qual y = ppKind unicode qual (unLoc y) - -ppKind :: Unicode -> Qualification -> HsKind DocName -> Html -ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual - -ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html -ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) - - -ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual - -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual - --- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar (L _ name)) True _ - | getOccString (getName name) == "*" = toHtml "★" - | getOccString (getName name) == "(->)" = toHtml "(→)" - -ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q -ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q = - parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q -ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" - -- Can now legally occur in ConDeclGADT, the output here is to provide a - -- placeholder in the signature, which is followed by the field - -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual - = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual - where - -- `(:)` is valid in type signature only as constructor to promoted list - -- and needs to be quoted in code so we explicitly quote it here too. - ppr_op - | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' - | otherwise = ppr_op' - ppr_op' = ppLDocName qual Infix op - -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual - = ppr_mono_lty ctxt_prec ty unicode qual - -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n - -ppr_tylit :: HsTyLit -> Html -ppr_tylit (HsNumTy _ n) = toHtml (show n) -ppr_tylit (HsStrTy _ s) = toHtml (show s) - - -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual - in - maybeParen ctxt_prec pREC_FUN $ - hsep [p1, arrow unicode <+> p2] +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Decl +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Decl ( + ppDecl, + ppOrphanInstances, +) where + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Doc (combineDocumentation) + +import Data.Foldable ( toList ) +import Data.List ( intersperse, sort ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.Map as Map +import Data.Maybe +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC.Core.Type ( Specificity(..) ) +import GHC hiding (LexicalFixity(..), fromMaybeContext) +import GHC.Exts hiding (toList) +import GHC.Types.Name +import GHC.Data.BooleanFormula +import GHC.Types.Name.Reader ( rdrNameOcc ) + +-- | Pretty print a declaration +ppDecl :: Bool -- ^ print summary info only + -> LinksInfo -- ^ link information + -> LHsDecl DocNameI -- ^ declaration to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant pattern synonyms + -> DocForDecl DocName -- ^ documentation for this decl + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls + -> Splice + -> Unicode -- ^ unicode output + -> Maybe Package + -> Qualification + -> Html +ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of + TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames + (dropWildCards lty) fixities splice unicode pkg qual + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames + lty fixities splice unicode pkg qual + ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual + InstD _ _ -> noHtml + DerivD _ _ -> noHtml + _ -> error "declaration not supported by ppDecl" + + +ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities + splice unicode pkg qual + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> + Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) + splice unicode pkg qual HideEmptyContexts + where + pp_typ = ppLSigType unicode qual HideEmptyContexts typ + +-- | Pretty print a pattern synonym +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> [LocatedN DocName] -- ^ names of patterns in declaration + -> LHsSigType DocNameI -- ^ type of patterns in declaration + -> [(DocName, Fixity)] + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities + (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ) + where + pp_typ = ppPatSigType unicode qual typ + + +ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) -> + Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html +ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) + splice unicode pkg qual emptyCtxts = + ppTypeOrFunSig summary links loc docnames typ doc + ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode + , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames + , dcolon unicode + ) + splice unicode pkg qual emptyCtxts + where + occnames = map (nameOccName . getName) docnames + addFixities html + | summary = html + | otherwise = html <+> ppFixities fixities qual + + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI + -> DocForDecl DocName -> (Html, Html, Html) + -> Splice -> Unicode -> Maybe Package -> Qualification + -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) + splice unicode pkg qual emptyCtxts + | summary = pref1 + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc + | otherwise = topDeclElem links loc splice docnames pref2 + +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) + +++ docSection curname pkg qual doc + where + curname = getName <$> listToMaybe docnames + + +-- | This splits up a type signature along @->@ and adds docs (when they exist) +-- to the arguments. +-- +-- If one passes in a list of the available subdocs, any top-level `HsRecTy` +-- found will be expanded out into their fields. +ppSubSigLike :: Unicode -> Qualification + -> HsSigType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when + -- we expand an `HsRecTy`) + -> Html -> HideEmptyContexts -> [SubDecl] +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ + where + do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl] + do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) = + case outer_bndrs of + HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype + HsOuterImplicit{} -> do_largs n leader ltype + where + leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs) + + argDoc n = Map.lookup n argDocs + + do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl] + do_largs n leader (L _ t) = do_args n leader t + + do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] + do_args n leader (HsForAllTy _ tele ltype) + = do_largs n leader' ltype + where + leader' = leader <+> ppForAllPart unicode qual tele + + do_args n leader (HsQualTy _ lctxt ltype) + | null (unLoc lctxt) + = do_largs n leader ltype + | otherwise + = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) + : do_largs n (darrow unicode) ltype + + do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r) + = [ (ldr <+> html, mdoc, subs) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + + do_args n leader (HsFunTy _ _w lt r) + = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) + : do_largs (n+1) (arrow unicode) r + + do_args n leader t + = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] + + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" + gadtOpen = toHtml "{" + + +ppFixities :: [(DocName, Fixity)] -> Qualification -> Html +ppFixities [] _ = noHtml +ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge + where + ppFix (ns, p, d) = thespan ! [theclass "fixity"] << + (toHtml d <+> toHtml (show p) <+> ppNames ns) + + ppDir InfixR = "infixr" + ppDir InfixL = "infixl" + ppDir InfixN = "infix" + + ppNames = case fs of + _:[] -> const noHtml -- Don't display names for fixities on single names + _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) + + uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs + , let d' = ppDir d + , then group by Down (p,d') using groupWith ] + + rightEdge = thespan ! [theclass "rightedge"] << noHtml + + +-- | Pretty-print type variables. +ppTyVars :: RenderableBndrFlag flag => + Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html] +ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs + + +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> ForeignDecl DocNameI -> [(DocName, Fixity)] + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities + splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual +ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" + + +-- we skip type patterns for now +ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan + -> DocForDecl DocName -> TyClDecl DocNameI + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) + splice unicode pkg qual + = ppTypeOrFunSig summary links loc [name] sig_type doc + (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) + splice unicode pkg qual ShowEmptyToplevelContexts + where + sig_type = mkHsImplicitSigTypeI ltype + hdr = hsep ([keyword "type", ppBinder summary occ] + ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) + full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type) + occ = nameOccName . getName $ name + fixs + | summary = noHtml + | otherwise = ppFixities fixities qual +ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" + + +ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html +ppTypeSig summary nms pp_ty unicode = + concatHtml htmlNames <+> dcolon unicode <+> pp_ty + where + htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms + +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan + -> [DocName] -> HsSigType DocNameI + -> Html +ppSimpleSig links splice unicode qual emptyCtxts loc names typ = + topDeclElem' names $ ppTypeSig True occNames ppTyp unicode + where + topDeclElem' = topDeclElem links loc splice + ppTyp = ppSigType unicode qual emptyCtxts typ + occNames = map getOccName names + + +-------------------------------------------------------------------------------- +-- * Type families +-------------------------------------------------------------------------------- + + +-- | Print a data\/type family declaration +ppFamDecl :: Bool -- ^ is a summary + -> Bool -- ^ is an associated type + -> LinksInfo + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> SrcSpan + -> Documentation DocName -- ^ this decl's documentation + -> FamilyDecl DocNameI -- ^ this decl + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual + | summary = ppFamHeader True associated decl unicode qual + | otherwise = header_ +++ docSection curname pkg qual doc +++ instancesBit + + where + docname = unLoc $ fdLName decl + curname = Just $ getName docname + + header_ = topDeclElem links loc splice [docname] $ + ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual + + instancesBit + | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl + , not summary + = subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns + + | otherwise + = ppInstances links (OriginFamily docname) instances splice unicode pkg qual + + -- Individual equation of a closed type family + ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl + ppFamDeclEqn (FamEqn { feqn_tycon = L _ n + , feqn_rhs = rhs + , feqn_pats = ts }) + = ( ppAppNameTypeArgs n ts unicode qual + <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) + , Nothing + , [] + ) + + +-- | Print a pseudo family declaration +ppPseudoFamDecl :: LinksInfo -> Splice + -> PseudoFamilyDecl DocNameI -- ^ this decl + -> Unicode -> Qualification -> Html +ppPseudoFamDecl links splice + (PseudoFamilyDecl { pfdInfo = info + , pfdKindSig = L _ kindSig + , pfdTyVars = tvs + , pfdLName = L loc name }) + unicode qual = + topDeclElem links (locA loc) splice [name] leader + where + leader = hsep [ ppFamilyLeader True info + , ppAppNameTypes name (map unLoc tvs) unicode qual + , ppResultSig kindSig unicode qual + ] + +-- | Print the LHS of a type\/data family declaration +ppFamHeader :: Bool -- ^ is a summary + -> Bool -- ^ is an associated type + -> FamilyDecl DocNameI -- ^ family declaration + -> Unicode -> Qualification -> Html +ppFamHeader summary associated (FamilyDecl { fdInfo = info + , fdResultSig = L _ result + , fdInjectivityAnn = injectivity + , fdLName = L _ name + , fdTyVars = tvs }) + unicode qual = + hsep [ ppFamilyLeader associated info + , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs) + , ppResultSig result unicode qual + , injAnn + , whereBit + ] + where + whereBit = case info of + ClosedTypeFamily _ -> keyword "where ..." + _ -> noHtml + + injAnn = case injectivity of + Nothing -> noHtml + Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|" + : ppLDocName qual Raw lhs + : arrow unicode + : map (ppLDocName qual Raw) rhs) + Just _ -> error "ppFamHeader:XInjectivityAnn" + +-- | Print the keywords that begin the family declaration +ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html +ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family") + where + typ = case info of + OpenTypeFamily -> "type" + ClosedTypeFamily _ -> "type" + DataFamily -> "data" + +-- | Print the signature attached to a family +ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html +ppResultSig result unicode qual = case result of + NoSig _ -> noHtml + KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + + +-------------------------------------------------------------------------------- +-- * Associated Types +-------------------------------------------------------------------------------- + + +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI + -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package + -> Qualification -> Html +ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = + ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual + + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + +ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag => + Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html +ppAppDocNameTyVarBndrs summ unicode qual n vs = + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) + where + ppDN notation = ppBinderFixity notation summ . nameOccName . getName + ppBinderFixity Infix = ppBinderInfix + ppBinderFixity _ = ppBinder + +-- | Print an application of a 'DocName' to its list of 'HsType's +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypes n ts unicode qual = + ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) + +ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q + = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts) +ppAppNameTypeArgs n args u q + = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args) + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 + +ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext :: Maybe (LHsContext DocNameI) -> Unicode + -> Qualification -> HideEmptyContexts -> Html +ppLContext Nothing u q h = ppContext [] u q h +ppLContext (Just c) u q h = ppContext (unLoc c) u q h + +ppLContextNoArrow :: LHsContext DocNameI -> Unicode + -> Qualification -> HideEmptyContexts -> Html +ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h + +ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts + + +ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual emptyCtxts + + +ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html +ppContextNoLocsMaybe [] _ _ emptyCtxts = + case emptyCtxts of + HideEmptyContexts -> Nothing + ShowEmptyToplevelContexts -> Just (toHtml "()") +ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual + +ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts + + +ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppCtxType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt) + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName + -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI] + -> Unicode -> Qualification -> Html +ppClassHdr summ lctxt n tvs fds unicode qual = + keyword "class" + <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) + <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) + <+> ppFds fds unicode qual + + +ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html +ppFds fds unicode qual = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + fundep (XFunDep _) = error "ppFds" + ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan + -> [(DocName, DocForDecl DocName)] + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc + subdocs splice unicode pkg qual = + if not (any isUserLSig sigs) && null ats + then (if summary then id else topDeclElem links loc splice [nm]) hdr + else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") + +++ shortSubDecls False + ( + [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ + + -- ToDo: add associated type defaults + + [ ppFunSig summary links loc noHtml doc names typ + [] splice unicode pkg qual + | L _ (ClassOpSig _ False lnames typ) <- sigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + ) + where + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual + nm = unLoc lname +ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + + +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] + -> SrcSpan -> Documentation DocName + -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppClassDecl summary links instances fixities loc d subdocs + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = atsDefs }) + splice unicode pkg qual + | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual + | otherwise = classheader +++ docSection curname pkg qual d + +++ minimalBit +++ atBit +++ methodBit +++ instancesBit + where + curname = Just $ getName nm + + sigs = map unLoc lsigs + + classheader + | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) + + -- Only the fixity relevant to the class header + fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual + + nm = tcdNameI decl + + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unLoc . fdLName $ unLoc at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name + ] + + -- Default associated types + ppDefaultAssocTy n (vs,rhs) = hsep + [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals + , ppType unicode qual HideEmptyContexts (unLoc rhs) + ] + + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ)) + | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs })) <- atsDefs + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] typ + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] t [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = noDocForDecl -- TODO: get docs for method defaults + nameStr = getOccString name + ] + + -- Minimal complete definition + minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of + -- Miminal complete definition = every shown method + And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == + sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] + -> noHtml + + -- Minimal complete definition = the only shown method + Var (L _ n) : _ | [getName n] == + [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + -> noHtml + + -- Minimal complete definition = nothing + And [] : _ -> subMinimal $ toHtml "Nothing" + + m : _ -> subMinimal $ ppMinimal False m + _ -> noHtml + + ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs + where wrap | p = parens | otherwise = id + ppMinimal p (Parens x) = ppMinimal p (unLoc x) + + -- Instances + instancesBit = ppInstances links (OriginClass nm) instances + splice unicode pkg qual + +ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + +ppInstances :: LinksInfo + -> InstOrigin DocName -> [DocInstance DocNameI] + -> Splice -> Unicode -> Maybe Package -> Qualification + -> Html +ppInstances links origin instances splice unicode pkg qual + = subInstances pkg qual instName links True (zipWith instDecl [1..] instances) + -- force Splice = True to use line URLs + where + instName = getOccString origin + instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) + instDecl no (inst, mdoc, loc, mdl) = + ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc) + + +ppOrphanInstances :: LinksInfo + -> [DocInstance DocNameI] + -> Splice -> Unicode -> Maybe Package -> Qualification + -> Html +ppOrphanInstances links instances splice unicode pkg qual + = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances) + where + instOrigin :: InstHead name -> InstOrigin (IdP name) + instOrigin inst = OriginClass (ihdClsName inst) + + instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName) + instDecl no (inst, mdoc, loc, mdl) = + ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc) + + +ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification + -> Maybe (MDoc DocName) + -> InstOrigin DocName + -> Bool -- ^ Is instance orphan + -> Int -- ^ Normal + -> InstHead DocNameI + -> Maybe Module + -> SubDecl +ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl = + case ihdInstType of + ClassInst { .. } -> + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ + , mdoc + , [subInstDetails iid ats sigs mname] + ) + where + sigs = ppInstanceSigs links splice unicode qual clsiSigs + ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys + TypeInst rhs -> + ( subInstHead iid ptype + , mdoc + , [subFamInstDetails iid prhs mname] + ) + where + ptype = keyword "type" <+> typ + prhs = ptype <+> maybe noHtml + (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs + DataInst dd -> + ( subInstHead iid pdata + , mdoc + , [subFamInstDetails iid pdecl mname]) + where + cons = dd_cons (tcdDataDefn dd) + pref = case cons of { NewTypeCon _ -> keyword "newtype"; DataTypeCons _ _ -> keyword "data" } + pdata = pref <+> typ + pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual + where + mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl + iid = instanceId origin no orphan ihd + typ = ppAppNameTypes ihdClsName ihdTypes unicode qual + + +ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification + -> [PseudoFamilyDecl DocNameI] + -> [Html] +ppInstanceAssocTys links splice unicode qual = + map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual) + + +ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification + -> [Sig DocNameI] + -> [Html] +ppInstanceSigs links splice unicode qual sigs = do + TypeSig _ lnames typ <- sigs + let names = map unLoc lnames + L _ rtyp = dropWildCards typ + -- Instance methods signatures are synified and thus don't have a useful + -- SrcSpan value. Use the methods name location instead. + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp + + +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n + + +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String +instanceId origin no orphan ihd = concat $ + [ "o:" | orphan ] ++ + [ qual origin + , ":" ++ getOccString origin + , ":" ++ getOccString (ihdClsName ihd) + , ":" ++ show no + ] + where + qual (OriginClass _) = "ic" + qual (OriginData _) = "id" + qual (OriginFamily _) = "if" + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +-- TODO: print contexts +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] + -> Unicode -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl pats unicode qual + + | [] <- toList cons + , [] <- pats = dataHeader + + | [lcon] <- toList cons, [] <- pats, isH98, + (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual + = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot + + | [] <- pats, isH98 = dataHeader + +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') (toList cons) ++ pats1) + + | otherwise = (dataHeader <+> keyword "where") + +++ shortSubDecls dataInst (map doGADTConstr (toList cons) ++ pats1) + + where + dataHeader + | dataInst = noHtml + | otherwise = ppDataHeader summary dataDecl unicode qual + doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual + doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual + + cons = dd_cons (tcdDataDefn dataDecl) + isH98 = flip any (unLoc <$> cons) $ \ case + ConDeclH98 {} -> True + ConDeclGADT{} -> False + + pats1 = [ hsep [ keyword "pattern" + , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames + , dcolon unicode + , ppPatSigType unicode qual typ + ] + | (SigD _ (PatSynSig _ lnames typ),_) <- pats + ] + + +-- | Pretty-print a data declaration +ppDataDecl :: Bool -> LinksInfo + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ all decl documentation + -> SrcSpan + -> Documentation DocName -- ^ this decl's documentation + -> TyClDecl DocNameI -- ^ this decl + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats + splice unicode pkg qual + + | summary = ppShortDataDecl summary False dataDecl pats unicode qual + | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit + + where + docname = tcdNameI dataDecl + curname = Just $ getName docname + cons = dd_cons (tcdDataDefn dataDecl) + isH98 = flip any (unLoc <$> cons) $ \ case + ConDeclH98 {} -> True + ConDeclGADT{} -> False + + header_ = topDeclElem links loc splice [docname] $ + ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix + + fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual + + whereBit + | null cons + , null pats = noHtml + | isH98 = noHtml + | otherwise = keyword "where" + + constrBit = subConstructors pkg qual + [ ppSideBySideConstr subdocs subfixs unicode pkg qual c + | c <- toList cons + , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) + (unL <$> getConNamesI (unLoc c))) fixities + ] + + patternBit = subPatterns pkg qual + [ ppSideBySidePat subfixs unicode qual lnames typ 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 pkg qual + + +ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html +ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot + where + (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual + + +-- returns three pieces: header, body, footer so that header & footer can be +-- incorporated into the declaration +ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) +ppShortConstrParts summary dataInst con unicode qual + = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = tyVars + , con_forall = forall_ + , con_mb_cxt = cxt + } -> let context = fromMaybeContext cxt + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + + -- Prefix constructor, e.g. 'Just a' + PrefixCon _ args -> + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) + , noHtml + , noHtml + ) + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon (L _ fields) -> + ( header_ +++ ppOcc <+> char '{' + , shortSubDecls dataInst [ ppShortField summary unicode qual field + | L _ field <- fields + ] + , char '}' + ) + + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 -> + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) + ] + , noHtml + , noHtml + ) + + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT {} -> + ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ] + , noHtml + , noHtml + ) + + where + occ = toList $ nameOccName . getName . unL <$> getConNamesI con + ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) + + +-- | Pretty print an expanded constructor +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] + -> Unicode -> Maybe Package -> Qualification + -> LConDecl DocNameI -- ^ constructor declaration to print + -> SubDecl +ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) + = ( decl -- Constructor header (name, fixity) + , mbDoc -- Docs on the whole constructor + , fieldPart -- Information on the fields (or arguments, if they have docs) + ) + where + -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) + L _ aConName :| _ = getConNamesI con + + fixity = ppFixities fixities qual + occ = toList $ nameOccName . getName . unL <$> getConNamesI con + + ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = tyVars + , con_forall = forall_ + , con_mb_cxt = cxt + } -> let context = fromMaybeContext cxt + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon _ args + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc + , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args) + , fixity + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ <+> ppOcc <+> fixity + + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1) + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2) + , fixity + ] + + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT{} + | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLSigType unicode qual HideEmptyContexts (getGADTConType con) + , fixity + ] + + fieldPart = case con of + ConDeclGADT{con_g_args = con_args'} -> case con_args' of + -- GADT record declarations + RecConGADT _ _ -> [ doConstrArgsWithDocs [] ] + -- GADT prefix data constructors + PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] + _ -> [] + + ConDeclH98{con_args = con_args'} -> case con_args' of + -- H98 record declarations + RecCon (L _ fields) -> [ doRecordFields fields ] + -- H98 prefix data constructors + PrefixCon _ args | hasArgDocs -> [ doConstrArgsWithDocs args ] + -- H98 infix data constructor + InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] + _ -> [] + + doRecordFields fields = subFields pkg qual + (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) + + doConstrArgsWithDocs args = subFields pkg qual $ case con of + ConDeclH98{} -> + [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) + | (i, arg) <- zip [0..] (map hsScaledThing args) + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + ppSubSigLike unicode qual (unLoc (getGADTConType con)) + argDocs subdocs (dcolon unicode) HideEmptyContexts + + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = lookup aConName subdocs >>= + combineDocumentation . fst + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification + -> Html +ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt + where + ppForall + | null tvs || not forall_ = noHtml + | otherwise = ppForAllPart unicode qual (HsForAllInvis noExtField tvs) + + ppCtxt + | null ctxt = noHtml + | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts + <+> darrow unicode +++ toHtml " " + + +-- | Pretty-print a record field +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification + -> ConDeclField DocNameI -> SubDecl +ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = + ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) + | L _ name <- names + , let field = (unLoc . foLabel) name + ]) + <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts ltype + , mbDoc + , [] + ) + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + -- Where there is more than one name, they all have the same documentation + mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst + + +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html +ppShortField summary unicode qual (ConDeclField _ names ltype _) + = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names)) + <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype + + +-- | Pretty print an expanded pattern (for bundled patterns) +ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification + -> [LocatedN DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> SubDecl +ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = + ( decl + , combineDocumentation doc + , fieldPart + ) + where + hasArgDocs = not $ Map.null argDocs + fixity = ppFixities fixities qual + ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppPatSigType unicode qual typ + , fixity + ] + + fieldPart + | not hasArgDocs = [] + | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ) + argDocs [] (dcolon unicode) + emptyCtxt) ] + + emptyCtxt = patSigContext typ + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html +ppDataHeader summary (DataDecl { tcdDataDefn = + HsDataDefn { dd_cons = cons + , dd_ctxt = ctxt + , dd_kindSig = ks } + , tcdLName = L _ name + , tcdTyVars = tvs }) + unicode qual + = -- newtype or data + (case cons of + { NewTypeCon _ -> keyword "newtype" + ; DataTypeCons False _ -> keyword "data" + ; DataTypeCons True _ -> keyword "type" <+> keyword "data" + }) + <+> + -- context + ppLContext ctxt unicode qual HideEmptyContexts <+> + -- T a b c ..., or a :+: b + ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs) + <+> case ks of + Nothing -> mempty + Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x + +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Types and contexts +-------------------------------------------------------------------------------- + + +ppBang :: HsSrcBang -> Html +ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!" +ppBang (HsSrcBang _ _ SrcLazy) = toHtml "~" +ppBang _ = noHtml + + +tupleParens :: HsTupleSort -> [Html] -> Html +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +sumParens :: [Html] -> Html +sumParens = ubxSumList + +-------------------------------------------------------------------------------- +-- * Rendering of HsType +-------------------------------------------------------------------------------- + +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html +ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) +ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) +ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) + +ppLSigType :: Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html +ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y) + +ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html +ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts + +ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html +ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts + +ppSigType :: Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html +ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts + +ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html +ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty +ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode qual emptyCtxts ki +ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" + +class RenderableBndrFlag flag where + ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html + +instance RenderableBndrFlag () where + ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) = + ppDocName qual Raw False name + ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + +instance RenderableBndrFlag Specificity where + ppHsTyVarBndr _ qual (UserTyVar _ SpecifiedSpec (L _ name)) = + ppDocName qual Raw False name + ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) = + braces $ ppDocName qual Raw False name + ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = + parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = + braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+> + ppLKind unicode qual kind) + +ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html +ppLKind unicode qual y = ppKind unicode qual (unLoc y) + +ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html +ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts + +patSigContext :: LHsSigType DocNameI -> HideEmptyContexts +patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts + where + typ = sig_body (unLoc sig_typ) + + hasNonEmptyContext t = + case unLoc t of + HsForAllTy _ _ s -> hasNonEmptyContext s + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ _ _ s -> hasNonEmptyContext s + _ -> False + isFirstContextEmpty t = + case unLoc t of + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ _ s -> isFirstContextEmpty s + _ -> False + + +-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in +-- the right 'HideEmptyContext' value) +ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ + +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag + => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html +ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of + HsOuterImplicit{} -> noHtml + HsOuterExplicit{hso_bndrs = bndrs} -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot + +ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html +ppForAllPart unicode qual tele = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ + spaceHtml +++ arrow unicode + HsForAllInvis { hsf_invis_bndrs = bndrs } -> + hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot + +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts + = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts + +ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) + + +ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts + +ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts + = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts + +-- UnicodeSyntax alternatives +ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ + | getOccString (getName name) == "(->)" = toHtml "(→)" + +ppr_mono_ty (HsBangTy _ b ty) u q _ = + ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _ + | isPromoted prom = promoQuote (ppDocName q Prefix True name) + | otherwise = ppDocName q Prefix True name +ppr_mono_ty (HsStarTy _ isUni) u _ _ = + toHtml (if u || isUni then "★" else "*") +ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e = + hsep [ ppr_mono_lty ty1 u q HideEmptyContexts + , arr <+> ppr_mono_lty ty2 u q e + ] + where arr = case mult of + HsLinearArrow _ -> lollipop u + HsUnrestrictedArrow _ -> arrow u + HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u + +ppr_mono_ty (HsTupleTy _ con tys) u q _ = + tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty (HsSumTy _ tys) u q _ = + sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty (HsKindSig _ ty kind) u q e = + ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind +ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = + ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts +ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v +ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" + -- Can now legally occur in ConDeclGADT, the output here is to provide a + -- placeholder in the signature, which is followed by the field + -- declarations. +ppr_mono_ty (XHsType {}) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _ + = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts + , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ] + +ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ + = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts + , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts] + +ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _ + = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts + where + ppr_op_prom + | isPromoted prom + = promoQuote ppr_op + | otherwise + = ppr_op + ppr_op = ppLDocName qual Infix op + +ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts + = parens (ppr_mono_lty ty unicode qual emptyCtxts) +-- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) + +ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts + = ppr_mono_lty ty unicode qual emptyCtxts + +ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' +ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n + +ppr_tylit :: HsTyLit DocNameI -> Html +ppr_tylit (HsNumTy _ n) = toHtml (show n) +ppr_tylit (HsStrTy _ s) = toHtml (show s) +ppr_tylit (HsCharTy _ c) = toHtml (show c) diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,7 +19,8 @@ docElement, docSection, docSection_, ) where -import Data.List +import Data.List (intersperse) +import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types @@ -30,8 +31,8 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC -import Name +import GHC hiding (anchor) +import GHC.Types.Name parHtmlMarkup :: Qualification -> Bool @@ -43,36 +44,38 @@ markupAppend = (+++), markupIdentifier = thecode . ppId insertAnchors, markupIdentifierUnchecked = thecode . ppUncheckedLink qual, - markupModule = \m -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style - -- foo\#bar anchors - mdl' = case reverse mdl of - '\\':_ -> init mdl - _ -> mdl - in ppModuleRef (mkModuleName mdl') ref, + markupModule = \(ModLink m lbl) -> + let (mdl,ref) = break (=='#') m + -- Accommodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef lbl (mkModuleName mdl') ref, markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupBold = strong, markupMonospaced = thecode, markupUnorderedList = unordList, - markupOrderedList = ordList, + markupOrderedList = makeOrdList, markupDefList = defList, markupCodeBlock = pre, markupHyperlink = \(Hyperlink url mLabel) -> if insertAnchors then anchor ! [href url] - << fromMaybe url mLabel - else toHtml $ fromMaybe url mLabel, + << fromMaybe (toHtml url) mLabel + else fromMaybe (toHtml url) mLabel, markupAName = \aname -> if insertAnchors then namedAnchor aname << "" else noHtml, markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), - markupMathInline = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"), - markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), + markupMathInline = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)"), + markupMathDisplay = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, - markupHeader = \(Header l t) -> makeHeader l t + markupHeader = \(Header l t) -> makeHeader l t, + markupTable = \(Table h r) -> makeTable h r } where makeHeader :: Int -> Html -> Html @@ -84,7 +87,23 @@ makeHeader 6 mkup = h6 mkup makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + makeTable :: [TableRow Html] -> [TableRow Html] -> Html + makeTable hs bs = table (concatHtml (hs' ++ bs')) + where + hs' | null hs = [] + | otherwise = [thead (concatHtml (map (makeTableRow th) hs))] + bs' = [tbody (concatHtml (map (makeTableRow td) bs))] + + makeTableRow :: (Html -> Html) -> TableRow Html -> Html + makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs)) + + makeTableCell :: (Html -> Html) -> TableCell Html -> Html + makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j') + where + i' = if i == 1 then [] else [ colspan i ] + j' = if j == 1 then [] else [ rowspan j ] + examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] exampleToHtml (Example expression result) = htmlExample @@ -93,9 +112,12 @@ htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + makeOrdList :: HTML a => [(Int, a)] -> Html + makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items + -- | We use this intermediate type to transform the input 'Doc' tree -- in an arbitrary way before rendering, such as grouping some --- elements. This is effectivelly a hack to prevent the 'Doc' type +-- elements. This is effectively a hack to prevent the 'Doc' type -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id = @@ -153,20 +175,20 @@ -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html -hackMarkup fmt' h' = +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html +hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' - in html +++ renderMeta fmt' (metaConcat ms) + in html +++ renderMeta fmt' currPkg (metaConcat ms) where - hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta]) hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - expanded = False - col' = collapseControl id_ expanded "caption" - instTable = (thediv ! collapseSection id_ expanded [] <<) + col' = collapseControl id_ "subheading" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" + instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl @@ -175,46 +197,51 @@ (y, m') = hackMarkup' fmt d' in (markupAppend fmt x y, m ++ m') -renderMeta :: DocMarkup id Html -> Meta -> Html -renderMeta fmt (Meta { _version = Just x }) = +renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html +renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) = markupParagraph fmt . markupEmphasis fmt . toHtml $ - "Since: " ++ formatVersion x + "Since: " ++ formatPkgMaybe pkg ++ formatVersion x where formatVersion v = concat . intersperse "." $ map show v -renderMeta _ _ = noHtml + formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-" + formatPkgMaybe _ = "" +renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. -markupHacked :: DocMarkup id Html +markupHacked :: DocMarkup (Wrap id) Html + -> Maybe Package -- this package -> Maybe String -> MDoc id -> Html -markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten +markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten -- If the doc is a single paragraph, don't surround it with

    (this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See - -- comments on 'toHack' for details. +docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See + -- comments on 'toHack' for details. + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docToHtml n qual = markupHacked fmt n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) +docToHtml n pkg qual = markupHacked fmt pkg n . cleanup + where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. -docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' +docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) +docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) -origDocToHtml :: Qualification -> MDoc Name -> Html -origDocToHtml qual = markupHacked fmt Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) +origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html +origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) -rdrDocToHtml :: Qualification -> MDoc RdrName -> Html -rdrDocToHtml qual = markupHacked fmt Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) +rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html +rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -225,14 +252,17 @@ docSection :: Maybe Name -- ^ Name of the thing this doc is for + -> Maybe Package -- ^ Current package -> Qualification -> Documentation DocName -> Html -docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation +docSection n pkg qual = + maybe noHtml (docSection_ n pkg qual) . combineDocumentation -docSection_ :: Maybe Name -- ^ Name of the thing this doc is for +docSection_ :: Maybe Name -- ^ Name of the thing this doc is for + -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html -docSection_ n qual = - (docElement thediv <<) . docToHtml (getOccString <$> n) qual +docSection_ n pkg qual = + (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual cleanup :: MDoc a -> MDoc a @@ -247,8 +277,8 @@ unParagraph (DocParagraph d) = d unParagraph doc = doc - fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, - markupOrderedList = DocOrderedList . map unParagraph + markupOrderedList = DocOrderedList . map (\(index, a) -> (index, unParagraph a)) } diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -15,7 +15,7 @@ divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList, + divIndex, divAlphabet, divPackageList, divModuleList, divContentsList, sectionName, nonEmptySectionName, @@ -29,28 +29,30 @@ subArguments, subAssociatedTypes, subConstructors, + subPatterns, subEquations, subFields, subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, title, quote ) +import Data.Maybe (fromMaybe) -import FastString ( unpackFS ) -import GHC -import Name (nameOccName) +import GHC.Data.FastString ( unpackFS ) +import GHC hiding (anchor) +import GHC.Types.Name (nameOccName) -------------------------------------------------------------------------------- -- * Sections of the document @@ -73,13 +75,13 @@ -- If it would have otherwise been empty, then give it the class ".empty". nonEmptySectionName :: Html -> Html nonEmptySectionName c - | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml - | otherwise = paragraph ! [theclass "caption"] $ c + | isNoHtml c = thespan ! [theclass "caption empty"] $ spaceHtml + | otherwise = thespan ! [theclass "caption"] $ c divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface, - divIndex, divAlphabet, divModuleList + divIndex, divAlphabet, divPackageList, divModuleList, divContentsList :: Html -> Html divPackageHeader = sectionDiv "package-header" @@ -87,12 +89,14 @@ divModuleHeader = sectionDiv "module-header" divFooter = sectionDiv "footer" divTableOfContents = sectionDiv "table-of-contents" +divContentsList = sectionDiv "contents-list" divDescription = sectionDiv "description" divSynopsis = sectionDiv "synopsis" divInterface = sectionDiv "interface" divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" divModuleList = sectionDiv "module-list" +divPackageList = sectionDiv "module-list" -------------------------------------------------------------------------------- @@ -127,89 +131,96 @@ subCaption = paragraph ! [theclass "caption"] << captionName -subDlist :: Qualification -> [SubDecl] -> Maybe Html -subDlist _ [] = Nothing -subDlist qual decls = Just $ ulist << map subEntry decls +subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html +subDlist _ _ [] = Nothing +subDlist pkg qual decls = Just $ ulist << map subEntry decls where subEntry (decl, mdoc, subs) = li << (define ! [theclass "src"] << decl +++ - docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs)) + docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs)) -subTable :: Qualification -> [SubDecl] -> Maybe Html -subTable _ [] = Nothing -subTable qual decls = Just $ table << aboves (concatMap subRow decls) +subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html +subTable _ _ [] = Nothing +subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) where subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <-> - docElement td << fmap (docToHtml Nothing qual) mdoc) + docElement td << fmap (docToHtml Nothing pkg qual) mdoc) : map (cell . (td <<)) subs -- | Sub table with source information (optional). -subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html -subTableSrc _ _ _ [] = Nothing -subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) +subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool + -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html +subTableSrc _ _ _ _ [] = Nothing +subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) where - subRow ((decl, mdoc, subs),L loc dn) = + subRow ((decl, mdoc, subs), mdl, L loc dn) = (td ! [theclass "src clearfix"] << (thespan ! [theclass "inst-left"] << decl) - <+> linkHtml loc dn + <+> linkHtml loc mdl dn <-> - docElement td << fmap (docToHtml Nothing qual) mdoc + docElement td << fmap (docToHtml Nothing pkg qual) mdoc ) : map (cell . (td <<)) subs - linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn - linkHtml _ _ = noHtml + linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html + linkHtml loc@(RealSrcSpan _ _) mdl dn = links lnks loc splice mdl dn + linkHtml _ _ _ = noHtml + subBlock :: [Html] -> Maybe Html subBlock [] = Nothing subBlock hs = Just $ toHtml hs -subArguments :: Qualification -> [SubDecl] -> Html -subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual +subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html +subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock -subConstructors :: Qualification -> [SubDecl] -> Html -subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual +subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html +subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual -subFields :: Qualification -> [SubDecl] -> Html -subFields qual = divSubDecls "fields" "Fields" . subDlist qual +subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html +subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual +subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html +subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual -subEquations :: Qualification -> [SubDecl] -> Html -subEquations qual = divSubDecls "equations" "Equations" . subTable qual +subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html +subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual --- | Generate sub table for instance declarations, with source -subInstances :: Qualification + +-- | Generate collapsible sub table for instance declarations, with source +subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool - -> [(SubDecl,Located DocName)] -> Html -subInstances qual nm lnks splice = maybe noHtml wrap . instTable + -> [(SubDecl, Maybe Module, Located DocName)] -> Html +subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where - wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) + instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] - subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + hdr = h4 ! collapseControl id_ "instances" << "Instances" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instances details" id_ = makeAnchorId $ "i:" ++ nm -subOrphanInstances :: Qualification +subOrphanInstances :: Maybe Package -> Qualification -> LinksInfo -> Bool - -> [(SubDecl,Located DocName)] -> Html -subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable + -> [(SubDecl, Maybe Module, Located DocName)] -> Html +subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice - id_ = makeAnchorId $ "orphans" + instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice + id_ = makeAnchorId "orphans" subInstHead :: String -- ^ Instance unique id (for anchor generation) @@ -218,26 +229,30 @@ subInstHead iid hdr = expander noHtml <+> hdr where - expander = thespan ! collapseControl (instAnchorId iid) False "instance" + expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails :: String -- ^ Instance unique id (for anchor generation) -> [Html] -- ^ Associated type contents -> [Html] -- ^ Method contents (pretty-printed signatures) + -> Html -- ^ Source module -> Html -subInstDetails iid ats mets = - subInstSection iid << (subAssociatedTypes ats <+> subMethods mets) +subInstDetails iid ats mets mdl = + subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) subFamInstDetails :: String -- ^ Instance unique id (for anchor generation) -> Html -- ^ Type or data family instance + -> Html -- ^ Source module TODO: use this -> Html -subFamInstDetails iid fi = - subInstSection iid << thediv ! [theclass "src"] << fi +subFamInstDetails iid fi mdl = + subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) subInstSection :: String -- ^ Instance unique id (for anchor generation) -> Html -> Html -subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details" +subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) + where + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details" instAnchorId :: String -> String instAnchorId iid = makeAnchorId $ "i:" ++ iid @@ -246,6 +261,9 @@ subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock + subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem @@ -259,13 +277,13 @@ -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html topDeclElem lnks loc splice names html = - declElem << (html <+> (links lnks loc splice $ head names)) + declElem << (html <+> (links lnks loc splice Nothing $ head names)) -- FIXME: is it ok to simply take the first name? -- | Adds a source and wiki link at the right hand side of the box. -- Name must be documented, otherwise we wouldn't get here. -links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html -links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) = +links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html +links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) = srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#") where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -289,12 +307,13 @@ -- For source links, we want to point to the original module, -- because only that will have the source. - -- TODO: do something about type instances. They will point to - -- the module defining the type family, which is wrong. - origMod = nameModule n - origPkg = moduleUnitId origMod + -- + -- 'mdl'' is a way of "overriding" the module. Without it, instances + -- will point to the module defining the class/family, which is wrong. + origMod = fromMaybe (nameModule n) mdl' + origPkg = moduleUnit origMod fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) + RealSrcSpan l _ -> unpackFS (srcSpanFile l) UnhelpfulSpan _ -> error "links: UnhelpfulSpan" -links _ _ _ _ = noHtml +links _ _ _ _ _ = noHtml diff --git a/src/Haddock/Backends/Xhtml/Meta.hs b/src/Haddock/Backends/Xhtml/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Meta.hs @@ -0,0 +1,28 @@ +module Haddock.Backends.Xhtml.Meta where + +import Haddock.Utils.Json +import Haddock.Version + +import Data.ByteString.Builder (hPutBuilder) +import System.FilePath (()) +import System.IO (withFile, IOMode (WriteMode)) + +-- | Everytime breaking changes to the Quckjump api +-- happen this needs to be modified. +quickjumpVersion :: Int +quickjumpVersion = 1 + +-- | Writes a json encoded file containing additional +-- information about the generated documentation. This +-- is useful for external tools (e.g., Hackage). +writeHaddockMeta :: FilePath -> Bool -> IO () +writeHaddockMeta odir withQuickjump = do + let + meta_json :: Value + meta_json = object (concat [ + [ "haddock_version" .= String projectVersion ] + , [ "quickjump_version" .= quickjumpVersion | withQuickjump ] + ]) + + withFile (odir "meta.json") WriteMode $ \h -> + hPutBuilder h (encodeToBuilder meta_json) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) + ppModule, ppModuleRef, ppIPName, linkId, Notation(..), + ppWrappedDocName, ppWrappedName, ) where @@ -22,14 +23,14 @@ import Haddock.Types import Haddock.Utils -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M -import qualified Data.List as List +import Data.List ( stripPrefix ) -import GHC -import Name -import RdrName -import FastString (unpackFS) +import GHC hiding (LexicalFixity(..), anchor) +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Data.FastString (unpackFS) -- | Indicator of how to render a 'DocName' into 'Html' @@ -49,14 +50,17 @@ ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - +ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html +ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml + where + (mdl, occ) = unwrap x + occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation -ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d + ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName = case docName of @@ -68,6 +72,19 @@ ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name + +ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html +ppWrappedDocName qual notation insertAnchors docName = case docName of + Unadorned n -> ppDocName qual notation insertAnchors n + Parenthesized n -> ppDocName qual Prefix insertAnchors n + Backticked n -> ppDocName qual Infix insertAnchors n + +ppWrappedName :: Notation -> Wrap Name -> Html +ppWrappedName notation docName = case docName of + Unadorned n -> ppName notation n + Parenthesized n -> ppName Prefix n + Backticked n -> ppName Infix n + -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -79,7 +96,7 @@ then ppName notation name else ppFullQualName notation mdl name RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + case stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppName notation name -- sub-module, A.B.x -> B.x @@ -147,17 +164,19 @@ linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html linkIdOcc mdl mbName insertAnchors = if insertAnchors - then anchor ! [href url] + then anchor ! [href url, title ttl] else id where + ttl = moduleNameString (moduleName mdl) url = case mbName of Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html -linkIdOcc' mdl mbName = anchor ! [href url] +linkIdOcc' mdl mbName = anchor ! [href url, title ttl] where + ttl = moduleNameString mdl url = case mbName of Nothing -> moduleHtmlFile' mdl Just name -> moduleNameUrl' mdl name @@ -168,9 +187,12 @@ << toHtml (moduleString mdl) -ppModuleRef :: ModuleName -> String -> Html -ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] - << toHtml (moduleNameString mdl) +ppModuleRef :: Maybe Html -> ModuleName -> String -> Html +ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) +ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << lbl + -- NB: The ref parameter already includes the '#'. -- This function is only called from markupModule expanding a -- DocModule, which doesn't seem to be ever be used. diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ b/src/Haddock/Backends/Xhtml/Themes.hs @@ -17,6 +17,7 @@ where import Haddock.Options +import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower) @@ -58,7 +59,7 @@ standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) --- | Default themes that are part of Haddock; added with --default-themes +-- | Default themes that are part of Haddock; added with @--built-in-themes@ -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme. @@ -176,13 +177,13 @@ cssFiles ts = nub $ concatMap themeFiles ts -styleSheet :: Themes -> Html -styleSheet ts = toHtml $ zipWith mkLink rels ts +styleSheet :: BaseURL -> Themes -> Html +styleSheet base_url ts = toHtml $ zipWith mkLink rels ts where rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink - ! [ href (themeHref t), rel aRel, thetype "text/css", + ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs --- a/src/Haddock/Backends/Xhtml/Types.hs +++ b/src/Haddock/Backends/Xhtml/Types.hs @@ -12,6 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types ( SourceURLs, WikiURLs, + BaseURL, + withBaseURL, LinksInfo, Splice, Unicode, @@ -20,12 +22,21 @@ import Data.Map import GHC +import qualified System.FilePath as FilePath -- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath) +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) +-- | base url for loading js, json, css resources. The default is "." +-- +type BaseURL = Maybe String + +-- TODO: we shouldn't use 'FilePath.' +withBaseURL :: BaseURL -> String -> String +withBaseURL Nothing uri = uri +withBaseURL (Just baseUrl) uri = baseUrl FilePath. uri -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs) diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -20,12 +20,15 @@ (<+>), (<=>), char, keyword, punctuate, - braces, brackets, pabrackets, parens, parenList, ubxParenList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, + arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + multAnnotation, + atSign, hsep, vcat, - collapseSection, collapseToggle, collapseControl, + DetailsState(..), collapseDetails, thesummary, + collapseToggle, collapseControl, ) where @@ -36,9 +39,9 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module, ModuleName, moduleName, moduleNameString ) -import Name ( getOccString, nameOccName, isValOcc ) +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) +import GHC.Unit.Module ( Module, ModuleName, moduleName, moduleNameString ) +import GHC.Types.Name ( getOccString, nameOccName, isValOcc ) -- | Replace placeholder string elements with provided values. @@ -73,7 +76,7 @@ Nothing -> "" Just span_ -> case span_ of - RealSrcSpan span__ -> + RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" @@ -109,7 +112,7 @@ hsep :: [Html] -> Html hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls +hsep htmls = foldr1 (<+>) htmls -- | Concatenate a series of 'Html' values vertically, with linebreaks in between. vcat :: [Html] -> Html @@ -177,16 +180,24 @@ ubxParenList = ubxparens . hsep . punctuate comma +ubxSumList :: [Html] -> Html +ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") + + ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->") +lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" +atSign unicode = toHtml (if unicode then "@" else "@") +multAnnotation :: Html +multAnnotation = toHtml "%" dot :: Html dot = toHtml "." @@ -209,26 +220,22 @@ -- A section of HTML which is collapsible. -- --- | Attributes for an area that can be collapsed -collapseSection :: String -> Bool -> String -> [HtmlAttr] -collapseSection id_ state classes = [ identifier sid, theclass cs ] - where cs = unwords (words classes ++ [pick state "show" "hide"]) - sid = "section." ++ id_ +data DetailsState = DetailsOpen | DetailsClosed +collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) + where openAttrs = case state of { DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] } + +thesummary :: Html -> Html +thesummary = tag "summary" + -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> [HtmlAttr] -collapseToggle id_ = [ strAttr "onclick" js ] - where js = "toggleSection('" ++ id_ ++ "')"; +collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] + where cs = unwords (words classes ++ ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> Bool -> String -> [HtmlAttr] -collapseControl id_ state classes = - [ identifier cid, theclass cs ] ++ collapseToggle id_ - where cs = unwords (words classes ++ [pick state "collapser" "expander"]) - cid = "control." ++ id_ - - -pick :: Bool -> a -> a -> a -pick True t _ = t -pick False _ f = f +collapseControl :: String -> String -> [HtmlAttr] +collapseControl id_ classes = collapseToggle id_ cs + where cs = unwords (words classes ++ ["details-toggle-control"]) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -1,488 +1,986 @@ - -{-# LANGUAGE CPP, PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Convert --- Copyright : (c) Isaac Dupree 2009, --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Conversion between TyThing and HsDecl. This functionality may be moved into --- GHC at some point. ------------------------------------------------------------------------------ -module Haddock.Convert where --- Some other functions turned out to be useful for converting --- instance heads, which aren't TyThings, so just export everything. - -import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..) ) -import Class -import CoAxiom -import ConLike -import Data.Either (lefts, rights) -import DataCon -import FamInstEnv -import HsSyn -import Name -import NameSet ( emptyNameSet ) -import RdrName ( mkVarUnqual ) -import PatSyn -import SrcLoc ( Located, noLoc, unLoc ) -import TcType ( tcSplitSigmaTy ) -import TyCon -import Type -import TyCoRep -import TysPrim ( alphaTyVars, unliftedTypeKindTyConName ) -import TysWiredIn ( listTyConName, starKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, ipClassKey - , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey ) -import Unique ( getUnique ) -import Util ( filterByList, filterOut ) -import Var - -import Haddock.Types -import Haddock.Interface.Specialize - - - --- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) -tyThingToLHsDecl t = case t of - -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. - -- Including built-in functions like seq. - -- foreign-imported functions could be represented with ForD - -- instead of SigD if we wanted... - -- - -- in a future code version we could turn idVarDetails = foreign-call - -- into a ForD instead of a SigD if we wanted. Haddock doesn't - -- need to care. - AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) - - -- type-constructors (e.g. Maybe) are complicated, put the definition - -- later in the file (also it's used for class associated-types too.) - ATyCon tc - | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl d) = return $ noLoc d - extractFamilyDecl _ = - Left "tyThingToLHsDecl: impossible associated tycon" - - atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] - atFamDecls = map extractFamilyDecl (rights atTyClDecls) - tyClErrors = lefts atTyClDecls - famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl - { tcdCtxt = synifyCtx (classSCTheta cl) - , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (classTyVars cl) - , tcdFDs = map (\ (l,r) -> noLoc - (map (noLoc . getName) l, map (noLoc . getName) r) ) $ - snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) : - map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) - (classMethods cl) - , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature - -- class associated-types are a subset of TyCon: - , tcdATs = rights atFamDecls - , tcdATDefs = [] --ignore associated type defaults - , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNamesTc } - | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD - - -- type-constructors (e.g. Maybe) are complicated, put the definition - -- later in the file (also it's used for class associated-types too.) - ACoAxiom ax -> synifyAxiom ax >>= allOK - - -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] - (synifySigWcType ImplicitizeForAll (dataConUserType dc))) - - AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps) - where - withErrs e x = return (e, x) - allOK x = return (mempty, x) - -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name -synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) - = let name = synifyName tc - typats = map (synifyType WithinType) args - hs_rhs = synifyType WithinType rhs - in TyFamEqn { tfe_tycon = name - , tfe_pats = HsIB { hsib_body = typats - , hsib_vars = map tyVarName tkvs } - , tfe_rhs = hs_rhs } - -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) -synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) - | isOpenTypeFamilyTyCon tc - , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD (TyFamInstD - (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNamesTc })) - - | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc - , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD - - | otherwise - = Left "synifyAxiom: closed/open family confusion" - --- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) -synifyTyCon _coax tc - | isFunTyCon tc || isPrimTyCon tc - = return $ - DataDecl { tcdLName = synifyName tc - , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: - let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) - (synifyKindSig realKind) - in HsQTvs { hsq_implicit = [] -- No kind polymorphism - , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) - alphaTyVars --a, b, c... which are unfortunately all kind * - , hsq_dependent = emptyNameSet } - - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither - -- algebraic data nor newtype: - , dd_ctxt = noLoc [] - , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) - -- we have their kind accurately: - , dd_cons = [] -- No constructors - , dd_derivs = Nothing } - , tcdDataCusk = False - , tcdFVs = placeHolderNamesTc } - -synifyTyCon _coax tc - | Just flav <- famTyConFlav_maybe tc - = case flav of - -- Type families - OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily - ClosedSynFamilyTyCon mb - | Just (CoAxiom { co_ax_branches = branches }) <- mb - -> mkFamDecl $ ClosedTypeFamily $ Just - $ map (noLoc . synifyAxBranch tc) (fromBranches branches) - | otherwise - -> mkFamDecl $ ClosedTypeFamily $ Just [] - BuiltInSynFamTyCon {} - -> mkFamDecl $ ClosedTypeFamily $ Just [] - AbstractClosedSynFamilyTyCon {} - -> mkFamDecl $ ClosedTypeFamily Nothing - DataFamilyTyCon {} - -> mkFamDecl DataFamily - where - resultVar = famTcResVar tc - mkFamDecl i = return $ FamDecl $ - FamilyDecl { fdInfo = i - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdResultSig = - synifyFamilyResultSig resultVar (tyConResKind tc) - , fdInjectivityAnn = - synifyInjectivityAnn resultVar (tyConTyVars tc) - (familyTyConInjectivityInfo tc) - } - -synifyTyCon coax tc - | Just ty <- synTyConRhs_maybe tc - = return $ SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNamesTc } - | otherwise = - -- (closed) newtype and data - let - alg_nd = if isNewTyCon tc then NewType else DataType - alg_ctx = synifyCtx (tyConStupidTheta tc) - name = case coax of - Just a -> synifyName a -- Data families are named according to their - -- CoAxioms, not their TyCons - _ -> synifyName tc - tyvars = synifyTyVars (tyConTyVars tc) - kindSig = Just (tyConKind tc) - -- The data constructors. - -- - -- Any data-constructors not exported from the module that *defines* the - -- type will not (cannot) be included. - -- - -- Very simple constructors, Haskell98 with no existentials or anything, - -- probably look nicer in non-GADT syntax. In source code, all constructors - -- must be declared with the same (GADT vs. not) syntax, and it probably - -- is less confusing to follow that principle for the documentation as well. - -- - -- There is no sensible infix-representation for GADT-syntax constructor - -- declarations. They cannot be made in source code, but we could end up - -- with some here in the case where some constructors use existentials. - -- That seems like an acceptable compromise (they'll just be documented - -- in prefix position), since, otherwise, the logic (at best) gets much more - -- complicated. (would use dataConIsInfix.) - use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) - consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) - cons = rights consRaw - -- "deriving" doesn't affect the signature, no need to specify any. - alg_deriv = Nothing - defn = HsDataDefn { dd_ND = alg_nd - , dd_ctxt = alg_ctx - , dd_cType = Nothing - , dd_kindSig = fmap synifyKindSig kindSig - , dd_cons = cons - , dd_derivs = alg_deriv } - in case lefts consRaw of - [] -> return $ - DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn - , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } - dataConErrs -> Left $ unlines dataConErrs - -synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity - -> Maybe (LInjectivityAnn Name) -synifyInjectivityAnn Nothing _ _ = Nothing -synifyInjectivityAnn _ _ NotInjective = Nothing -synifyInjectivityAnn (Just lhs) tvs (Injective inj) = - let rhs = map (noLoc . tyVarName) (filterByList inj tvs) - in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs - -synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name -synifyFamilyResultSig Nothing kind = - noLoc $ KindSig (synifyKindSig kind) -synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) - --- User beware: it is your responsibility to pass True (use_gadt_syntax) --- for any constructor that would be misrepresented by omitting its --- result-type. --- But you might want pass False in simple enough cases, --- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name) -synifyDataCon use_gadt_syntax dc = - let - -- dataConIsInfix allegedly tells us whether it was declared with - -- infix *syntax*. - use_infix_syntax = dataConIsInfix dc - use_named_field_syntax = not (null field_tys) - name = synifyName dc - -- con_qvars means a different thing depending on gadt-syntax - (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc - - qvars = if use_gadt_syntax - then synifyTyVars (univ_tvs ++ ex_tvs) - else synifyTyVars ex_tvs - - -- skip any EqTheta, use 'orig'inal syntax - ctx = synifyCtx theta - - linear_tys = - zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - in case bang of - (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy bang' tySyn) - arg_tys (dataConSrcBangs dc) - - field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys - con_decl_field fl synTy = noLoc $ - ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy - Nothing - hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of - (True,True) -> Left "synifyDataCon: contradiction!" - (True,False) -> return $ RecCon (noLoc field_tys) - (False,False) -> return $ PrefixCon linear_tys - (False,True) -> case linear_tys of - [a,b] -> return $ InfixCon a b - _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] (synifyType WithinType res_ty) - -- finally we get synifyDataCon's result! - in hs_arg_tys >>= - \hat -> - if use_gadt_syntax - then return $ noLoc $ - ConDeclGADT { con_names = [name] - , con_type = gadt_ty - , con_doc = Nothing } - else return $ noLoc $ - ConDeclH98 { con_name = name - , con_qvars = Just qvars - , con_cxt = Just ctx - , con_details = hat - , con_doc = Nothing } - -synifyName :: NamedThing n => n -> Located Name -synifyName = noLoc . getName - - -synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) - -synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name -synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) - -synifyCtx :: [PredType] -> LHsContext Name -synifyCtx = noLoc . map (synifyType WithinType) - - -synifyTyVars :: [TyVar] -> LHsQTyVars Name -synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs - , hsq_dependent = emptyNameSet } - -synifyTyVar :: TyVar -> LHsTyVarBndr Name -synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv - ---states of what to do with foralls: -data SynifyTypeState - = WithinType - -- ^ normal situation. This is the safe one to use if you don't - -- quite understand what's going on. - | ImplicitizeForAll - -- ^ beginning of a function definition, in which, to make it look - -- less ugly, those rank-1 foralls are made implicit. - | DeleteTopLevelQuantification - -- ^ because in class methods the context is added to the type - -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) - -- which is rather sensible, - -- but we want to restore things to the source-syntax situation where - -- the defining class gets to quantify all its functions for free! - - -synifySigType :: SynifyTypeState -> Type -> LHsSigType Name --- The empty binders is a bit suspicious; --- what if the type has free variables? -synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) - -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name --- Ditto (see synifySigType) -synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty)) - -synifyPatSynSigType :: PatSyn -> LHsSigType Name --- Ditto (see synifySigType) -synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) - -synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) -synifyType _ (TyConApp tc tys) - -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) - | tc `hasKey` tYPETyConKey - , [TyConApp lev []] <- tys - , lev `hasKey` ptrRepLiftedDataConKey - = noLoc (HsTyVar (noLoc starKindTyConName)) - | tc `hasKey` tYPETyConKey - , [TyConApp lev []] <- tys - , lev `hasKey` ptrRepUnliftedDataConKey - = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName)) - -- Use non-prefix tuple syntax where possible, because it looks nicer. - | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = noLoc $ HsTupleTy (case sort of - BoxedTuple -> HsBoxedTuple - ConstraintTuple -> HsConstraintTuple - UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) tys) - -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy (synifyType WithinType ty) - -- ditto for implicit parameter tycons - | tc `hasKey` ipClassKey - , [name, ty] <- tys - , Just x <- isStrLitTy name - = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) - -- and equalities - | tc `hasKey` eqTyConKey - , [ty1, ty2] <- tys - = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) - -- Most TyCons: - | otherwise = - foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar $ noLoc (getName tc)) - (map (synifyType WithinType) $ - filterOut isCoercionTy tys) -synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 -synifyType _ (AppTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsAppTy s1 s2 -synifyType _ (ForAllTy (Anon t1) t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsFunTy s1 s2 -synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTy forallty - sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_body = synifyType WithinType tau } - in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_body = noLoc sPhi } - ImplicitizeForAll -> noLoc sPhi - -synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t -synifyType s (CastTy t _) = synifyType s t -synifyType _ (CoercionTy {}) = error "synifyType:Coercion" - -synifyPatSynType :: PatSyn -> LHsType Name -synifyPatSynType ps = let - (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps - req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] - -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", - -- i.e., an explicit empty context, which is what we need. This is not - -- possible by taking theta = [], as that will print no context at all - | otherwise = req_theta - sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_body = noLoc s } - sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty - in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau - -synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy mempty n -synifyTyLit (StrTyLit s) = HsStrTy mempty s - -synifyKindSig :: Kind -> LHsKind Name -synifyKindSig k = synifyType WithinType k - -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead - { ihdClsName = getName cls - , ihdKinds = map (unLoc . synifyType WithinType) ks - , ihdTypes = map (unLoc . synifyType WithinType) ts - , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType) preds - , clsiTyVars = synifyTyVars $ classTyVars cls - , clsiSigs = map synifyClsIdSig $ classMethods cls - , clsiAssocTys = do - (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls - pure $ mkPseudoFamilyDecl fam - } - } - where - (ks,ts) = partitionInvisibles (classTyCon cls) id types - synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification - --- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) -synifyFamInst fi opaque = do - ityp' <- ityp $ fi_flavor fi - return InstHead - { ihdClsName = fi_fam fi - , ihdKinds = synifyTypes ks - , ihdTypes = synifyTypes ts - , ihdInstType = ityp' - } - where - ityp SynFamilyInst | opaque = return $ TypeInst Nothing - ityp SynFamilyInst = - return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi - ityp (DataFamilyInst c) = - DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi - synifyTypes = map (unLoc. synifyType WithinType) +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Convert +-- Copyright : (c) Isaac Dupree 2009, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Conversion between TyThing and HsDecl. This functionality may be moved into +-- GHC at some point. +----------------------------------------------------------------------------- +module Haddock.Convert ( + tyThingToLHsDecl, + synifyInstHead, + synifyFamInst, + PrintRuntimeReps(..), +) where + +import Control.DeepSeq (force) +import GHC.Data.Bag ( emptyBag ) +import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) ) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.PatSyn +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqTypes ) + +import GHC.Hs +import GHC.Types.TyThing +import GHC.Types.Name +import GHC.Types.Name.Set ( emptyNameSet ) +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Builtin.Types.Prim ( alphaTyVars ) +import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName + , unitTy, promotedNilDataCon, promotedConsDataCon ) +import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey + , liftedDataConKey, boxedRepDataConKey ) +import GHC.Types.Unique ( getUnique ) +import GHC.Utils.Misc ( chkAppend, dropList, equalLength + , filterByList, filterOut ) +import GHC.Utils.Panic.Plain ( assert ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.SrcLoc + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Haddock.Types +import Haddock.Interface.Specialize +import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType ) + +import Data.Either (lefts, rights) +import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) +import Data.Either ( partitionEithers ) + + +-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check +-- out Note [Defaulting RuntimeRep variables] in GHC.Iface.Type for the +-- motivation. +data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show + +-- the main function here! yay! +tyThingToLHsDecl + :: PrintRuntimeReps + -> TyThing + -> Either String ([String], (HsDecl GhcRn)) +tyThingToLHsDecl prr t = case t of + -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. + -- Including built-in functions like seq. + -- foreign-imported functions could be represented with ForD + -- instead of SigD if we wanted... + -- + -- in a future code version we could turn idVarDetails = foreign-call + -- into a ForD instead of a SigD if we wanted. Haddock doesn't + -- need to care. + AnId i -> allOK $ SigD noExtField (synifyIdSig prr ImplicitizeForAll [] i) + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ATyCon tc + | Just cl <- tyConClass_maybe tc -- classes are just a little tedious + -> let extractFamilyDecl :: TyClDecl a -> Either String (FamilyDecl a) + extractFamilyDecl (FamDecl _ d) = return d + extractFamilyDecl _ = + Left "tyThingToLHsDecl: impossible associated tycon" + + cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn + -- Without this signature, we trigger GHC#18932 + cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n + cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn + (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind + + -- | Convert a LHsTyVarBndr to an equivalent LHsType. + hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn + hsLTyVarBndrToType = fmap cvt + + extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn + extractFamDefDecl fd rhs = + TyFamInstDecl noAnn $ FamEqn + { feqn_ext = noAnn + , feqn_tycon = fdLName fd + , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)} + , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ + hsq_explicit $ fdTyVars fd + , feqn_fixity = fdFixity fd + , feqn_rhs = synifyType WithinType [] rhs } + + extractAtItem + :: ClassATItem + -> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn)) + extractAtItem (ATI at_tc def) = do + tyDecl <- synifyTyCon prr Nothing at_tc + famDecl <- extractFamilyDecl tyDecl + let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def + pure (noLocA famDecl, defEqnTy) + + atTyClDecls = map extractAtItem (classATItems cl) + (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) + vs = tyConVisibleTyVars (classTyCon cl) + + in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl + { tcdCtxt = Just $ synifyCtx (classSCTheta cl) + , tcdLayout = NoLayoutInfo + , tcdLName = synifyNameN cl + , tcdTyVars = synifyTyVars vs + , tcdFixity = synifyFixity cl + , tcdFDs = map (\ (l,r) -> noLocA + (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $ + snd $ classTvsFds cl + , tcdSigs = noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl) : + [ noLocA tcdSig + | clsOp <- classOpItems cl + , tcdSig <- synifyTcIdSig vs clsOp ] + , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature + -- class associated-types are a subset of TyCon: + , tcdATs = atFamDecls + , tcdATDefs = catMaybes atDefFamDecls + , tcdDocs = [] --we don't have any docs at this point + , tcdCExt = emptyNameSet } + | otherwise + -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ACoAxiom ax -> synifyAxiom ax >>= allOK + + -- a data-constructor alone just gets rendered as a function: + AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc] + (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc))) + + AConLike (PatSynCon ps) -> + allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps) + where + withErrs e x = return (e, x) + allOK x = return (mempty, x) + +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn +synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) + = let name = synifyNameN tc + args_types_only = filterOutInvisibleTypes tc args + typats = map (synifyType WithinType []) args_types_only + annot_typats = zipWith3 annotHsType args_poly args_types_only typats + hs_rhs = synifyType WithinType [] rhs + outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs} + -- TODO: this must change eventually + in FamEqn { feqn_ext = noAnn + , feqn_tycon = name + , feqn_bndrs = outer_bndrs + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name + , feqn_rhs = hs_rhs } + where + args_poly = tyConArgsPolyKinded tc + +synifyAxiom :: CoAxiom br -> Either String (HsDecl GhcRn) +synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) + | isOpenTypeFamilyTyCon tc + , Just branch <- coAxiomSingleBranch_maybe ax + = return $ InstD noExtField + $ TyFamInstD noExtField + $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch } + + | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc + , getUnique ax' == getUnique ax -- without the getUniques, type error + = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExtField + + | otherwise + = Left "synifyAxiom: closed/open family confusion" + +-- | Turn type constructors into data declarations, type families, or type synonyms +synifyTyCon + :: PrintRuntimeReps + -> Maybe (CoAxiom br) -- ^ RHS of type synonym + -> TyCon -- ^ type constructor to convert + -> Either String (TyClDecl GhcRn) +synifyTyCon prr _coax tc + | isPrimTyCon tc + = return $ + DataDecl { tcdLName = synifyNameN tc + , tcdTyVars = HsQTvs { hsq_ext = [] -- No kind polymorphism + , hsq_explicit = zipWith mk_hs_tv + (map scaledThing tyVarKinds) + alphaTyVars --a, b, c... which are unfortunately all kind * + } + + , tcdFixity = synifyFixity tc + + , tcdDataDefn = HsDataDefn { dd_ext = noExtField + , dd_cons = DataTypeCons False [] -- No constructors; arbitrary lie, they are neither + -- algebraic data nor newtype: + , dd_ctxt = Nothing + , dd_cType = Nothing + , dd_kindSig = synifyDataTyConReturnKind tc + -- we have their kind accurately: + , dd_derivs = [] } + , tcdDExt = DataDeclRn False emptyNameSet } + where + -- tyConTyVars doesn't work on fun/prim, but we can make them up: + mk_hs_tv realKind fakeTyVar + | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar)) + | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind) + + conKind = defaultType prr (tyConKind tc) + tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind + +synifyTyCon _prr _coax tc + | Just flav <- famTyConFlav_maybe tc + = case flav of + -- Type families + OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily + ClosedSynFamilyTyCon mb + | Just (CoAxiom { co_ax_branches = branches }) <- mb + -> mkFamDecl $ ClosedTypeFamily $ Just + $ map (noLocA . synifyAxBranch tc) (fromBranches branches) + | otherwise + -> mkFamDecl $ ClosedTypeFamily $ Just [] + BuiltInSynFamTyCon {} + -> mkFamDecl $ ClosedTypeFamily $ Just [] + AbstractClosedSynFamilyTyCon {} + -> mkFamDecl $ ClosedTypeFamily Nothing + DataFamilyTyCon {} + -> mkFamDecl DataFamily + where + resultVar = tyConFamilyResVar_maybe tc + mkFamDecl i = return $ FamDecl noExtField $ + FamilyDecl { fdExt = noAnn + , fdInfo = i + , fdTopLevel = TopLevel + , fdLName = synifyNameN tc + , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) + , fdFixity = synifyFixity tc + , fdResultSig = + synifyFamilyResultSig resultVar (tyConResKind tc) + , fdInjectivityAnn = + synifyInjectivityAnn resultVar (tyConTyVars tc) + (tyConInjectivityInfo tc) + } + +synifyTyCon _prr coax tc + | Just ty <- synTyConRhs_maybe tc + = return $ SynDecl { tcdSExt = emptyNameSet + , tcdLName = synifyNameN tc + , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) + , tcdFixity = synifyFixity tc + , tcdRhs = synifyType WithinType [] ty } + | otherwise = do + -- (closed) newtype and data + let alg_ctx = synifyCtx (tyConStupidTheta tc) + name = case coax of + Just a -> synifyNameN a -- Data families are named according to their + -- CoAxioms, not their TyCons + _ -> synifyNameN tc + tyvars = synifyTyVars (tyConVisibleTyVars tc) + kindSig = synifyDataTyConReturnKind tc + -- The data constructors. + -- + -- Any data-constructors not exported from the module that *defines* the + -- type will not (cannot) be included. + -- + -- Very simple constructors, Haskell98 with no existentials or anything, + -- probably look nicer in non-GADT syntax. In source code, all constructors + -- must be declared with the same (GADT vs. not) syntax, and it probably + -- is less confusing to follow that principle for the documentation as well. + -- + -- There is no sensible infix-representation for GADT-syntax constructor + -- declarations. They cannot be made in source code, but we could end up + -- with some here in the case where some constructors use existentials. + -- That seems like an acceptable compromise (they'll just be documented + -- in prefix position), since, otherwise, the logic (at best) gets much more + -- complicated. (would use dataConIsInfix.) + use_gadt_syntax = isGadtSyntaxTyCon tc + consRaw <- case partitionEithers $ synifyDataCon use_gadt_syntax <$> tyConDataCons tc of + ([], consRaw) -> Right consRaw + (errs, _) -> Left (unlines errs) + cons <- case (isNewTyCon tc, consRaw) of + (False, cons) -> Right (DataTypeCons False cons) + (True, [con]) -> Right (NewTypeCon con) + (True, _) -> Left "Newtype hasn't 1 constructor" + + let -- "deriving" doesn't affect the signature, no need to specify any. + alg_deriv = [] + defn = HsDataDefn { dd_ext = noExtField + , dd_ctxt = Just alg_ctx + , dd_cType = Nothing + , dd_kindSig = kindSig + , dd_cons = cons + , dd_derivs = alg_deriv } + pure DataDecl { tcdLName = name, tcdTyVars = tyvars + , tcdFixity = synifyFixity name + , tcdDataDefn = defn + , tcdDExt = DataDeclRn False emptyNameSet } + +-- | In this module, every TyCon being considered has come from an interface +-- file. This means that when considering a data type constructor such as: +-- +-- > data Foo (w :: *) (m :: * -> *) (a :: *) +-- +-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are +-- also rendering the type variables of Foo, so if we synify the tyConKind of +-- Foo in full, we will end up displaying this in Haddock: +-- +-- > data Foo (w :: *) (m :: * -> *) (a :: *) +-- > :: * -> (* -> *) -> * -> * +-- +-- Which is entirely wrong (#548). We only want to display the /return/ kind, +-- which this function obtains. +synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) +synifyDataTyConReturnKind tc + | isLiftedTypeKind ret_kind = Nothing -- Don't bother displaying :: * + | otherwise = Just (synifyKindSig ret_kind) + where ret_kind = tyConResKind tc + +synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity + -> Maybe (LInjectivityAnn GhcRn) +synifyInjectivityAnn Nothing _ _ = Nothing +synifyInjectivityAnn _ _ NotInjective = Nothing +synifyInjectivityAnn (Just lhs) tvs (Injective inj) = + let rhs = map (noLocA . tyVarName) (filterByList inj tvs) + in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs + +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn +synifyFamilyResultSig Nothing kind + | isLiftedTypeKind kind = noLocA $ NoSig noExtField + | otherwise = noLocA $ KindSig noExtField (synifyKindSig kind) +synifyFamilyResultSig (Just name) kind = + noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind)) + +-- User beware: it is your responsibility to pass True (use_gadt_syntax) +-- for any constructor that would be misrepresented by omitting its +-- result-type. +-- But you might want pass False in simple enough cases, +-- if you think it looks better. +synifyDataCon :: Bool -> DataCon -> Either String (LConDecl GhcRn) +synifyDataCon use_gadt_syntax dc = + let + -- dataConIsInfix allegedly tells us whether it was declared with + -- infix *syntax*. + use_infix_syntax = dataConIsInfix dc + use_named_field_syntax = not (null field_tys) + name = synifyNameN dc + -- con_qvars means a different thing depending on gadt-syntax + (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors + + outer_bndrs | null user_tvbndrs + = HsOuterImplicit { hso_ximplicit = [] } + | otherwise + = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = map synifyTyVarBndr user_tvbndrs } + + -- skip any EqTheta, use 'orig'inal syntax + ctx | null theta = Nothing + | otherwise = Just $ synifyCtx theta + + linear_tys = + zipWith (\ty bang -> + let tySyn = synifyType WithinType [] (scaledThing ty) + in case bang of + (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn + bang' -> noLocA $ HsBangTy noAnn bang' tySyn) + arg_tys (dataConSrcBangs dc) + + field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys + con_decl_field fl synTy = noLocA $ + ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)] synTy + Nothing + + mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn) + mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of + (True,True) -> Left "synifyDataCon: contradiction!" + (True,False) -> return $ RecCon (noLocA field_tys) + (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys) + (False,True) -> case linear_tys of + [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) + _ -> Left "synifyDataCon: infix with non-2 args?" + + mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn + mk_gadt_arg_tys + | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok + | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) + + -- finally we get synifyDataCon's result! + in if use_gadt_syntax + then do + let hat = mk_gadt_arg_tys + return $ noLocA $ ConDeclGADT + { con_g_ext = noAnn + , con_names = pure name + , con_dcolon = noHsUniTok + , con_bndrs = noLocA outer_bndrs + , con_mb_cxt = ctx + , con_g_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } + else do + hat <- mk_h98_arg_tys + return $ noLocA $ ConDeclH98 + { con_ext = noAnn + , con_name = name + , con_forall = False + , con_ex_tvs = map (synifyTyVarBndr . (mkForAllTyBinder InferredSpec)) ex_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_doc = Nothing } + +synifyNameN :: NamedThing n => n -> LocatedN Name +synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) + +-- synifyName :: NamedThing n => n -> LocatedA Name +-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) + +-- | Guess the fixity of a something with a name. This isn't quite right, since +-- a user can always declare an infix name in prefix form or a prefix name in +-- infix form. Unfortunately, that is not something we can usually reconstruct. +synifyFixity :: NamedThing n => n -> LexicalFixity +synifyFixity n | isSymOcc (getOccName n) = Infix + | otherwise = Prefix + +synifyIdSig + :: PrintRuntimeReps -- ^ are we printing tyvars of kind 'RuntimeRep'? + -> SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Id -- ^ the 'Id' from which to get the type signature + -> Sig GhcRn +synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t) + where + !n = force $ synifyNameN i + t = defaultType prr (varType i) + +-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going +-- to contain the synified 'ClassOpSig' as well (when appropriate) a default +-- 'ClassOpSig'. +synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] +synifyTcIdSig vs (i, dm) = + [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] ++ + [ ClassOpSig noAnn True [noLocA dn] (defSig dt) + | Just (dn, GenericDM dt) <- [dm] ] + where + mainSig t = synifySigType DeleteTopLevelQuantification vs t + defSig t = synifySigType ImplicitizeForAll vs t + +synifyCtx :: [PredType] -> LHsContext GhcRn +synifyCtx ts = noLocA ( map (synifyType WithinType []) ts) + + +synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn +synifyTyVars ktvs = HsQTvs { hsq_ext = [] + , hsq_explicit = map synifyTyVar ktvs } + +synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn +synifyTyVar = synify_ty_var emptyVarSet () + +synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr = synifyTyVarBndr' emptyVarSet + +synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn +synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv + +-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind +-- signatures (even if they don't have the lifted type kind). +synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn +synify_ty_var no_kinds flag tv + | isLiftedTypeKind kind || tv `elemVarSet` no_kinds + = noLocA (UserTyVar noAnn flag (noLocA name)) + | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv + +-- | Annotate (with HsKingSig) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to synify type patterns for poly-kinded tyvars in +-- synifying class and type instances. +annotHsType :: Bool -- True <=> annotate + -> Type -> LHsType GhcRn -> LHsType GhcRn + -- tiny optimization: if the type is annotated, don't annotate again. +annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty +annotHsType True ty hs_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = let ki = typeKind ty + hs_ki = synifyType WithinType [] ki + in noLocA (HsKindSig noAnn hs_ty hs_ki) +annotHsType _ _ hs_ty = hs_ty + +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs + ++ repeat True + where + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [PiTyBinder] + tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc + +--states of what to do with foralls: +data SynifyTypeState + = WithinType + -- ^ normal situation. This is the safe one to use if you don't + -- quite understand what's going on. + | ImplicitizeForAll + -- ^ beginning of a function definition, in which, to make it look + -- less ugly, those rank-1 foralls (without kind annotations) are made + -- implicit. + | DeleteTopLevelQuantification + -- ^ because in class methods the context is added to the type + -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) + -- which is rather sensible, + -- but we want to restore things to the source-syntax situation where + -- the defining class gets to quantify all its functions for free! + + +synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn +-- The use of mkEmptySigType (which uses empty binders in OuterImplicit) +-- is a bit suspicious; what if the type has free variables? +synifySigType s vs ty = mkEmptySigType (synifyType s vs ty) + +synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn +-- Ditto (see synifySigType) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty)) + +synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn +-- Ditto (see synifySigType) +synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps) + +-- | Depending on the first argument, try to default all type variables of kind +-- 'RuntimeRep' to 'LiftedType'. +defaultType :: PrintRuntimeReps -> Type -> Type +defaultType ShowRuntimeRep = id +defaultType HideRuntimeRep = defaultRuntimeRepVars + +-- | Convert a core type into an 'HsType'. +synifyType + :: SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the type to convert + -> LHsType GhcRn +synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv) +synifyType _ vs (TyConApp tc tys) + = maybe_sig res_ty + where + res_ty :: LHsType GhcRn + res_ty + -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) + | tc `hasKey` tYPETyConKey + , [TyConApp rep [TyConApp lev []]] <- tys + , rep `hasKey` boxedRepDataConKey + , lev `hasKey` liftedDataConKey + = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName)) + -- Use non-prefix tuple syntax where possible, because it looks nicer. + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == tys_len + = noLocA $ HsTupleTy noAnn + (case sort of + BoxedTuple -> HsBoxedOrConstraintTuple + ConstraintTuple -> HsBoxedOrConstraintTuple + UnboxedTuple -> HsUnboxedTuple) + (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) + -- ditto for lists + | getName tc == listTyConName, [ty] <- vis_tys = + noLocA $ HsListTy noAnn (synifyType WithinType vs ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLocA $ HsExplicitListTy noExtField IsPromoted [] + | tc == promotedConsDataCon + , [ty1, ty2] <- vis_tys + = let hTy = synifyType WithinType vs ty1 + in case synifyType WithinType vs ty2 of + tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy + -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') + | otherwise + -> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy + -- ditto for implicit parameter tycons + | tc `hasKey` ipClassKey + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty) + -- and equalities + | tc `hasKey` eqTyConKey + , [ty1, ty2] <- tys + = noLocA $ HsOpTy noAnn + NotPromoted + (synifyType WithinType vs ty1) + (noLocA eqTyConName) + (synifyType WithinType vs ty2) + -- and infix type operators + | isSymOcc (nameOccName (getName tc)) + , ty1:ty2:tys_rest <- vis_tys + = mk_app_tys (HsOpTy noAnn + prom + (synifyType WithinType vs ty1) + (noLocA $ getName tc) + (synifyType WithinType vs ty2)) + tys_rest + -- Most TyCons: + | otherwise + = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc)) + vis_tys + where + !prom = if isPromotedDataCon tc then IsPromoted else NotPromoted + mk_app_tys ty_app ty_args = + foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) + (noLocA ty_app) + (map (synifyType WithinType vs) $ + filterOut isCoercionTy ty_args) + + tys_len = length tys + vis_tys = filterOutInvisibleTypes tc tys + + maybe_sig :: LHsType GhcRn -> LHsType GhcRn + maybe_sig ty' + | tyConAppNeedsKindSig False tc tys_len + = let full_kind = typeKind (mkTyConApp tc tys) + full_kind' = synifyType WithinType vs full_kind + in noLocA $ HsKindSig noAnn ty' full_kind' + | otherwise = ty' + +synifyType _ vs ty@(AppTy {}) = let + (ty_head, ty_args) = splitAppTys ty + ty_head' = synifyType WithinType vs ty_head + ty_args' = map (synifyType WithinType vs) $ + filterOut isCoercionTy $ + filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args) + ty_args + in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args' + +synifyType s vs funty@(FunTy af w t1 t2) + | isInvisibleFunArg af = synifySigmaType s vs funty + | otherwise = noLocA $ HsFunTy noAnn w' s1 s2 + where + s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 + w' = synifyMult vs w + +synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) = + case argf of + Required -> synifyVisForAllType vs forallty + Invisible _ -> synifySigmaType s vs forallty + +synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t +synifyType s vs (CastTy t _) = synifyType s vs t +synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" + +-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType' +synifyVisForAllType + :: [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyVisForAllType vs ty = + let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty + + sTvs = map synifyTyVarBndr tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) [rho] + + in noLocA $ HsForAllTy { hst_tele = mkHsForAllVisTele noAnn sTvs + , hst_xforall = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) rho } + +-- | Process a 'Type' which starts with an invisible @forall@ or a constraint +-- into an 'HsType' +synifySigmaType + :: SynifyTypeState -- ^ what to do with the 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifySigmaType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExtField + , hst_body = synifyType WithinType (tvs' ++ vs) tau } + + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs + , hst_xforall = noExtField + , hst_body = noLocA sPhi } + + sTvs = map synifyTyVarBndr tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + + in case s of + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau + + -- Put a forall in if there are any type variables + WithinType + | not (null tvs) -> noLocA sTy + | otherwise -> noLocA sPhi + + ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau + +-- | Put a forall in if there are any type variables which require +-- explicit kind annotations or if the inferred type variable order +-- would be different. +implicitForAll + :: [TyCon] -- ^ type constructors that determine their args kinds + -> [TyVar] -- ^ free variables in the type to convert + -> [InvisTVBinder] -- ^ type variable binders in the forall + -> ThetaType -- ^ constraints right after the forall + -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type + -> Type -- ^ inner type + -> LHsType GhcRn +implicitForAll tycons vs tvs ctx synInner tau + | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy + | tvs' /= (binderVars tvs) = noLocA sTy + | otherwise = noLocA sPhi + where + sRho = synInner (tvs' ++ vs) tau + sPhi | null ctx = unLoc sRho + | otherwise + = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExtField + , hst_body = synInner (tvs' ++ vs) tau } + sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs + , hst_xforall = noExtField + , hst_body = noLocA sPhi } + + no_kinds_needed = noKindTyVars tycons tau + sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) + + + +-- | Find the set of type variables whose kind signatures can be properly +-- inferred just from their uses in the type signature. This means the type +-- variable to has at least one fully applied use @f x1 x2 ... xn@ where: +-- +-- * @f@ has a function kind where the arguments have the same kinds +-- as @x1 x2 ... xn@. +-- +-- * @f@ has a function kind whose final return has lifted type kind +-- +noKindTyVars + :: [TyCon] -- ^ type constructors that determine their args kinds + -> Type -- ^ type to inspect + -> VarSet -- ^ set of variables whose kinds can be inferred from uses in the type +noKindTyVars _ (TyVarTy var) + | isLiftedTypeKind (tyVarKind var) = unitVarSet var +noKindTyVars ts ty + | (f, xs) <- splitAppTys ty + , not (null xs) + = let args = map (noKindTyVars ts) xs + func = case f of + TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) + , map scaledThing xsKinds `eqTypes` map typeKind xs + , isLiftedTypeKind outKind + -> unitVarSet var + TyConApp t ks | t `elem` ts + , all noFreeVarsOfType ks + -> mkVarSet [ v | TyVarTy v <- xs ] + _ -> noKindTyVars ts f + in unionVarSets (func : args) +noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t +noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet` + noKindTyVars ts t1 `unionVarSet` + noKindTyVars ts t2 +noKindTyVars ts (CastTy t _) = noKindTyVars ts t +noKindTyVars _ _ = emptyVarSet + +synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn +synifyMult vs t = case t of + OneTy -> HsLinearArrow (HsPct1 noHsTok noHsUniTok) + ManyTy -> HsUnrestrictedArrow noHsUniTok + ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok + + + +synifyPatSynType :: PatSyn -> LHsType GhcRn +synifyPatSynType ps = + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps + ts = maybeToList (tyConAppTyCon_maybe res_ty) + + -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", + -- i.e., an explicit empty context, which is what we need. This is not + -- possible by taking theta = [], as that will print no context at all + req_theta' | null req_theta + , not (null prov_theta && null ex_tvs) + = [unitTy] + | otherwise = req_theta + + in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta' + (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType)) + (mkScaledFunTys arg_tys res_ty) + +synifyTyLit :: TyLit -> HsTyLit GhcRn +synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n +synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s +synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c + +synifyKindSig :: Kind -> LHsKind GhcRn +synifyKindSig k = synifyType WithinType [] k + +stripKindSig :: LHsType GhcRn -> LHsType GhcRn +stripKindSig (L _ (HsKindSig _ t _)) = t +stripKindSig t = t + +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn +synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead + { ihdClsName = getName cls + , ihdTypes = map unLoc annot_ts + , ihdInstType = ClassInst + { clsiCtx = map (unLoc . synifyType WithinType []) preds + , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) + , clsiSigs = map synifyClsIdSig $ classMethods cls + , clsiAssocTys = do + (Right (FamDecl _ fam)) <- map (synifyTyCon HideRuntimeRep Nothing) + (classATs cls) + pure $ mkPseudoFamilyDecl fam + } + } + where + cls_tycon = classTyCon cls + ts = filterOutInvisibleTypes cls_tycon types + ts' = map (synifyType WithinType vs) ts + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded cls_tycon + synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs + +-- Convert a family instance, this could be a type family or data family +synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn) +synifyFamInst fi opaque = do + ityp' <- ityp fam_flavor + return InstHead + { ihdClsName = fi_fam fi + , ihdTypes = map unLoc annot_ts + , ihdInstType = ityp' + } + where + ityp SynFamilyInst | opaque = return $ TypeInst Nothing + ityp SynFamilyInst = + return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs + ityp (DataFamilyInst c) = + DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c + fam_tc = famInstTyCon fi + fam_flavor = fi_flavor fi + fam_lhs = fi_tys fi + fam_rhs = fi_rhs fi + + eta_expanded_lhs + -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See Trac #9692 + -- See Note [Eta reduction for data family axioms] in GHC.Tc.TyCl.Instance in GHC + | DataFamilyInst rep_tc <- fam_flavor + = let (_, rep_tc_args) = splitTyConApp fam_rhs + etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc + etad_tys = mkTyVarTys etad_tyvars + eta_exp_lhs = fam_lhs `chkAppend` etad_tys + in eta_exp_lhs + | otherwise + = fam_lhs + + ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs + synifyTypes = map (synifyType WithinType []) + ts' = synifyTypes ts + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded fam_tc + +{- +Note [Invariant: Never expand type synonyms] + +In haddock, we never want to expand a type synonym that may be presented to the +user, as we want to keep the link to the abstraction captured in the synonym. + +All code in Haddock.Convert must make sure that this invariant holds. + +See https://github.com/haskell/haddock/issues/879 for a bug where this +invariant didn't hold. +-} + +-- | A version of 'TcType.tcSplitSigmaTy' that: +-- +-- 1. Preserves type synonyms. +-- 2. Returns 'InvisTVBinder's instead of 'TyVar's. +-- +-- See Note [Invariant: Never expand type synonyms] +tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type) +tcSplitSigmaTyPreserveSynonyms ty = + case tcSplitForAllTysInvisPreserveSynonyms ty of + (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of + (theta, tau) -> (tvs, theta, tau) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitSomeForAllTysPreserveSynonyms :: + (ForAllTyFlag -> Bool) -> Type -> ([ForAllTyBinder], Type) +tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty [] + where + split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs + | argf_pred argf = split ty' ty' (tvb:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type) +tcSplitForAllTysReqPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleForAllTyFlag ty + req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in + assert ( req_bndrs `equalLength` all_bndrs) + (req_bndrs, body) + where + mk_req_bndr_maybe :: ForAllTyBinder -> Maybe ReqTVBinder + mk_req_bndr_maybe (Bndr tv argf) = case argf of + Required -> Just $ Bndr tv () + Invisible _ -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type) +tcSplitForAllTysInvisPreserveSynonyms ty = + let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleForAllTyFlag ty + inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in + assert ( inv_bndrs `equalLength` all_bndrs) + (inv_bndrs, body) + where + mk_inv_bndr_maybe :: ForAllTyBinder -> Maybe InvisTVBinder + mk_inv_bndr_maybe (Bndr tv argf) = case argf of + Invisible s -> Just $ Bndr tv s + Required -> Nothing + +-- | See Note [Invariant: Never expand type synonyms] + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) +tcSplitPhiTyPreserveSynonyms ty0 = split ty0 [] + where + split ty ts + = case tcSplitPredFunTyPreserveSynonyms_maybe ty of + Just (pred_, ty') -> split ty' (pred_:ts) + Nothing -> (reverse ts, ty) + +-- | See Note [Invariant: Never expand type synonyms] +tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type) +tcSplitPredFunTyPreserveSynonyms_maybe (FunTy af _ arg res) + | isInvisibleFunArg af = Just (arg, res) +tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -1,5 +1,14 @@ -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -17,141 +26,432 @@ import Control.Arrow -import Data.Function +import Data.Char ( isSpace ) +import Data.Foldable ( toList, foldl' ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Maybe ( mapMaybe, fromMaybe ) +import qualified Data.Set as Set -import Exception -import Outputable -import Name -import Lexeme -import Module -import RdrName (GlobalRdrEnv) -import GhcMonad (withSession) -import HscTypes -import UniqFM +import Haddock.Types( DocName, DocNameI, XRecCond ) + +import GHC.Utils.FV as FV +import GHC.Utils.Outputable ( Outputable ) +import GHC.Utils.Panic ( panic ) +import GHC.Driver.Ppr (showPpr ) +import GHC.Types.Name +import GHC.Unit.Module import GHC -import Class +import GHC.Driver.Session +import GHC.Types.SrcLoc ( advanceSrcLoc ) +import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder + , tyVarKind, updateTyVarKind, isInvisibleForAllTyFlag ) +import GHC.Types.Var.Set ( VarSet, emptyVarSet ) +import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) +import GHC.Core.TyCo.Rep ( Type(..) ) +import GHC.Core.Type ( isRuntimeRepVar, binderVar ) +import GHC.Builtin.Types( liftedRepTy ) +import GHC.Data.StringBuffer ( StringBuffer ) +import qualified GHC.Data.StringBuffer as S +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS + +import GHC.HsToCore.Docs + moduleString :: Module -> String moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName - -isVarSym :: OccName -> Bool -isVarSym = isLexVarSym . occNameFS - -isConSym :: OccName -> Bool -isConSym = isLexConSym . occNameFS - - -getMainDeclBinder :: HsDecl name -> [name] -getMainDeclBinder (TyClD d) = [tcdName d] -getMainDeclBinder (ValD d) = - case collectHsBindBinders d of - [] -> [] - (name:_) -> [name] -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - --- Extract the source location where an instance is defined. This is used --- to correlate InstDecls with their Instance/CoAxiom Names, via the --- instanceMap. -getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l -getInstLoc (TyFamInstD (TyFamInstDecl - -- Since CoAxioms' Names refer to the whole line for type family instances - -- in particular, we need to dig a bit deeper to pull out the entire - -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l - -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) -filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p (FixSig (FixitySig ns ty)) = +filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p)) +filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig (FixitySig filtered ty)) + filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty) = +filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) -filterSigNames p (ClassOpSig is_default ns ty) = + filtered -> Just (TypeSig noAnn filtered ty) +filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig is_default filtered ty) -filterSigNames _ _ = Nothing + filtered -> Just (ClassOpSig noAnn is_default filtered ty) +filterSigNames p (PatSynSig _ ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (PatSynSig noAnn filtered ty) +filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [name] -sigName (L _ sig) = sigNameNoLoc sig - -sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns -sigNameNoLoc _ = [] +sigName :: LSig GhcRn -> [IdP GhcRn] +sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig -- | Was this signature given by the user? -isUserLSig :: LSig name -> Bool -isUserLSig (L _(TypeSig {})) = True -isUserLSig (L _(ClassOpSig {})) = True -isUserLSig _ = False - +isUserLSig :: forall p. UnXRec p => LSig p -> Bool +isUserLSig = isUserSig . unXRec @p isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d +isClassD (TyClD _ d) = isClassDecl d isClassD _ = False -isValD :: HsDecl a -> Bool -isValD (ValD _) = True -isValD _ = False +pretty :: Outputable a => DynFlags -> a -> String +pretty = showPpr +-- --------------------------------------------------------------------- -declATs :: HsDecl a -> [a] -declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d -declATs _ = [] +-- These functions are duplicated from the GHC API, as they must be +-- instantiated at DocNameI instead of (GhcPass _). +-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) +hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ DataConCantHappen, UnXRec n) + => HsTyVarBndr flag n -> IdP n +hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name +hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name -pretty :: Outputable a => DynFlags -> a -> String -pretty = showPpr +hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName +hsTyVarNameI (UserTyVar _ _ (L _ n)) = n +hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n +hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName +hsLTyVarNameI = hsTyVarNameI . unLoc + +getConNamesI :: ConDecl DocNameI -> NonEmpty (LocatedN DocName) +getConNamesI ConDeclH98 {con_name = name} = pure name +getConNamesI ConDeclGADT {con_names = names} = names + +hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI +hsSigTypeI = sig_body . unLoc + +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free variables +mkEmptySigType lty@(L loc ty) = L loc $ case ty of + HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = body } + -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField + , hso_bndrs = bndrs } + , sig_body = body } + _ -> HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = []} + , sig_body = lty } + +mkHsForAllInvisTeleI :: + [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI +mkHsForAllInvisTeleI invis_bndrs = + HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } + +mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI +mkHsImplicitSigTypeI body = + HsSig { sig_ext = noExtField + , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField} + , sig_body = body } + +getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI +-- The full type of a GADT data constructor We really only get this in +-- order to pretty-print it, and currently only in Haddock's code. So +-- we are cavalier about locations and extensions, hence the +-- 'undefined's +getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty }) + = noLocA (HsSig { sig_ext = noExtField + , sig_bndrs = outer_bndrs + , sig_body = theta_ty }) + where + theta_ty | Just theta <- mcxt + = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty }) + | otherwise + = tau_ty + +-- tau_ty :: LHsType DocNameI + tau_ty = case args of + RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty + PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) + + mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) + +getGADTConType (ConDeclH98 {}) = panic "getGADTConType" + -- Should only be called on ConDeclGADT + +getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] +getMainDeclBinderI (TyClD _ d) = [tcdNameI d] +getMainDeclBinderI (ValD _ d) = + case collectHsBindBinders CollNoDictBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d +getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinderI _ = [] + +familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName +familyDeclLNameI (FamilyDecl { fdLName = n }) = n + +tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName +tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd +tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln +tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln +tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln + +tcdNameI :: TyClDecl DocNameI -> DocName +tcdNameI = unLoc . tyClDeclLNameI + +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn +-- Add the class context to a class-op signature +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) + where + go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty })) + = L loc (HsSig { sig_ext = noExtField + , sig_bndrs = bndrs, sig_body = go_ty ty }) + + go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty })) + = L loc (HsForAllTy { hst_xforall = noExtField + , hst_tele = tele, hst_body = go_ty ty }) + go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go_ty (L loc ty) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp NotPromoted Prefix cls (lHsQTyVarsToTypes tvs0) + + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn] +lHsQTyVarsToTypes tvs + = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv))) + | tv <- hsQTvExplicit tvs ] + + +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- + +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn +restrictTo names (L loc decl) = L loc $ case decl of + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), + tcdATs = restrictATs names (tcdATs d) }) + _ -> decl + +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn +restrictDataDefn names d = d { dd_cons = restrictDataDefnCons names (dd_cons d) } + +restrictDataDefnCons :: [Name] -> DataDefnCons (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn) +restrictDataDefnCons names = \ case + DataTypeCons is_type_data cons -> DataTypeCons is_type_data (restrictCons names cons) + NewTypeCon con -> maybe (DataTypeCons False []) NewTypeCon $ restrictCons names (Just con) + +restrictCons :: MonadFail m => [Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn) +restrictCons names decls = [ L p d | L p (Just d) <- fmap keep <$> decls ] + where + keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn) + keep d + | any (`elem` names) (unLoc <$> getConNames d) = + case d of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon {} -> Just d + RecCon fields + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc fields) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT {} -> Just d + RecConGADT fields _ + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) }) + -- see above + where + field_avail :: LConDeclField GhcRn -> Bool + field_avail (L _ (ConDeclField _ fs _ _)) + = all (\f -> foExt (unLoc f) `elem` names) fs + + field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] + + keep _ = Nothing + +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) + + +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] +restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ] + + ------------------------------------------------------------------------------- +-- * Parenthesization +------------------------------------------------------------------------------- + +-- | Precedence level (inside the 'HsType' AST). +data Precedence + = PREC_TOP -- ^ precedence of 'type' production in GHC's parser + + | PREC_SIG -- ^ explicit type signature + + | PREC_CTX -- ^ Used for single contexts, eg. ctx => type + -- (as opposed to (ctx1, ctx2) => type) + + | PREC_FUN -- ^ precedence of 'btype' production in GHC's parser + -- (used for LH arg of (->)) + + | PREC_OP -- ^ arg of any infix operator + -- (we don't keep have fixity info) + + | PREC_CON -- ^ arg of type application: always parenthesize unless atomic + deriving (Eq, Ord) + +-- | Add in extra 'HsParTy' where needed to ensure that what would be printed +-- out using 'ppr' has enough parentheses to be re-parsed properly. +-- +-- We cannot add parens that may be required by fixities because we do not have +-- any fixity information to work with in the first place :(. +reparenTypePrec :: forall a. (XRecCond a) + => Precedence -> HsType a -> HsType a +reparenTypePrec = go + where + + -- Shorter name for 'reparenType' + go :: Precedence -> HsType a -> HsType a + go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) + go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) + go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) + go _ (HsListTy x ty) = HsListTy x (reparenLType ty) + go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds) + go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d + go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) + go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) + go p (HsKindSig x ty kind) + = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) + go p (HsIParamTy x n ty) + = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) + go p (HsForAllTy x tele ty) + = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) + go p (HsQualTy x ctxt ty) + = let p' [_] = PREC_CTX + p' _ = PREC_TOP -- parens will get added anyways later... + ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt + in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) + go p (HsFunTy x w ty1 ty2) + = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) + go p (HsAppTy x fun_ty arg_ty) + = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) + go p (HsAppKindTy x fun_ty arg_ki) + = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) + go p (HsOpTy x prom ty1 op ty2) + = paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2) + go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed + go _ t@HsTyVar{} = t + go _ t@HsStarTy{} = t + go _ t@HsSpliceTy{} = t + go _ t@HsTyLit{} = t + go _ t@HsWildCardTy{} = t + go _ t@XHsType{} = t + + -- Located variant of 'go' + goL :: Precedence -> LHsType a -> LHsType a + goL ctxt_prec = mapXRec @a (go ctxt_prec) + + -- Optionally wrap a type in parens + paren :: Precedence -- Precedence of context + -> Precedence -- Precedence of top-level operator + -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a + | otherwise = id + + +-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') +reparenType :: XRecCond a => HsType a -> HsType a +reparenType = reparenTypePrec PREC_TOP + +-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') +reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a +reparenLType = mapXRec @a reparenType + +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') +reparenSigType :: forall a. ( XRecCond a ) + => HsSigType a -> HsSigType a +reparenSigType (HsSig x bndrs body) = + HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body) +reparenSigType v@XHsSigType{} = v + +-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') +reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a ) + => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a +reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp +reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs) +reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v + +-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') +reparenHsForAllTelescope :: forall a. (XRecCond a ) + => HsForAllTelescope a -> HsForAllTelescope a +reparenHsForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) +reparenHsForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs) +reparenHsForAllTelescope v@XHsForAllTelescope{} = v + +-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') +reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n +reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) +reparenTyVar v@XTyVarBndr{} = v + +-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') +reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a +reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d +reparenConDeclField c@XConDeclField{} = c + + +------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- -unL :: Located a -> a +unL :: GenLocated l a -> a unL (L _ x) = x - -reL :: a -> Located a +reL :: a -> GenLocated l a reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b) +mapMA f (L al a) = L (locA al) <$> f a + ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- -instance NamedThing (TyClDecl Name) where +instance NamedThing (TyClDecl GhcRn) where getName = tcdName ------------------------------------------------------------------------------- @@ -163,20 +463,19 @@ children :: a -> [Name] -instance Parent (ConDecl Name) where +instance Parent (ConDecl GhcRn) where children con = - case getConDetails con of - RecCon fields -> map (selectorFieldOcc . unL) $ - concatMap (cd_fld_names . unL) (unL fields) - _ -> [] + case getRecConArgs_maybe con of + Nothing -> [] + Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) -instance Parent (TyClDecl Name) where +instance Parent (TyClDecl GhcRn) where children d - | isDataDecl d = map unL $ concatMap (getConNames . unL) - $ (dd_cons . tcdDataDefn) $ d + | isDataDecl d = map unLoc $ concatMap (toList . getConNames . unLoc) + $ (dd_cons . tcdDataDefn) d | isClassDecl d = - map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + map (unLoc . fdLName . unLoc) (tcdATs d) ++ + [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -185,26 +484,26 @@ family = getName &&& children -familyConDecl :: ConDecl Name -> [(Name, [Name])] -familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) +familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] +familyConDecl d = zip (toList $ unLoc <$> getConNames d) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. -families :: TyClDecl Name -> [(Name, [Name])] +families :: TyClDecl GhcRn -> [(Name, [Name])] families d - | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) + | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] -- | A mapping from child to parent -parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap :: TyClDecl GhcRn -> [(Name, Name)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration -parents :: Name -> HsDecl Name -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents :: Name -> HsDecl GhcRn -> [Name] +parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] @@ -220,28 +519,259 @@ return () --- | A variant of 'gbracket' where the return value from the first computation --- is not required. -gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c -gbracket_ before_ after thing = gbracket before_ (const after) (const thing) +------------------------------------------------------------------------------- +-- * DynFlags +------------------------------------------------------------------------------- --- Extract the minimal complete definition of a Name, if one exists -minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) -minimalDef n = do - mty <- lookupGlobalName n - case mty of - Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c - _ -> return Nothing +-- TODO: use `setOutputDir` from GHC +setOutputDir :: FilePath -> DynFlags -> DynFlags +setOutputDir dir dynFlags = + dynFlags { objectDir = Just dir + , hiDir = Just dir + , hieDir = Just dir + , stubDir = Just dir + , includePaths = addGlobalInclude (includePaths dynFlags) [dir] + , dumpDir = Just dir + } ------------------------------------------------------------------------------- --- * DynFlags +-- * 'StringBuffer' and 'ByteString' ------------------------------------------------------------------------------- +-- We get away with a bunch of these functions because 'StringBuffer' and +-- 'ByteString' have almost exactly the same structure. +-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really +-- relies on the internals of both 'ByteString' and 'StringBuffer'. +-- +-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood) +stringBufferFromByteString :: ByteString -> StringBuffer +stringBufferFromByteString bs = + let BS.PS fp off len = bs <> BS.pack [0,0,0] + in S.StringBuffer { S.buf = fp, S.len = len - 3, S.cur = off } -setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags -setObjectDir f d = d{ objectDir = Just f} -setHiDir f d = d{ hiDir = Just f} -setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. -setOutputDir f = setObjectDir f . setHiDir f . setStubDir f +-- | Take the first @n@ /bytes/ of the 'StringBuffer' and put them in a +-- 'ByteString'. +-- +-- /O(1)/ +takeStringBuffer :: Int -> StringBuffer -> ByteString +takeStringBuffer !n (S.StringBuffer fp _ cur) = BS.PS fp cur n + +-- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second +-- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use +-- separate buffers.** +-- +-- /O(1)/ +splitStringBuffer :: StringBuffer -> StringBuffer -> ByteString +splitStringBuffer buf1 buf2 = takeStringBuffer n buf1 + where n = S.byteDiff buf1 buf2 + +-- | Split the 'StringBuffer' at the next newline (or the end of the buffer). +-- Also: initial position is passed in and the updated position is returned. +-- +-- /O(n)/ (but /O(1)/ space) +spanLine :: RealSrcLoc -> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer) +spanLine !loc !buf = go loc buf + where + + go !l !b + | not (S.atEnd b) + = case S.nextChar b of + ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b') + (c, b') -> go (advanceSrcLoc l c) b' + | otherwise + = (splitStringBuffer buf b, advanceSrcLoc l '\n', b) + +-- | Given a start position and a buffer with that start position, split the +-- buffer at an end position. +-- +-- /O(n)/ (but /O(1)/ space) +spanPosition :: RealSrcLoc -- ^ start of buffeer + -> RealSrcLoc -- ^ position until which to take + -> StringBuffer -- ^ buffer from which to take + -> (ByteString, StringBuffer) +spanPosition !start !end !buf = go start buf + where + + go !l !b + | l < end + , not (S.atEnd b) + , (c, b') <- S.nextChar b + = go (advanceSrcLoc l c) b' + | otherwise + = (splitStringBuffer buf b, b) + +-- | Try to parse a line of CPP from the from of the buffer. A \"line\" of CPP +-- consists of +-- +-- * at most 10 whitespace characters, including at least one newline +-- * a @#@ character +-- * keep parsing lines until you find a line not ending in @\\@. +-- +-- This is chock full of heuristics about what a line of CPP is. +-- +-- /O(n)/ (but /O(1)/ space) +tryCppLine :: RealSrcLoc -> StringBuffer -> Maybe (ByteString, RealSrcLoc, StringBuffer) +tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf + where + + -- Keep consuming space characters until we hit either a @#@ or something + -- else. If we hit a @#@, start parsing CPP + spanSpace !seenNl !l !b + | S.atEnd b + = Nothing + | otherwise + = case S.nextChar b of + ('#' , b') | not (S.atEnd b') + , ('-', b'') <- S.nextChar b' + , ('}', _) <- S.nextChar b'' + -> Nothing -- Edge case exception for @#-}@ + | seenNl + -> Just (spanCppLine (advanceSrcLoc l '#') b') -- parse CPP + | otherwise + -> Nothing -- We didn't see a newline, so this can't be CPP! + + (c , b') | isSpace c -> spanSpace (seenNl || c == '\n') + (advanceSrcLoc l c) b' + | otherwise -> Nothing + + -- Consume a CPP line to its "end" (basically the first line that ends not + -- with a @\@ character) + spanCppLine !l !b + | S.atEnd b + = (splitStringBuffer buf b, l, b) + | otherwise + = case S.nextChar b of + ('\\', b') | not (S.atEnd b') + , ('\n', b'') <- S.nextChar b' + -> spanCppLine (advanceSrcLoc (advanceSrcLoc l '\\') '\n') b'' + + ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b') + + (c , b') -> spanCppLine (advanceSrcLoc l c) b' + +------------------------------------------------------------------------------- +-- * Names in a 'Type' +------------------------------------------------------------------------------- + +-- | Given a 'Type', return a set of 'Name's coming from the 'TyCon's within +-- the type. +typeNames :: Type -> Set.Set Name +typeNames ty = go ty Set.empty + where + go :: Type -> Set.Set Name -> Set.Set Name + go t acc = + case t of + TyVarTy {} -> acc + AppTy t1 t2 -> go t2 $ go t1 acc + FunTy _ _ t1 t2 -> go t2 $ go t1 acc + TyConApp tcon args -> foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args + ForAllTy bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc + LitTy _ -> acc + CastTy t' _ -> go t' acc + CoercionTy {} -> acc + +------------------------------------------------------------------------------- +-- * Free variables of a 'Type' +------------------------------------------------------------------------------- + +-- | Get free type variables in a 'Type' in their order of appearance. +-- See [Ordering of implicit variables]. +orderedFVs + :: VarSet -- ^ free variables to ignore + -> [Type] -- ^ types to traverse (in order) looking for free variables + -> [TyVar] -- ^ free type variables, in the order they appear in +orderedFVs vs tys = + reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet) + + +-- See the "Free variables of types and coercions" section in 'TyCoRep', or +-- check out Note [Free variables of types]. The functions in this section +-- don't output type variables in the order they first appear in in the 'Type'. +-- +-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type +-- of 'const :: a -> b -> a': +-- +-- >>> import GHC.Types.Name +-- >>> import TyCoRep +-- >>> import GHC.Builtin.Types.Prim +-- >>> import GHC.Types.Var +-- >>> a = TyVarTy alphaTyVar +-- >>> b = TyVarTy betaTyVar +-- >>> constTy = mkFunTys [a, b] a +-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy) +-- ["b","a"] +-- +-- However, we want to reuse the very optimized traversal machinery there, so +-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`. +-- All these do differently is traverse in a different order and ignore +-- coercion variables. + +-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfType' :: Type -> FV +tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c +tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c +tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c +tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c +tyCoFVsOfType' (FunTy _ w arg res) a b c = (tyCoFVsOfType' w `unionFV` + tyCoFVsOfType' res `unionFV` + tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c + +-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfTypes' :: [Type] -> FV +tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc +tyCoFVsOfTypes' [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of +-- appearance. +tyCoFVsBndr' :: TyVarBinder -> FV -> FV +tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv) + + +------------------------------------------------------------------------------- +-- * Defaulting RuntimeRep variables +------------------------------------------------------------------------------- + +-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to +-- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such +-- function working over `IfaceType`'s. +defaultRuntimeRepVars :: Type -> Type +defaultRuntimeRepVars = go emptyVarEnv + where + go :: TyVarEnv () -> Type -> Type + go subs (ForAllTy (Bndr var flg) ty) + | isRuntimeRepVar var + , isInvisibleForAllTyFlag flg + = let subs' = extendVarEnv subs var () + in go subs' ty + | otherwise + = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg) + (go subs ty) + + go subs (TyVarTy tv) + | tv `elemVarEnv` subs + = liftedRepTy + | otherwise + = TyVarTy (updateTyVarKind (go subs) tv) + + go subs (TyConApp tc tc_args) + = TyConApp tc (map (go subs) tc_args) + + go subs (FunTy af w arg res) + = FunTy af (go subs w) (go subs arg) (go subs res) + + go subs (AppTy t u) + = AppTy (go subs t) (go subs u) + + go subs (CastTy x co) + = CastTy (go subs x) co + + go _ ty@(LitTy {}) = ty + go _ ty@(CoercionTy {}) = ty + +fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI +fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -28,35 +33,48 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface ( - processModules + plugin + , processModules ) where -import Haddock.GhcUtils -import Haddock.InterfaceFile -import Haddock.Interface.Create -import Haddock.Interface.AttachInstances -import Haddock.Interface.Rename +import Haddock.GhcUtils (moduleString, pretty) +import Haddock.Interface.AttachInstances (attachInstances) +import Haddock.Interface.Create (createInterface1) +import Haddock.Interface.Rename (renameInterface) +import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity) import Haddock.Types -import Haddock.Utils +import Haddock.Utils (Verbosity (..), normal, out, verbose) -import Control.Monad -import Data.List -import qualified Data.Map as Map +import Control.Monad (unless, when) +import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef) +import Data.List (foldl', isPrefixOf) +import Data.Maybe (mapMaybe) +import Data.Traversable (for) +import Text.Printf (printf) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Distribution.Verbosity -import System.Directory -import System.FilePath -import Text.Printf -import Digraph -import DynFlags hiding (verbosity) -import Exception import GHC hiding (verbosity) -import HscTypes -import FastString (unpackFS) +import GHC.Data.Graph.Directed +import GHC.Driver.Env +import GHC.Driver.Monad (modifySession, withTimingM) +import GHC.Driver.Session hiding (verbosity) +import GHC.HsToCore.Docs (getMainDeclBinder) +import GHC.Plugins +import GHC.Tc.Types (TcGblEnv (..), TcM) +import GHC.Tc.Utils.Env (tcLookupGlobal) +import GHC.Tc.Utils.Monad (getTopEnv) +import GHC.Unit.Module.Graph +import GHC.Utils.Error (withTiming) +#if defined(mingw32_HOST_OS) +import System.IO +import GHC.IO.Encoding.CodePage (mkLocaleEncoding) +import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) +#endif + -- | Create 'Interface's and a link environment by typechecking the list of -- modules using the GHC API and processing the resulting syntax trees. processModules @@ -68,144 +86,324 @@ -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming -- environment processModules verbosity modules flags extIfaces = do +#if defined(mingw32_HOST_OS) + -- Avoid internal error: : hPutChar: invalid argument (invalid character)' non UTF-8 Windows + liftIO $ hSetEncoding stdout $ mkLocaleEncoding TransliterateCodingFailure + liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure +#endif + dflags <- getDynFlags + out verbosity verbose "Creating interfaces..." - let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces - , iface <- ifInstalledIfaces ext ] - interfaces <- createIfaces0 verbosity modules flags instIfaceMap + + -- Map from a module to a corresponding installed interface + let instIfaceMap :: InstIfaceMap + instIfaceMap = Map.fromList + [ (instMod iface, iface) + | ext <- extIfaces + , iface <- ifInstalledIfaces ext + ] + + (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap + let exportedNames = Set.unions $ map (Set.fromList . ifaceExports) $ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces mods = Set.fromList $ map ifaceMod interfaces + out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap + interfaces' <- {-# SCC attachInstances #-} + withTimingM "attachInstances" (const ()) $ do + attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..." -- Combine the link envs of the external packages into one let extLinks = Map.unions (map ifLinkEnv extIfaces) - homeLinks = buildHomeLinks interfaces -- Build the environment for the home - -- package + homeLinks = buildHomeLinks interfaces' -- Build the environment for the home + -- package links = homeLinks `Map.union` extLinks out verbosity verbose "Renaming interfaces..." + let warnings = Flag_NoWarnings `notElem` flags - dflags <- getDynFlags - let (interfaces'', msgs) = - runWriter $ mapM (renameInterface dflags links warnings) interfaces' - liftIO $ mapM_ putStrLn msgs + ignoredSymbolSet = ignoredSymbols flags - return (interfaces'', homeLinks) + interfaces'' <- + withTimingM "renameAllInterfaces" (const ()) $ + for interfaces' $ \i -> do + withTimingM ("renameInterface: " <+> pprModuleName (moduleName (ifaceMod i))) (const ()) $ + renameInterface dflags ignoredSymbolSet links warnings (Flag_Hoogle `elem` flags) i + return (interfaces'', homeLinks) -------------------------------------------------------------------------------- -- * Module typechecking and Interface creation -------------------------------------------------------------------------------- +createIfaces + :: Verbosity + -- ^ Verbosity requested by the caller + -> [String] + -- ^ List of modules provided as arguments to Haddock (still in FilePath + -- format) + -> [Flag] + -- ^ Command line flags which Hadddock was invoked with + -> InstIfaceMap + -- ^ Map from module to corresponding installed interface file + -> Ghc ([Interface], ModuleSet) + -- ^ Resulting interfaces +createIfaces verbosity modules flags instIfaceMap = do + -- Initialize the IORefs for the interface map and the module set + (ifaceMapRef, moduleSetRef) <- liftIO $ do + m <- newIORef Map.empty + s <- newIORef emptyModuleSet + return (m, s) -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] -createIfaces0 verbosity modules flags instIfaceMap = - -- Output dir needs to be set before calling depanal since depanal uses it to - -- compute output file names that are stored in the DynFlags of the - -- resulting ModSummaries. - (if useTempDir then withTempOutputDir else id) $ do - modGraph <- depAnalysis - if needsTemplateHaskell modGraph then do - modGraph' <- enableCompilation modGraph - createIfaces verbosity flags instIfaceMap modGraph' - else - createIfaces verbosity flags instIfaceMap modGraph + let + haddockPlugin = plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef - where - useTempDir :: Bool - useTempDir = Flag_NoTmpCompDir `notElem` flags + installHaddockPlugin :: HscEnv -> HscEnv + installHaddockPlugin hsc_env = + let + old_plugins = hsc_plugins hsc_env + new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins } + hsc_env' = hsc_env { hsc_plugins = new_plugins } + in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env' + -- Note that we would rather use withTempSession but as long as we + -- have the separate attachInstances step we need to keep the session + -- alive to be able to find all the instances. + modifySession installHaddockPlugin - withTempOutputDir :: Ghc a -> Ghc a - withTempOutputDir action = do - tmp <- liftIO getTemporaryDirectory - x <- liftIO getProcessID - let dir = tmp ".haddock-" ++ show x - modifySessionDynFlags (setOutputDir dir) - withTempDir dir action + targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules + setTargets targets + loadOk <- withTimingM "load" (const ()) $ + {-# SCC load #-} GHC.load LoadAllTargets - depAnalysis :: Ghc ModuleGraph - depAnalysis = do - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - depanal [] False + case loadOk of + Failed -> + throwE "Cannot typecheck modules" + Succeeded -> do + modGraph <- GHC.getModuleGraph + (ifaceMap, moduleSet) <- liftIO $ do + m <- atomicModifyIORef' ifaceMapRef (Map.empty,) + s <- atomicModifyIORef' moduleSetRef (Set.empty,) + return (m, s) - enableCompilation :: ModuleGraph -> Ghc ModuleGraph - enableCompilation modGraph = do - let enableComp d = let platform = targetPlatform d - in d { hscTarget = defaultObjectTarget platform } - modifySessionDynFlags enableComp - -- We need to update the DynFlags of the ModSummaries as well. - let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } - let modGraph' = map upd modGraph - return modGraph' + let + -- We topologically sort the module graph including boot files, + -- so it should be acylic (hopefully we failed much earlier if this is not the case) + -- We then filter out boot modules from the resultant topological sort + -- + -- We do it this way to make 'buildHomeLinks' a bit more stable + -- 'buildHomeLinks' depends on the topological order of its input in order + -- to construct its result. In particular, modules closer to the bottom of + -- the dependency chain are to be prefered for link destinations. + -- + -- If there are cycles in the graph, then this order is indeterminate + -- (the nodes in the cycle can be ordered in any way). + -- While 'topSortModuleGraph' does guarantee stability for equivalent + -- module graphs, seemingly small changes in the ModuleGraph can have + -- big impacts on the `LinkEnv` constructed. + -- + -- For example, suppose + -- G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import). + -- + -- Then suppose C.hs is changed to have a cyclic dependency on A + -- + -- G2 = A.hs -> B.hs -> C.hs -> A.hs-boot + -- + -- For G1, `C.hs` is preferred for link destinations. However, for G2, + -- the topologically sorted order not taking into account boot files (so + -- C -> A) is completely indeterminate. + -- Using boot files to resolve cycles, we end up with the original order + -- [C, B, A] (in decreasing order of preference for links) + -- + -- This exact case came up in testing for the 'base' package, where there + -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't + -- include 'Prelude' on non-windows platforms. This lead to drastically different + -- LinkEnv's (and failing haddockHtmlTests) across the platforms + -- + -- In effect, for haddock users this behaviour (using boot files to eliminate cycles) + -- means that {-# SOURCE #-} imports no longer count towards re-ordering + -- the preference of modules for linking. + -- + -- i.e. if module A imports B, then B is preferred over A, + -- but if module A {-# SOURCE #-} imports B, then we can't say the same. + -- + go :: SCC ModuleGraphNode -> Maybe Module + go (AcyclicSCC (ModuleNode _ ms)) + | NotBoot <- isBootSummary ms = Just $ ms_mod ms + | otherwise = Nothing + go (AcyclicSCC _) = Nothing + go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files" + ifaces :: [Interface] + ifaces = + [ Map.findWithDefault + (error "haddock:iface") + m + ifaceMap + | m <- mapMaybe go $ topSortModuleGraph False modGraph Nothing + ] -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] -createIfaces verbosity flags instIfaceMap mods = do - let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing - out verbosity normal "Haddock coverage:" - (ifaces, _) <- foldM f ([], Map.empty) sortedMods - return (reverse ifaces) - where - f (ifaces, ifaceMap) modSummary = do - x <- processModule verbosity modSummary flags ifaceMap instIfaceMap - return $ case x of - Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) - Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. + return (ifaces, moduleSet) -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) -processModule verbosity modsum flags modMap instIfaceMap = do - out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- loadModule =<< typecheckModule =<< parseModule modsum - if not $ isBootSummary modsum then do - out verbosity verbose "Creating interface..." - (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap - liftIO $ mapM_ putStrLn msg - dflags <- getDynFlags - let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int - modString = moduleString (ifaceMod interface) - coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString - header = case ifaceDoc interface of - Documentation Nothing _ -> False - _ -> True - undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n - , expItemMbDoc = (Documentation Nothing _, _) - } <- ifaceExportItems interface ] - where - formatName :: SrcSpan -> HsDecl Name -> String - formatName loc n = p (getMainDeclBinder n) ++ case loc of - RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" - _ -> "" +-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock +-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to +-- parallelize the compilation process. +plugin + :: Verbosity + -- ^ Verbosity requested by the Haddock caller + -> [Flag] + -- ^ Command line flags which Hadddock was invoked with + -> InstIfaceMap + -- ^ Map from module to corresponding installed interface file + -> IORef IfaceMap + -- ^ The 'IORef' to write the interface map to + -> IORef ModuleSet + -- ^ The 'IORef' to write the module set to + -> StaticPlugin -- the plugin to install with GHC +plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef = + let + processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM () + processTypeCheckedResult mod_summary tc_gbl_env + -- Don't do anything for hs-boot modules + | IsBoot <- isBootSummary mod_summary = + pure () + | otherwise = do + hsc_env <- getTopEnv + ifaces <- liftIO $ readIORef ifaceMapRef - p [] = "" - p (x:_) = let n = pretty dflags x - ms = modString ++ "." - in if ms `isPrefixOf` n - then drop (length ms) n - else n + (iface, modules) <- + withTiming (hsc_logger hsc_env) "processModule1" (const ()) $ + processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env + liftIO $ do + atomicModifyIORef' ifaceMapRef $ \xs -> + (Map.insert (ms_mod mod_summary) iface xs, ()) + + atomicModifyIORef' moduleSetRef $ \xs -> + (modules `unionModuleSet` xs, ()) + in + StaticPlugin + { + spPlugin = PluginWithArgs + { + paPlugin = defaultPlugin + { + renamedResultAction = keepRenamedSource + , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do + processTypeCheckedResult mod_summary tc_gbl_env + pure tc_gbl_env + } + , paArguments = [] + } + } + +processModule1 + :: Verbosity + -- ^ Verbosity requested by the Haddock caller + -> [Flag] + -- ^ Command line flags which Hadddock was invoked with + -> IfaceMap + -- ^ Map from module to corresponding interface, for the modules we have + -- already processed + -> InstIfaceMap + -- ^ Map from module to corresponding installed interface file + -> HscEnv + -> ModSummary + -> TcGblEnv + -> TcM (Interface, ModuleSet) +processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do + out verbosity verbose "Creating interface..." + + let + TcGblEnv { tcg_rdr_env } = tc_gbl_env + + unit_state = hsc_units hsc_env + + !interface <- do + logger <- getLogger + {-# SCC createInterface #-} + withTiming logger "createInterface" (const ()) $ + runIfM (fmap Just . tcLookupGlobal) $ + createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces + + -- We need to keep track of which modules were somehow in scope so that when + -- Haddock later looks for instances, it also looks in these modules too. + -- + -- See https://github.com/haskell/haddock/issues/469. + let + mods :: ModuleSet + !mods = mkModuleSet + [ nameModule name + | gre <- globalRdrEnvElts tcg_rdr_env + , let name = greMangledName gre + , nameIsFromExternalPackage (hsc_home_unit hsc_env) name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre -- In scope unqualified + ] + + dflags <- getDynFlags + + let + (haddockable, haddocked) = + ifaceHaddockCoverage interface + + percentage :: Int + percentage = div (haddocked * 100) haddockable + + modString :: String + modString = moduleString (ifaceMod interface) + + coverageMsg :: String + coverageMsg = + printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString + + header :: Bool + header = case ifaceDoc interface of + Documentation Nothing _ -> False + _ -> True + + undocumentedExports :: [String] + undocumentedExports = + [ formatName (locA s) n + | ExportDecl ExportD + { expDDecl = L s n + , expDMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface + ] + where + formatName :: SrcSpan -> HsDecl GhcRn -> String + formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of + RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ + show (srcSpanStartLine rss) ++ ")" + _ -> "" + + p :: Outputable a => [a] -> String + p [] = "" + p (x:_) = let n = pretty dflags x + ms = modString ++ "." + in if ms `isPrefixOf` n + then drop (length ms) n + else n + + when (OptHide `notElem` ifaceOptions interface) $ do out verbosity normal coverageMsg when (Flag_NoPrintMissingDocs `notElem` flags && not (null undocumentedExports && header)) $ do out verbosity normal " Missing documentation for:" unless header $ out verbosity normal " Module header" mapM_ (out verbosity normal . (" " ++)) undocumentedExports - interface' <- liftIO $ evaluate interface - return (Just interface') - else - return Nothing + pure (interface, mods) + -------------------------------------------------------------------------------- -- * Building of cross-linking environment -------------------------------------------------------------------------------- @@ -220,25 +418,17 @@ -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. buildHomeLinks :: [Interface] -> LinkEnv -buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) +buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces) where upd old_env iface - | OptHide `elem` ifaceOptions iface = old_env + | OptHide `elem` ifaceOptions iface = + old_env | OptNotHome `elem` ifaceOptions iface = - foldl' keep_old old_env exported_names - | otherwise = foldl' keep_new old_env exported_names + foldl' keep_old old_env exported_names + | otherwise = + foldl' keep_new old_env exported_names where - exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface) + exported_names = ifaceVisibleExports iface ++ map haddockClsInstName (ifaceInstances iface) mdl = ifaceMod iface keep_old env n = Map.insertWith (\_ old -> old) n mdl env keep_new env n = Map.insert n mdl env - - --------------------------------------------------------------------------------- --- * Utils --------------------------------------------------------------------------------- - - -withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a -withTempDir dir = gbracket_ (liftIO $ createDirectory dir) - (liftIO $ removeDirectoryRecursive dir) diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances @@ -11,113 +14,168 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -module Haddock.Interface.AttachInstances (attachInstances) where +module Haddock.Interface.AttachInstances (attachInstances, instHead) where -import Haddock.Types import Haddock.Convert -import Haddock.GhcUtils +import Haddock.GhcUtils (typeNames) +import Haddock.Types +import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) -import Data.List +import Control.DeepSeq (force) +import Data.Foldable (foldl') +import Data.List (sortBy) import Data.Ord (comparing) -import Data.Function (on) -import Data.Maybe ( maybeToList, mapMaybe ) -import qualified Data.Map as Map +import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Class -import DynFlags -import CoreSyn (isOrphan) -import ErrUtils -import FamInstEnv -import FastString +import GHC.Data.FastString (unpackFS) +import GHC.Core.Class +import GHC.Core.FamInstEnv import GHC -import GhcMonad (withSession) -import InstEnv -import MonadUtils (liftIO) -import Name -import Outputable (text, sep, (<+>)) -import PrelNames -import SrcLoc -import TcRnDriver (tcRnGetInfo) -import TyCon -import TyCoRep -import TysPrim( funTyCon ) -import Var hiding (varName) -#define FSLIT(x) (mkFastString# (x#)) +import GHC.Core.InstEnv +import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Utils.Outputable (text, sep, (<+>)) +import GHC.Types.SrcLoc +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Builtin.Types( unrestrictedFunTyConName ) +import GHC.Types.Var hiding (varName) +import GHC.HsToCore.Docs type ExportedNames = Set.Set Name type Modules = Set.Set Module type ExportInfo = (ExportedNames, Modules) -- Also attaches fixities -attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] -attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces +attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface] +attachInstances expInfo ifaces instIfaceMap mods = do + (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods' + mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where + mods' = Just (moduleSetElts mods) + -- TODO: take an IfaceMap as input ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] - attach iface = do - newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) + attach index iface = do + + let getInstDoc = findInstDoc iface ifaceMap instIfaceMap + getFixity = findFixity iface ifaceMap instIfaceMap + + newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity) (ifaceExportItems iface) - let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) + let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface) return $ iface { ifaceExportItems = newItems , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] -attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = - [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) - | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys +attachOrphanInstances + :: ExportInfo + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> [HaddockClsInst] -- ^ a list of instances + -> [DocInstance GhcRn] +attachOrphanInstances expInfo getInstDoc cls_instances = + [ (synified, getInstDoc instName, (L (getSrcSpan instName) instName), Nothing) + | let is = + [ ( haddockClsInstHead i + , haddockClsInstSynified i + , haddockClsInstName i + , haddockClsInstClsName i + , haddockClsInstTyNames i + ) + | i <- cls_instances, haddockClsInstIsOrphan i + ] + , (_, synified, instName, cls, tyNames) <- sortBy (comparing $ (\(ih,_,_,_,_) -> ih)) is + , not $ isInstanceHidden expInfo cls tyNames ] -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem Name - -> Ghc (ExportItem Name) -attachToExportItem expInfo iface ifaceMap instIfaceMap export = +attachToExportItem + :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of) + -> ExportInfo + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) +attachToExportItem index expInfo getInstDoc getFixity export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do - mb_info <- getAllInfo (tcdName d) - insts <- case mb_info of - Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) - | i <- sortBy (comparing instFam) fam_instances - , let n = getName i - , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap - , not $ isNameHidden expInfo (fi_fam i) - , not $ any (isTypeHidden expInfo) (fi_tys i) - , let opaque = isTypeHidden expInfo (fi_rhs i) - ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) - | let is = [ (instanceSig i, getName i) | i <- cls_instances ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys - ] + ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do + insts <- + let mb_instances = lookupNameEnv index (tcdName d) + cls_instances = maybeToList mb_instances >>= fst + fam_instances = maybeToList mb_instances >>= snd + fam_insts = [ ( synFamInst + , getInstDoc n + , spanNameE n synFamInst (L (locA eSpan) (tcdName d)) + , mb_mdl + ) + | i <- sortBy (comparing instFam) fam_instances + , let n = getName i + , not $ isNameHidden expInfo (fi_fam i) + , not $ any (isTypeHidden expInfo) (fi_tys i) + , let opaque = isTypeHidden expInfo (fi_rhs i) + , let synFamInst = synifyFamInst i opaque + , let !mb_mdl = force $ nameModule_maybe n + ] + cls_insts = [ ( synClsInst + , getInstDoc n + , spanName n synClsInst (L (locA eSpan) (tcdName d)) + , mb_mdl + ) + | let is = [ (instanceSig i, getName i) | i <- cls_instances ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden + expInfo + (getName cls) + (foldl' (\acc t -> acc `Set.union` typeNames t) Set.empty tys) + , let synClsInst = synifyInstHead i + , let !mb_mdl = force $ nameModule_maybe n + ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] - in do - dfs <- getDynFlags - let mkBug = (text "haddock-bug:" <+>) . text - liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) - return $ cls_insts ++ cleanFamInsts - Nothing -> return [] - return $ e { expItemInstances = insts } + cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ] + in do + let mkBug = (text "haddock-bug:" <+>) . text + putMsgM (sep $ map mkBug famInstErrs) + return $ cls_insts ++ cleanFamInsts + return $ ExportDecl e { expDInstances = insts } e -> return e where - attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = - nubBy ((==) `on` fst) $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder d - , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap] - , n' <- n : subs - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] - ] } + attachFixities + ( ExportDecl + ( e@ExportD + { expDDecl = L _ d + , expDPats = patsyns + , expDSubDocs = subDocs + } + ) + ) + = ExportDecl e + { expDFixities = fixities + } + where + fixities :: [(Name, Fixity)] + !fixities = force . Map.toList $ foldl' f Map.empty all_names + f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity + f !fs n = Map.alter (<|> getFixity n) n fs + + patsyn_names :: [Name] + patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns + + all_names :: [Name] + all_names = + getMainDeclBinder emptyOccEnv d + ++ map fst subDocs + ++ patsyn_names + attachFixities e = e + -- spanName: attach the location to the name that is the same file as the instance location spanName s (InstHead { ihdClsName = clsn }) (L instL instn) = let s1 = getSrcSpan s @@ -131,60 +189,48 @@ let L l r = spanName s ok linst in L l (Right r) - -instLookup :: (InstalledInterface -> Map.Map Name a) -> Name - -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a -instLookup f name iface ifaceMap instIfaceMap = - case Map.lookup name (f $ toInstalledIface iface) of - res@(Just _) -> res - Nothing -> do - let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap - iface' <- Map.lookup (nameModule name) ifaceMaps - Map.lookup name (f iface') +-- | Lookup the doc associated with a certain instance +findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name) +findInstDoc iface ifaceMap instIfaceMap = \name -> + (Map.lookup name . ifaceDocMap $ iface) <|> + (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|> + (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap) --- | Like GHC's getInfo but doesn't cut things out depending on the --- interative context, which we don't set sufficiently anyway. -getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -getAllInfo name = withSession $ \hsc_env -> do - (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name - return r +-- | Lookup the fixity associated with a certain name +findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity +findFixity iface ifaceMap instIfaceMap = \name -> + (Map.lookup name . ifaceFixMap $ iface) <|> + (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|> + (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap) -------------------------------------------------------------------------------- -- Collecting and sorting instances -------------------------------------------------------------------------------- - --- | Simplified type for sorting types, ignoring qualification (not visible --- in Haddock output) and unifying special tycons with normal ones. --- For the benefit of the user (looks nice and predictable) and the --- tests (which prefer output to be deterministic). -data SimpleType = SimpleType Name [SimpleType] - | SimpleTyLit TyLit - deriving (Eq,Ord) - - -instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) +instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType]) instHead (_, _, cls, args) - = (map argCount args, className cls, map simplify args) + = (map argCount args, SName (className cls), map simplify args) argCount :: Type -> Int -argCount (AppTy t _) = argCount t + 1 +argCount (AppTy t _) = argCount t + 1 argCount (TyConApp _ ts) = length ts -argCount (ForAllTy (Anon _) _ ) = 2 -argCount (ForAllTy _ t) = argCount t -argCount (CastTy t _) = argCount t +argCount (FunTy _ _ _ _) = 2 +argCount (ForAllTy _ t) = argCount t +argCount (CastTy t _) = argCount t argCount _ = 0 simplify :: Type -> SimpleType -simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (FunTy _ _ t1 t2) = SimpleType (SName unrestrictedFunTyConName) [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2)) where (SimpleType s ts) = simplify t1 -simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) +simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) [] +simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc)) (mapMaybe simplify_maybe ts) -simplify (LitTy l) = SimpleTyLit l +simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n +simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s) +simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c simplify (CastTy ty _) = simplify ty simplify (CoercionTy _) = error "simplify:Coercion" @@ -193,18 +239,11 @@ simplify_maybe ty = Just (simplify ty) -- Used for sorting -instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) +instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType) instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } - = (map argCount ts, n, map simplify ts, argCount t, simplify t) + = (map argCount ts, SName n, map simplify ts, argCount t, simplify t) -funTyConName :: Name -funTyConName = mkWiredInName gHC_PRIM - (mkOccNameFS tcName FSLIT("(->)")) - funTyConKey - (ATyCon funTyCon) -- Relevant TyCon - BuiltInSyntax - -------------------------------------------------------------------------------- -- Filtering hidden instances -------------------------------------------------------------------------------- @@ -221,29 +260,21 @@ -- | We say that an instance is «hidden» iff its class or any (part) -- of its type(s) is hidden. -isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool -isInstanceHidden expInfo cls tys = +isInstanceHidden :: ExportInfo -> Name -> Set.Set Name -> Bool +isInstanceHidden expInfo cls tyNames = instClassHidden || instTypeHidden where instClassHidden :: Bool - instClassHidden = isNameHidden expInfo $ getName cls + instClassHidden = isNameHidden expInfo cls instTypeHidden :: Bool - instTypeHidden = any (isTypeHidden expInfo) tys + instTypeHidden = any (isNameHidden expInfo) tyNames isTypeHidden :: ExportInfo -> Type -> Bool isTypeHidden expInfo = typeHidden where typeHidden :: Type -> Bool - typeHidden t = - case t of - TyVarTy {} -> False - AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty - LitTy _ -> False - CastTy ty _ -> typeHidden ty - CoercionTy {} -> False + typeHidden t = any nameHidden $ typeNames t nameHidden :: Name -> Bool nameHidden = isNameHidden expInfo diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,900 +1,1276 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} -{-# OPTIONS_GHC -Wwarn #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Interface.Create --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.Create (createInterface) where - -import Documentation.Haddock.Doc (metaDocAppend) -import Haddock.Types -import Haddock.Options -import Haddock.GhcUtils -import Haddock.Utils -import Haddock.Convert -import Haddock.Interface.LexParseRn -import Haddock.Backends.Hyperlinker.Types -import Haddock.Backends.Hyperlinker.Ast as Hyperlinker -import Haddock.Backends.Hyperlinker.Parser as Hyperlinker - -import qualified Data.Map as M -import Data.Map (Map) -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Ord -import Control.Applicative -import Control.Arrow (second) -import Control.DeepSeq -import Control.Monad -import Data.Function (on) - -import qualified Packages -import qualified Module -import qualified SrcLoc -import GHC -import HscTypes -import Name -import Bag -import RdrName -import TcRnTypes -import FastString (concatFS) -import BasicTypes ( StringLiteral(..) ) -import qualified Outputable as O -import HsDecls ( getConDetails ) - --- | Use a 'TypecheckedModule' to produce an 'Interface'. --- To do this, we need access to already processed modules in the topological --- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do - - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - L _ hsm = parsedSource tm - !safety = modInfoSafe mi - mdl = ms_mod ms - dflags = ms_hspp_opts ms - !instances = modInfoInstances mi - !fam_instances = md_fam_insts md - !exportedNames = modInfoExports mi - - (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm - - -- The renamed source should always be available to us, but it's best - -- to be on the safe side. - (group_, mayExports, mayDocHeader) <- - case renamedSource tm of - Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, Nothing, Nothing) - Just (x, _, y, z) -> return (x, y, z) - - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - let opts - | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 - | otherwise = opts0 - - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader - - let declsWithDocs = topDecls group_ - fixMap = mkFixMap group_ - (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances - ++ map getName fam_instances - -- Locations of all TH splices - splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] - - 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)) - - exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls - maps fixMap splices exports instIfaceMap dflags - - let !visibleNames = mkVisibleNames maps exportItems opts - - -- Measure haddock documentation coverage. - let prunedExportItems0 = pruneExportItems exportItems - !haddockable = 1 + length exportItems -- module + exports - !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - !coverage = (haddockable, haddocked) - - -- Prune the export list to just those declarations that have - -- documentation, if the 'prune' option is on. - let prunedExportItems' - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems - !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - - let !aliases = - mkAliasMap dflags $ tm_renamed_source tm - modWarn = moduleWarning dflags gre warnings - - tokenizedSrc <- mkMaybeTokenizedSrc flags tm - - return $! Interface { - ifaceMod = mdl - , 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 - , ifaceOrphanInstances = [] -- Filled in `attachInstances` - , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = tokenizedSrc - } - -mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap dflags mRenamedSource = - case mRenamedSource of - Nothing -> M.empty - Just (_,impDecls,_,_) -> - M.fromList $ - mapMaybe (\(SrcLoc.L _ impDecl) -> do - alias <- ideclAs impDecl - return $ - (lookupModuleDyn dflags - (fmap Module.fsToUnitId $ - fmap sl_fs $ ideclPkgQual impDecl) - (case ideclName impDecl of SrcLoc.L _ name -> name), - alias)) - impDecls - --- similar to GHC.lookupModule -lookupModuleDyn :: - DynFlags -> Maybe UnitId -> ModuleName -> Module -lookupModuleDyn _ (Just pkgId) mdlName = - Module.mkModule pkgId mdlName -lookupModuleDyn dflags Nothing mdlName = - case Packages.lookupModuleInAllPackages dflags mdlName of - (m,_):_ -> m - [] -> Module.mkModule Module.mainUnitId mdlName - - -------------------------------------------------------------------------------- --- Warnings -------------------------------------------------------------------------------- - -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap -mkWarningMap dflags warnings gre exps = case warnings of - NoWarnings -> M.empty - WarnAll _ -> M.empty - WarnSome ws -> - let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] - in M.fromList $ map (second $ parseWarning dflags gre) ws' - -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) -moduleWarning _ _ NoWarnings = Nothing -moduleWarning _ _ (WarnSome _) = Nothing -moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w - -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name -parseWarning dflags gre w = force $ case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) - where - format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - . processDocString dflags gre $ HsDocString xs - - -------------------------------------------------------------------------------- --- Doc options --- --- Haddock options that are embedded in the source file -------------------------------------------------------------------------------- - - -mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] -mkDocOpts mbOpts flags mdl = do - opts <- case mbOpts of - Just opts -> case words $ replace ',' ' ' opts of - [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] - xs -> liftM catMaybes (mapM parseOption xs) - Nothing -> return [] - hm <- if Flag_HideModule (moduleString mdl) `elem` flags - then return $ OptHide : opts - else return opts - if Flag_ShowExtensions (moduleString mdl) `elem` flags - then return $ OptShowExtensions : hm - else return hm - - -parseOption :: String -> ErrMsgM (Maybe DocOption) -parseOption "hide" = return (Just OptHide) -parseOption "prune" = return (Just OptPrune) -parseOption "ignore-exports" = return (Just OptIgnoreExports) -parseOption "not-home" = return (Just OptNotHome) -parseOption "show-extensions" = return (Just OptShowExtensions) -parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing - - --------------------------------------------------------------------------------- --- Maps --------------------------------------------------------------------------------- - - -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) - --- | Create 'Maps' by looping through the declarations. For each declaration, --- find its names, its subordinates, and its doc strings. Process doc strings --- into 'Doc's. -mkMaps :: DynFlags - -> GlobalRdrEnv - -> [Name] - -> [(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) - where - f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - - f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) - f' = M.fromListWith metaDocAppend . concat - - mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, MDoc Name)] - , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] - , [(Name, [LHsDecl Name])] - ) - mappings (ldecl, docStrs) = - let L l decl = ldecl - declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (MDoc Name), Map Int (MDoc Name)) - declDoc strs m = - let doc' = processDocStrings dflags gre strs - m' = M.map (processDocStringParas dflags gre) m - in (doc', m') - (doc, args) = declDoc docStrs (typeDocs decl) - subs :: [(Name, [HsDocString], Map Int HsDocString)] - subs = subordinates instanceMap decl - (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs - ns = names l decl - subNs = [ n | (n, _, _) <- subs ] - dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] - am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - sm = [ (n, subNs) | n <- ns ] - cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - in seqList ns `seq` - seqList subNs `seq` - doc `seq` - seqList subDocs `seq` - seqList subArgs `seq` - (dm, am, sm, cm) - - instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - - names :: SrcSpan -> HsDecl Name -> [Name] - names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. - where loc = case d of - TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs - _ -> getInstLoc d - names _ decl = getMainDeclBinder decl - --- Note [2]: ------------- --- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. --- That should work for normal user-written instances (from looking at GHC --- sources). We can assume that commented instances are user-written. --- This lets us relate Names (from ClsInsts) to comments (associated --- with InstDecls). - - --------------------------------------------------------------------------------- --- Declarations --------------------------------------------------------------------------------- - - --- | Get all subordinate declarations inside a declaration, and their docs. -subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] -subordinates instMap decl = case decl of - InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = def } <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def - - InstD (DataFamInstD d) -> dataSubs (dfid_defn d) - TyClD d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) - _ -> [] - where - classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] - dataSubs dd = constrs ++ fields - where - cons = map unL $ (dd_cons dd) - constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons, cname <- getConNames c ] - fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map getConDetails cons - , L _ (ConDeclField ns _ doc) <- (unLoc flds) - , L _ n <- ns ] - --- | Extract function argument docs from inside types. -typeDocs :: HsDecl Name -> Map Int HsDocString -typeDocs d = - let docs = go 0 in - case d of - SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) - SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) - ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) - TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) - _ -> M.empty - where - go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) - go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ (L _ doc)) = M.singleton n doc - go _ _ = M.empty - - --- | All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. -classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ - - --- | The top-level declarations of a module that we care about, --- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup - --- | Extract a map of fixity declarations only -mkFixMap :: HsGroup Name -> FixMap -mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig ns f) <- hs_fixds group_, - L _ n <- ns ] - - --- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup Name -> [LHsDecl Name] -ungroup group_ = - mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls hs_instds InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ - where - typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs - typesigs _ = error "expected ValBindsOut" - - valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds - valbinds _ = error "expected ValBindsOut" - - --- | Take a field of declarations from a data structure and create HsDecls --- using the given constructor -mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] - - --- | Sort by source location -sortByLoc :: [Located a] -> [Located a] -sortByLoc = sortBy (comparing getLoc) - - --------------------------------------------------------------------------------- --- Filtering of declarations --- --- We filter out declarations that we don't intend to handle later. --------------------------------------------------------------------------------- - - --- | Filter out declarations that we don't handle in Haddock -filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unL . fst) - where - isHandled (ForD (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True - isHandled (SigD d) = isUserLSig (reL d) - isHandled (ValD _) = True - -- we keep doc declarations to be able to get at named docs - isHandled (DocD _) = True - isHandled _ = False - - --- | Go through all class declarations and filter their sub-declarations -filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x - | x@(L loc d, doc) <- decls ] - where - filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } - filterClass _ = error "expected TyClD" - - --------------------------------------------------------------------------------- --- Collect docs --- --- To be able to attach the right Haddock comment to the right declaration, --- we sort the declarations by their SrcLoc and "collect" the docs for each --- declaration. --------------------------------------------------------------------------------- - - --- | Collect docs and attach them to the right declarations. -collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] -collectDocs = go Nothing [] - where - go Nothing _ [] = [] - go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD (DocCommentNext str)) : ds) - | Nothing <- prev = go Nothing (str:docs) ds - | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds - go Nothing docs (d:ds) = go (Just d) docs ds - go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) - - finished decl docs rest = (decl, reverse docs) : rest - - --- | Build the list of items that will become the documentation, from the --- export list. At this point, the list of ExportItems is in terms of --- original names. --- --- We create the export items even if the module is hidden, since they --- might be useful when creating the export items for other modules. -mkExportItems - :: IfaceMap - -> Module -- this module - -> WarningMap - -> GlobalRdrEnv - -> [Name] -- exported names (orig) - -> [LHsDecl Name] - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> Maybe [IE Name] - -> InstIfaceMap - -> DynFlags - -> ErrMsgGhc [ExportItem Name] -mkExportItems - modMap thisMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) 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 x - lookupExport (IEThingAbs (L _ t)) = declWith t - lookupExport (IEThingAll (L _ t)) = declWith t - lookupExport (IEThingWith (L _ t) _ _ _) = declWith t - lookupExport (IEModuleContents (L _ m)) = - moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = return $ - return . ExportGroup lev "" $ processDocString dflags gre docStr - - lookupExport (IEDoc docStr) = return $ - return . ExportDoc $ processDocStringParas dflags gre docStr - - lookupExport (IEDocNamed str) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= return . \case - Nothing -> [] - Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - - declWith :: Name -> ErrMsgGhc [ ExportItem Name ] - declWith t = - case findDecl t of - ([L l (ValD _)], (doc, _)) -> do - -- Top-level binding without type signature - export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap - return [export] - (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unL decl) - in case () of - _ - -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | t `elem` declATs (unL decl) -> return [] - - -- We should not show a subordinate by itself if any of its - -- parents is also exported. See note [1]. - | t `notElem` declNames, - Just p <- find isExported (parents t $ unL decl) -> - do liftErrMsg $ tell [ - "Warning: " ++ moduleString thisMod ++ ": " ++ - pretty dflags (nameOccName t) ++ " is exported separately but " ++ - "will be documented under " ++ pretty dflags (nameOccName p) ++ - ". Consider exporting it together with its parent(s)" ++ - " for code clarity." ] - return [] - - -- normal case - | otherwise -> case decl of - -- A single signature might refer to many names, but we - -- create an export item for a single name only. So we - -- modify the signature to contain only that single name. - L loc (SigD sig) -> - -- 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_ ] - - L loc (TyClD cl@ClassDecl{}) -> do - mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef - return [ mkExportDecl t - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] - - _ -> return [ mkExportDecl t decl docs_ ] - - -- Declaration from another package - ([], _) -> do - mayDecl <- hiDecl dflags t - case mayDecl of - Nothing -> return [ ExportNoDecl t [] ] - Just decl -> - -- We try to get the subs and docs - -- from the installed .haddock file for that package. - case M.lookup (nameModule t) instIfaceMap of - Nothing -> do - 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_) ] - Just iface -> - return [ mkExportDecl t decl (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' - where - decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False - mdl = nameModule name - subs' = filter (isExported . fst) subs - sub_names = map fst subs' - fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] - - - isExported = (`elem` exportedNames) - - - findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) - findDecl n - | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n warnings docMap argMap subMap) - | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) - | otherwise = ([], (noDocForDecl, [])) - where - m = nameModule n - - -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) -hiDecl dflags t = do - mayTyThing <- liftGhcToErrMsgGhc $ lookupName t - case mayTyThing of - Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] - return Nothing - Just x -> case tyThingToLHsDecl x of - Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing - Right (m, t') -> liftErrMsg (tell $ map bugWarn m) - >> return (Just $ noLoc t') - where - warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> - O.comma O.<+> O.quotes (O.ppr t) O.<+> - O.text "-- Please report this on Haddock issue tracker!" - bugWarn = O.showSDoc dflags . warnLine - --- | This function is called for top-level bindings without type signatures. --- It gets the type signature from GHC and that means it's not going to --- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the --- declaration and use it instead - 'nLoc' here. -hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -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) - where - fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t - fixities = case fixity of - Just f -> [(name, f)] - Nothing -> [] - - --- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap - -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings docMap argMap subMap = - let lookupArgDoc x = M.findWithDefault M.empty x argMap in - let doc = (lookupDoc n, lookupArgDoc n) in - let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in - (doc, subDocs) - where - lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) - - --- | Return all export items produced by an exported module. That is, we're --- interested in the exports produced by \"module B\" in such a scenario: --- --- > module A (module B) where --- > import B (...) hiding (...) --- --- There are three different cases to consider: --- --- 1) B is hidden, in which case we return all its exports that are in scope in A. --- 2) B is visible, but not all its exports are in scope in A, in which case we --- only return those that are. --- 3) B is visible and all its exports are in scope, in which case we return --- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A - -> ModuleName -- ^ The real name of B, the exported module - -> DynFlags -- ^ The flags used when typechecking A - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment used for A - -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the declarations in A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> Maps - -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls - | otherwise = - case M.lookup m ifaceMap of - Just iface - | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) - | otherwise -> return [ ExportModule m ] - - Nothing -> -- We have to try to find it in the installed interfaces - -- (external packages). - case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of - Just iface -> return [ ExportModule (instMod iface) ] - Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty dflags expMod] - return [] - where - m = mkModule unitId expMod - unitId = moduleUnitId thisMod - - --- Note [1]: ------------- --- It is unnecessary to document a subordinate by itself at the top level if --- any of its parents is also documented. Furthermore, if the subordinate is a --- record field or a class method, documenting it under its parent --- indicates its special status. --- --- A user might expect that it should show up separately, so we issue a --- warning. It's a fine opportunity to also tell the user she might want to --- export the subordinate through the parent export item for clarity. --- --- The code removes top-level subordinates also when the parent is exported --- through a 'module' export. I think that is fine. --- --- (For more information, see Trac #69) - - -fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] - -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSig decls) - where - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- - -- We go through the list of declarations and expand type signatures, so - -- that every type signature has exactly one name! - expandSig :: [LHsDecl name] -> [LHsDecl name] - expandSig = foldr f [] - where - f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names - f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names - f x xs = x : xs - - mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) - mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - return . Just . ExportGroup lev "" $ processDocString dflags gre docStr - mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - return . Just . ExportDoc $ processDocStringParas dflags gre docStr - mkExportItem (L l (ValD d)) - | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = - -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) - | otherwise = return Nothing - mkExportItem decl@(L l (InstD d)) - | Just name <- M.lookup (getInstLoc d) instMap = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) - mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do - mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef - expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name - mkExportItem decl@(L l d) - | name:_ <- getMainDeclBinder d = expDecl decl l name - | otherwise = return Nothing - - 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)) - where (doc, subs) = lookupDocs name warnings docMap argMap subMap - - --- | Sometimes the declaration we want to export is not the "main" declaration: --- it might be an individual record selector or a class method. In these --- cases we have to extract the required declaration (and somehow cobble --- together a type signature for it...). -extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name -extractDecl name mdl decl - | name `elem` getMainDeclBinder (unLoc decl) = decl - | otherwise = - case unLoc decl of - TyClD d@ClassDecl {} -> - let matches = [ lsig - | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig - -- Note: exclude `default` declarations (see #505) - , name `elem` sigName lsig - ] - -- TODO: document fixity - in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) - L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) - _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" - O.$$ O.nest 4 (O.ppr d) - O.$$ O.text "Matches:" - O.$$ O.nest 4 (O.ppr matches)) - TyClD d@DataDecl {} -> - let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d)) - InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsIB { hsib_body = tys } - , dfid_defn = defn }) -> - SigD <$> extractRecSel name mdl n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> - let matches = [ d | L _ d <- insts - -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) - , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) - , L _ n <- ns - , selectorFieldOcc n == name - ] - in case matches of - [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) - _ -> error "internal: extractDecl (ClsInstD)" - _ -> error "internal: extractDecl" - -extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] - -> LSig Name -extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" - -extractRecSel nm mdl t tvs (L _ con : rest) = - case getConDetails con of - RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) - _ -> extractRecSel nm mdl t tvs rest - where - matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] - matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds - , L l n <- ns, selectorFieldOcc n == nm ] - data_ty - -- ResTyGADT _ ty <- con_res con = ty - | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs - --- | Keep export items with docs. -pruneExportItems :: [ExportItem Name] -> [ExportItem Name] -pruneExportItems = filter hasDoc - where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d - hasDoc _ = True - - -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts - | OptHide `elem` opts = [] - | otherwise = let ns = concatMap exportName exports - in seqList ns `seq` ns - where - exportName e@ExportDecl {} = name ++ subs - where subs = map fst (expItemSubDocs e) - name = case unLoc $ expItemDecl e of - InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap - decl -> getMainDeclBinder decl - exportName ExportNoDecl {} = [] -- we don't count these as visible, since - -- we don't want links to go to them. - exportName _ = [] - -seqList :: [a] -> () -seqList [] = () -seqList (x : xs) = x `seq` seqList xs - -mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule - -> ErrMsgGhc (Maybe [RichToken]) -mkMaybeTokenizedSrc flags tm - | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of - Just src -> do - tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src - return $ Just tokens - Nothing -> do - liftErrMsg . tell . pure $ concat - [ "Warning: Cannot hyperlink module \"" - , moduleNameString . ms_mod_name $ summary - , "\" because renamed source is not available" - ] - return Nothing - | otherwise = return Nothing - where - summary = pm_mod_summary . tm_parsed_module $ tm - -mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc ms src = - Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc - where - rawSrc = readFile $ msHsFilePath ms - --- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) -findNamedDoc name = search - where - search [] = do - tell ["Cannot find documentation for: $" ++ name] - return Nothing - search (DocD (DocCommentNamed name' doc) : rest) - | name == name' = return (Just doc) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wwarn #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Create +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This module provides a single function 'createInterface', +-- which creates a Haddock 'Interface' from the typechecking +-- results 'TypecheckedModule' from GHC. +----------------------------------------------------------------------------- +module Haddock.Interface.Create (IfM, runIfM, createInterface1) where + +import Documentation.Haddock.Doc (metaDocAppend) +import Haddock.Backends.Hoogle (outWith) +import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl, synifyInstHead) +import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, + pretty, restrictTo, sigName, unL, typeNames) +import Haddock.Interface.AttachInstances (instHead) +import Haddock.Interface.LexParseRn +import Haddock.Options (Flag (..), modulePackageInfo) +import Haddock.Types +import Haddock.Utils (replace) + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Control.Monad.State.Strict +import Data.Bitraversable (bitraverse) +import Data.Foldable (toList) +import Data.List (find, foldl') +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) +import qualified Data.Set as Set +import Data.Traversable (for) + +import GHC hiding (lookupName) +import GHC.Core (isOrphan) +import GHC.Core.Class (ClassMinimalDef, classMinimalDef) +import GHC.Core.ConLike (ConLike (..)) +import GHC.Core.InstEnv +import GHC.Data.FastString (unpackFS) +import GHC.Driver.Ppr (showSDoc, showSDocForUser) +import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) +import GHC.IORef (readIORef) +import GHC.Stack (HasCallStack) +import GHC.Tc.Types hiding (IfM) +import GHC.Tc.Utils.Monad (finalSafeMode) +import GHC.Types.Avail hiding (avail) +import qualified GHC.Types.Avail as Avail +import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv) +import GHC.Types.Name.Env (lookupNameEnv) +import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) +import GHC.Types.Name.Set (elemNameSet, mkNameSet) +import GHC.Types.SourceFile (HscSource (..)) +import GHC.Types.SourceText (SourceText (..), sl_fs) +import GHC.Unit.Types +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Unit.Module as Module +import GHC.Unit.Module.ModSummary (msHsFilePath) +import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) +import qualified GHC.Utils.Outputable as O +import GHC.Utils.Panic (pprPanic) +import GHC.Unit.Module.Warnings +import GHC.Types.Unique.Map + +createInterface1 + :: MonadIO m + => [Flag] + -> UnitState + -> ModSummary + -> TcGblEnv + -> IfaceMap + -> InstIfaceMap + -> IfM m Interface +createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do + + let + ModSummary + { + -- Cached flags from OPTIONS, INCLUDE and LANGUAGE + -- pragmas in the modules source code. Used to infer + -- safety of module. + ms_hspp_opts + , ms_location = ModLocation + { + ml_hie_file + } + } = mod_sum + + !ml_hie_file' = force ml_hie_file + + TcGblEnv + { + tcg_mod + , tcg_src + , tcg_semantic_mod + , tcg_rdr_env + , tcg_exports + , tcg_insts + , tcg_fam_insts + , tcg_warns + + -- Renamed source + , tcg_rn_imports + , tcg_rn_exports + , tcg_rn_decls + + , tcg_th_docs + , tcg_doc_hdr + } = tc_gbl_env + + dflags = ms_hspp_opts + + is_sig = tcg_src == HsigFile + + (pkg_name_fs, _) = + modulePackageInfo unit_state flags (Just tcg_mod) + + pkg_name :: Maybe Package + pkg_name = + let + unpack (PackageName name) = unpackFS name + in + fmap unpack pkg_name_fs + + fixities :: FixMap + fixities = case tcg_rn_decls of + Nothing -> mempty + Just dx -> mkFixMap dx + + -- Locations of all the TH splices + loc_splices :: [SrcSpan] + loc_splices = case tcg_rn_decls of + Nothing -> [] + Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ] + + decls <- case tcg_rn_decls of + Nothing -> do + warn "Warning: Renamed source is not available" + pure [] + Just dx -> pure (topDecls dx) + + -- Derive final options to use for haddocking this module + doc_opts <- mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod + + let + -- All elements of an explicit export list, if present + export_list :: Maybe [(IE GhcRn, Avails)] + export_list + | OptIgnoreExports `elem` doc_opts = + Nothing + | Just rn_exports <- tcg_rn_exports = + Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ] + | otherwise = + Nothing + + -- All the exported Names of this module. + exported_names :: [Name] + !exported_names = force $ + concatMap availNamesWithSelectors tcg_exports + + -- Module imports of the form `import X`. Note that there is + -- a) no qualification and + -- b) no import list + imported_modules :: Map ModuleName [ModuleName] + imported_modules + | Just{} <- export_list = + unrestrictedModuleImports (map unLoc tcg_rn_imports) + | otherwise = + M.empty + + -- TyThings that have instances defined in this module + local_instances :: [Name] + local_instances = + [ name + | name <- map getName tcg_insts ++ map getName tcg_fam_insts + , nameIsLocalOrFrom tcg_semantic_mod name + ] + + -- Infer module safety + safety <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) + + -- The docs added via Template Haskell's putDoc + thDocs@ExtractedTHDocs { ethd_mod_header = thMbDocStr } <- + liftIO $ extractTHDocs <$> readIORef tcg_th_docs + + -- Process the top-level module header documentation. + (!info, !header_doc) <- force <$> processModuleHeader dflags pkg_name + tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr)) + + -- Warnings on declarations in this module + decl_warnings <- mkWarningMap dflags tcg_warns tcg_rdr_env exported_names + + -- Warning on the module header + mod_warning <- moduleWarning dflags tcg_rdr_env tcg_warns + + let + -- Warnings in this module and transitive warnings from dependent modules + warnings :: Map Name (Doc Name) + warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) + + maps@(!docs, !arg_docs, !decl_map, _) <- + mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs + + export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod + warnings tcg_rdr_env exported_names (map fst decls) maps fixities + imported_modules loc_splices export_list tcg_exports inst_ifaces dflags + + let + visible_names :: [Name] + !visible_names = force $ mkVisibleNames maps export_items doc_opts + + -- Measure haddock documentation coverage. + pruned_export_items :: [ExportItem GhcRn] + pruned_export_items = pruneExportItems export_items + + !haddockable = 1 + length export_items -- module + exports + !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items + + coverage :: (Int, Int) + !coverage = (haddockable, haddocked) + + aliases :: Map Module ModuleName + aliases = mkAliasMap unit_state tcg_rn_imports + + insts :: [HaddockClsInst] + !insts = force $ map (fromClsInst (Flag_Hoogle `elem` flags) dflags unit_state) tcg_insts + + return $! Interface + { + ifaceMod = tcg_mod + , ifaceIsSig = is_sig + , ifaceOrigFilename = msHsFilePath mod_sum + , ifaceHieFile = Just ml_hie_file' + , ifaceInfo = info + , ifaceDoc = Documentation header_doc mod_warning + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = doc_opts + , ifaceDocMap = docs + , ifaceArgMap = arg_docs + , ifaceExportItems = if OptPrune `elem` doc_opts then + pruned_export_items else export_items + , ifaceRnExportItems = [] -- Filled in renameInterfaceRn + , ifaceExports = exported_names + , ifaceVisibleExports = visible_names + , ifaceDeclMap = decl_map + , ifaceFixMap = fixities + , ifaceModuleAliases = aliases + , ifaceInstances = insts + , ifaceOrphanInstances = [] -- Filled in attachInstances + , ifaceRnOrphanInstances = [] -- Filled in renameInterfaceRn + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warnings + , ifaceDynFlags = dflags + } + + +-- | Given all of the @import M as N@ declarations in a package, +-- create a mapping from the module identity of M, to an alias N +-- (if there are multiple aliases, we pick the last one.) This +-- will go in 'ifaceModuleAliases'. +mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName +mkAliasMap st impDecls = + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + SrcLoc.L _ alias <- ideclAs impDecl + return + (lookupModuleDyn st + -- TODO: This is supremely dodgy, because in general the + -- UnitId isn't going to look anything like the package + -- qualifier (even with old versions of GHC, the + -- IPID would be p-0.1, but a package qualifier never + -- has a version number it. (Is it possible that in + -- Haddock-land, the UnitIds never have version numbers? + -- I, ezyang, have not quite understand Haddock's package + -- identifier model.) + -- + -- Additionally, this is simulating some logic GHC already + -- has for deciding how to qualify names when it outputs + -- them to the user. We should reuse that information; + -- or at least reuse the renamed imports, which know what + -- they import! + (ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls + +-- We want to know which modules are imported without any qualification. This +-- way we can display module reexports more compactly. This mapping also looks +-- through aliases: +-- +-- module M (module X) where +-- import M1 as X +-- import M2 as X +-- +-- With our mapping we know that we can display exported modules M1 and M2. +-- +unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports idecls = + M.map (map (unLoc . ideclName)) + $ M.filter (all isInteresting) impModMap + where + impModMap = + M.fromListWith (++) (concatMap moduleMapping idecls) + + moduleMapping idecl = + concat [ [ (unLoc (ideclName idecl), [idecl]) ] + , [ (unLoc mod_name, [idecl]) + | Just mod_name <- [ideclAs idecl] + ] + ] + + isInteresting idecl = + case ideclImportList idecl of + -- i) no subset selected + Nothing -> True + -- ii) an import with a hiding clause + -- without any names + Just (EverythingBut, L _ []) -> True + -- iii) any other case of qualification + _ -> False + +-- Similar to GHC.lookupModule +-- ezyang: Not really... +lookupModuleDyn :: + UnitState -> PkgQual -> ModuleName -> Module +lookupModuleDyn st pkg_qual mdlName = case pkg_qual of + OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName + ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName + NoPkgQual -> case lookupModuleInAllUnits st mdlName of + (m,_):_ -> m + [] -> Module.mkModule Module.mainUnit mdlName + +-- | Prune a 'ClsInst' down to a 'HaddockClsInst'. The goal is to remove as much +-- unnecessary information from the 'ClsInst' as possible by precomputing the +-- information we eventually want from it. +fromClsInst + :: Bool + -- ^ Was Hoogle output requested? + -> DynFlags + -- ^ GHC session dynflags + -> UnitState + -- ^ GHC session dynflags + -> ClsInst + -- ^ Class instance to convert + -> HaddockClsInst + -- ^ Resulting Haddock class instance +fromClsInst doHoogle dflags unitState inst = + HaddockClsInst + { haddockClsInstPprHoogle = + if doHoogle then Just (ppInstance inst) else Nothing + , haddockClsInstName = getName inst + , haddockClsInstClsName = getName cls + , haddockClsInstIsOrphan = isOrphan $ is_orphan inst + , haddockClsInstSynified = synifyInstHead instSig + , haddockClsInstHead = instHead instSig + , haddockClsInstTyNames = + foldl' (\ns t -> ns `Set.union` typeNames t) Set.empty tys + } + where + instSig :: ([TyVar], [Type], Class, [Type]) + instSig@(_,_,cls,tys) = instanceSig inst + + ppInstance :: ClsInst -> String + ppInstance i = + dropComment $ outWith (showSDocForUser dflags unitState alwaysQualify) i' + where + -- As per #168, we don't want safety information about the class + -- in Hoogle output. The easiest way to achieve this is to set the + -- safety information to a state where the Outputable instance + -- produces no output which means no overlap and unsafe (or [safe] + -- is generated). + i' = i { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText + , isSafeOverlap = False } } + + dropComment :: String -> String + dropComment (' ':'-':'-':' ':_) = [] + dropComment (x:xs) = x : dropComment xs + dropComment [] = [] + + +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + +mkWarningMap + :: MonadIO m + => DynFlags + -> Warnings a + -> GlobalRdrEnv + -> [Name] + -> IfM m WarningMap +mkWarningMap dflags warnings gre exps = case warnings of + NoWarnings -> pure M.empty + WarnAll _ -> pure M.empty + WarnSome ws -> + let ws' = [ (n, w) + | (occ, w) <- ws + , elt <- lookupGlobalRdrEnv gre occ + , let n = greMangledName elt, n `elem` exps ] + in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' + +moduleWarning + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> Warnings a + -> IfM m (Maybe (Doc Name)) +moduleWarning _ _ NoWarnings = pure Nothing +moduleWarning _ _ (WarnSome _) = pure Nothing +moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w + +parseWarning + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> WarningTxt a + -> IfM m (Doc Name) +parseWarning dflags gre w = case w of + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) + where + format x bs = DocWarning . DocParagraph . DocAppend (DocString x) + <$> processDocStringFromString dflags gre bs + + +------------------------------------------------------------------------------- +-- Doc options +-- +-- Haddock options that are embedded in the source file +------------------------------------------------------------------------------- + +mkDocOpts :: MonadIO m => Maybe String -> [Flag] -> Module -> IfM m [DocOption] +mkDocOpts mbOpts flags mdl = do + opts <- case mbOpts of + Just opts -> case words $ replace ',' ' ' opts of + [] -> warn "No option supplied to DOC_OPTION/doc_option" >> return [] + xs -> fmap catMaybes (mapM parseOption xs) + Nothing -> return [] + pure (foldl go opts flags) + where + mdlStr = moduleString mdl + + -- Later flags override earlier ones + go os m | m == Flag_HideModule mdlStr = OptHide : os + | m == Flag_ShowModule mdlStr = filter (/= OptHide) os + | m == Flag_ShowAllModules = filter (/= OptHide) os + | m == Flag_IgnoreAllExports = OptIgnoreExports : os + | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os + | otherwise = os + +parseOption :: MonadIO m => String -> IfM m (Maybe DocOption) +parseOption "hide" = return (Just OptHide) +parseOption "prune" = return (Just OptPrune) +parseOption "ignore-exports" = return (Just OptIgnoreExports) +parseOption "not-home" = return (Just OptNotHome) +parseOption "show-extensions" = return (Just OptShowExtensions) +parseOption other = warn ("Unrecognised option: " ++ other) >> return Nothing + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + + +type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) + +-- | Create 'Maps' by looping through the declarations. For each declaration, +-- find its names, its subordinates, and its doc strings. Process doc strings +-- into 'Doc's. +mkMaps + :: MonadIO m + => DynFlags + -> Maybe Package -- this package + -> GlobalRdrEnv + -> [Name] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] + -> ExtractedTHDocs -- ^ Template Haskell putDoc docs + -> IfM m Maps +mkMaps dflags pkgName gre instances decls thDocs = do + (a, b, c) <- unzip3 <$> traverse mappings decls + (th_a, th_b) <- thMappings + pure ( force $ + th_a `M.union` f' (map (nubByName fst) a) + , force $ + fmap intmap2mapint $ + th_b `unionArgMaps` (f (filterMapping (not . IM.null) b)) + , f c + , instanceMap + ) + where + f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + 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)) + + -- Convert IntMap -> IntMap + -- TODO: should ArgMap eventually be switched over to IntMap? + intmap2mapint = M.fromList . IM.toList + + -- | Extract the mappings from template haskell. + -- No DeclMap/InstMap is needed since we already have access to the + -- doc strings + thMappings + :: MonadIO m + => IfM m (Map Name (MDoc Name), Map Name (IntMap (MDoc Name))) + thMappings = do + let ExtractedTHDocs + _ + declDocs + argDocs + instDocs = thDocs + ds2mdoc :: MonadIO m => (HsDoc GhcRn) -> IfM m (MDoc Name) + ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString + + let cvt = M.fromList . nonDetEltsUniqMap + + declDocs' <- mapM ds2mdoc (cvt declDocs) + argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs) + instDocs' <- mapM ds2mdoc (cvt instDocs) + return (declDocs' <> instDocs', argDocs') + + + mappings + :: MonadIO m + => (LHsDecl GhcRn, [HsDoc GhcRn]) + -> IfM m + ( [(Name, MDoc Name)] + , [(Name, IntMap (MDoc Name))] + , [(Name, DeclMapEntry)] + ) + mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do + let docStrs = map hsDocString hs_docStrs + declDoc + :: MonadIO m + => [HsDocString] + -> IntMap HsDocString + -> IfM m (Maybe (MDoc Name), IntMap (MDoc Name)) + declDoc strs m = do + doc' <- processDocStrings dflags pkgName gre strs + m' <- traverse (processDocStringParas dflags pkgName gre) m + pure (doc', m') + + (!doc, !args) <- force <$> declDoc docStrs (fmap hsDocString (declTypeDocs decl)) + + let + subs :: [(Name, [HsDocString], IntMap HsDocString)] + subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im)) + $ subordinates emptyOccEnv instanceMap decl + + (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs + + let + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] + am = [ (n, args) | n <- ns ] ++ zip subNs subArgs + cm = [ (n, toDeclMapEntry ldecl) | n <- ns ++ subNs ] + + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + pure (dm, am, cm) + mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], []) + + instanceMap :: Map RealSrcSpan Name + instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] + + names :: RealSrcSpan -> HsDecl GhcRn -> [Name] + names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2]. + where loc = case d of + -- The CoAx's loc is the whole line, but only for TFs. The + -- workaround is to dig into the family instance declaration and + -- get the identifier with the right location. + TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') + _ -> getInstLoc d + names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. + names _ decl = getMainDeclBinder emptyOccEnv decl + +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two +-- maps with values for the same key merge the inner map as well. +-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. + +unionArgMaps :: forall b . Map Name (IntMap b) + -> Map Name (IntMap b) + -> Map Name (IntMap b) +unionArgMaps a b = M.foldrWithKey go b a + where + go :: Name -> IntMap b + -> Map Name (IntMap b) -> Map Name (IntMap b) + go n newArgMap acc + | Just oldArgMap <- M.lookup n acc = + M.insert n (newArgMap `IM.union` oldArgMap) acc + | otherwise = M.insert n newArgMap acc + +-- Note [2]: +------------ +-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried +-- inside them. That should work for normal user-written instances (from +-- looking at GHC sources). We can assume that commented instances are +-- user-written. This lets us relate Names (from ClsInsts) to comments +-- (associated with InstDecls and DerivDecls). + +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + +-- | Extract a map of fixity declarations only +mkFixMap :: HsGroup GhcRn -> FixMap +mkFixMap group_ = + M.fromList [ (n,f) + | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_, + L _ n <- ns ] + + +-- | Build the list of items that will become the documentation, from the +-- export list. At this point, the list of ExportItems is in terms of +-- original names. +-- +-- We create the export items even if the module is hidden, since they +-- might be useful when creating the export items for other modules. +mkExportItems + :: MonadIO m + => Bool -- is it a signature + -> IfaceMap + -> Maybe Package -- this package + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> GlobalRdrEnv + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations + -> Maps + -> FixMap + -> M.Map ModuleName [ModuleName] + -> [SrcSpan] -- splice locations + -> Maybe [(IE GhcRn, Avails)] + -> Avails -- exported stuff from this module + -> InstIfaceMap + -> DynFlags + -> IfM m [ExportItem GhcRn] +mkExportItems + is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls + maps fixMap unrestricted_imp_mods splices exportList allExports + instIfaceMap dflags = + case exportList of + Nothing -> do + fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre + exportedNames decls maps fixMap splices instIfaceMap dflags + allExports + Just exports -> fmap concat $ mapM lookupExport exports + where + lookupExport (IEGroup _ lev docStr, _) = do + !doc <- force <$> processDocString dflags gre (hsDocString . unLoc $ docStr) + return [ExportGroup lev "" doc] + + lookupExport (IEDoc _ docStr, _) = do + !doc <- force <$> processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) + return [ExportDoc doc] + + lookupExport (IEDocNamed _ str, _) = + findNamedDoc str [ unL d | d <- decls ] >>= \case + Nothing -> return [] + Just docStr -> do + !doc <- force <$> processDocStringParas dflags pkgName gre docStr + return [ExportDoc doc] + + lookupExport (IEModuleContents _ (L _ mod_name), _) + -- only consider exporting a module if we are sure we + -- are really exporting the whole module and not some + -- subset. We also look through module aliases here. + | Just mods <- M.lookup mod_name unrestricted_imp_mods + , not (null mods) + = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods + + lookupExport (_, avails) = concat <$> traverse availExport (nubAvails avails) + + availExport avail = + availExportItem is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avail + + +-- Extract the minimal complete definition of a Name, if one exists +minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef) +minimalDef n = do + mty <- lookupName n + case mty of + Just (ATyCon (tyConClass_maybe -> Just c)) -> + return . Just $ classMinimalDef c + _ -> + return Nothing + + +availExportItem + :: forall m + . MonadIO m + => Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> IfM m [ExportItem GhcRn] +availExportItem is_sig modMap thisMod semMod warnings exportedNames + (docMap, argMap, declMap, _) fixMap splices instIfaceMap + dflags availInfo = declWith availInfo + where + declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ] + declWith avail = do + let t = availName avail + r <- findDecl avail + case r of + (Just (EValD srcSpan), (doc, _)) -> do + -- Since the DeclMapEntry is an 'EValD', we know the declaration is a + -- top-level binding without a type signature. We get type information + -- for the binding from the GHC interface file using the + -- 'hiValExportItem' function + export <- hiValExportItem dflags t srcSpan doc (srcSpan `elem` splices) $ M.lookup t fixMap + return [export] + + (Just (EOther d), docs_) -> + let declNames = getMainDeclBinder emptyOccEnv (unL d) + in case () of + _ + -- If 't' is not the main declaration binder, then it is a + -- subordinate name in the declaration. If any of its parents are + -- also exported, we do not want to show its documentation by + -- itself. See note [1]. + | t `notElem` declNames, + Just p <- find isExported (parents t $ unL d) -> do + warn $ + "Warning: " ++ moduleString thisMod ++ ": " ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ + ". Consider exporting it together with its parent(s)" ++ + " for code clarity." + return [] + + -- normal case + | otherwise -> case d of + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. + L loc (SigD _ sig) -> + -- fromJust is safe since we already checked in guards + -- that 't' is a name declared in this declaration. + let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig + in availExportDecl avail newDecl docs_ + + L loc (TyClD _ ClassDecl {..}) -> do + mdef <- minimalDef t + let sig = maybeToList $ fmap (noLocA . MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA) mdef + availExportDecl avail + (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ + + _ -> availExportDecl avail d docs_ + + -- Declaration from another package + (Nothing, _) -> do + mayDecl <- hiDecl dflags t + case mayDecl of + Nothing -> return [ ExportNoDecl t [] ] + Just decl -> + -- We try to get the subs and docs + -- from the installed .haddock file for that package. + -- TODO: This needs to be more sophisticated to deal + -- with signature inheritance + case M.lookup (nameModule t) instIfaceMap of + Nothing -> do + warn $ "Warning: Couldn't find .haddock for export " ++ pretty dflags t + let subs_ = availNoDocs avail + availExportDecl avail decl (noDocForDecl, subs_) + Just iface -> + availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) + + -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails + availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn) + availDecl declName parentDecl = + case extractDecl declMap declName parentDecl of + Right d -> pure d + Left err -> do + synifiedDeclOpt <- hiDecl dflags declName + case synifiedDeclOpt of + Just synifiedDecl -> pure synifiedDecl + Nothing -> pprPanic "availExportItem" (O.text err) + + availExportDecl :: AvailInfo -> LHsDecl GhcRn + -> (DocForDecl Name, [(Name, DocForDecl Name)]) + -> IfM m [ ExportItem GhcRn ] + availExportDecl avail decl (doc, subs) + | availExportsDecl avail = do + extractedDecl <- availDecl (availName avail) decl + + -- bundled pattern synonyms only make sense if the declaration is + -- exported (otherwise there would be nothing to bundle to) + bundledPatSyns <- findBundledPatterns avail + + let + !patSynNames = force $ + concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns + + !doc' = force doc + !subs' = force subs + + !restrictToNames = force $ fmap fst subs' + + !fixities = force + [ (n, f) + | n <- availName avail : fmap fst subs' ++ patSynNames + , Just f <- [M.lookup n fixMap] + ] + + return + [ ExportDecl ExportD + { expDDecl = restrictTo restrictToNames extractedDecl + , expDPats = bundledPatSyns + , expDMbDoc = doc' + , expDSubDocs = subs' + , expDInstances = [] + , expDFixities = fixities + , expDSpliced = False + } + ] + + | otherwise = for subs $ \(sub, sub_doc) -> do + extractedDecl <- availDecl sub decl + + let + !fixities = force [ (sub, f) | Just f <- [M.lookup sub fixMap] ] + !subDoc = force sub_doc + + return $ + ExportDecl ExportD + { expDDecl = extractedDecl + , expDPats = [] + , expDMbDoc = subDoc + , expDSubDocs = [] + , expDInstances = [] + , expDFixities = fixities + , expDSpliced = False + } + + exportedNameSet = mkNameSet exportedNames + isExported n = elemNameSet n exportedNameSet + + findDecl :: AvailInfo -> IfM m (Maybe DeclMapEntry, (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl avail + | m == semMod = + case M.lookup n declMap of + Just d -> return (Just d, lookupDocs avail warnings docMap argMap) + Nothing + | is_sig -> do + -- OK, so it wasn't in the local declaration map. It could + -- have been inherited from a signature. Reconstitute it + -- from the type. + mb_r <- hiDecl dflags n + case mb_r of + Nothing -> return (Nothing, (noDocForDecl, availNoDocs avail)) + -- TODO: If we try harder, we might be able to find + -- a Haddock! Look in the Haddocks for each thing in + -- requirementContext (unitState) + Just decl -> return (Just $ toDeclMapEntry decl, (noDocForDecl, availNoDocs avail)) + | otherwise -> + return (Nothing, (noDocForDecl, availNoDocs avail)) + | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap + , Just d <- M.lookup n (ifaceDeclMap iface) = + return (Just d, lookupDocs avail warnings + (ifaceDocMap iface) + (ifaceArgMap iface)) + | otherwise = return (Nothing, (noDocForDecl, availNoDocs avail)) + where + n = availName avail + m = nameModule n + + findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns avail = do + patsyns <- for constructor_names $ \name -> do + mtyThing <- lookupName name + case mtyThing of + Just (AConLike PatSynCon{}) -> do + export_items <- declWith (Avail.avail name) + pure [ (unLoc patsyn_decl, patsyn_doc) + | ExportDecl ExportD + { expDDecl = patsyn_decl + , expDMbDoc = patsyn_doc + } <- export_items + ] + _ -> pure [] + pure (concat patsyns) + where + constructor_names = + filter isDataConName (availSubordinates avail) + +availSubordinates :: AvailInfo -> [Name] +availSubordinates = map greNameMangledName . availSubordinateGreNames + +availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] +availNoDocs avail = + zip (availSubordinates avail) (repeat noDocForDecl) + +-- | Given a 'Module' from a 'Name', convert it into a 'Module' that +-- we can actually find in the 'IfaceMap'. +semToIdMod :: Unit -> Module -> Module +semToIdMod this_uid m + | Module.isHoleModule m = mkModule this_uid (moduleName m) + | otherwise = m + +hiDecl :: MonadIO m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) +hiDecl dflags t = do + mayTyThing <- lookupName t + case mayTyThing of + Nothing -> do + warn $ "Warning: Not found in environment: " ++ pretty dflags t + return Nothing + Just x -> case tyThingToLHsDecl ShowRuntimeRep x of + Left m -> (warn $ bugWarn m) >> return Nothing + Right (m, t') -> mapM (warn . bugWarn) m >> return (Just $ noLocA t') + where + warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<> + O.comma O.<+> O.quotes (O.ppr t) O.<+> + O.text "-- Please report this on Haddock issue tracker!" + bugWarn = showSDoc dflags . warnLine + +-- | This function is called for top-level bindings without type signatures. +-- It gets the type signature from GHC and that means it's not going to +-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the +-- declaration and use it instead - 'nLoc' here. +hiValExportItem + :: MonadIO m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool + -> Maybe Fixity -> IfM m (ExportItem GhcRn) +hiValExportItem dflags name nLoc doc splice fixity = do + mayDecl <- hiDecl dflags name + case mayDecl of + Nothing -> return (ExportNoDecl name []) + Just decl -> return (ExportDecl $ ExportD (fixSpan decl) [] doc [] [] fixities splice) + where + fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t + fixities = case fixity of + Just f -> [(name, f)] + Nothing -> [] + + +-- | Lookup docs for a declaration from maps. +lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name + -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs avail warningMap docMap argMap = + let n = availName avail in + let lookupArgDoc x = M.findWithDefault M.empty x argMap in + let doc = (lookupDoc n, lookupArgDoc n) in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) + | s <- availSubordinates avail + ] in + (doc, subDocs) + where + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warningMap) + + +-- | Export the given module as `ExportModule`. We are not concerned with the +-- single export items of the given module. +moduleExport + :: MonadIO m + => Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> IfM m [ExportItem GhcRn] -- ^ Resulting export items +moduleExport thisMod dflags ifaceMap instIfaceMap expMod = + -- NB: we constructed the identity module when looking up in + -- the IfaceMap. + case M.lookup m ifaceMap of + Just iface + | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) + | otherwise -> return [ ExportModule m ] + + Nothing -> -- We have to try to find it in the installed interfaces + -- (external packages). + case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + warn $ + "Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod + return [] + where + m = mkModule (moduleUnit thisMod) expMod -- Identity module! + +-- Note [1]: +------------ +-- It is unnecessary to document a subordinate by itself at the top level if +-- any of its parents is also documented. Furthermore, if the subordinate is a +-- record field or a class method, documenting it under its parent +-- indicates its special status. +-- +-- A user might expect that it should show up separately, so we issue a +-- warning. It's a fine opportunity to also tell the user she might want to +-- export the subordinate through the parent export item for clarity. +-- +-- The code removes top-level subordinates also when the parent is exported +-- through a 'module' export. I think that is fine. +-- +-- (For more information, see Trac #69) + + +-- | Simplified variant of 'mkExportItems', where we can assume that +-- every locally defined declaration is exported; thus, we just +-- zip through the renamed declarations. + +fullModuleContents + :: MonadIO m + => Bool -- is it a signature + -> IfaceMap + -> Maybe Package -- this package + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> IfM m [ExportItem GhcRn] +fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames + decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do + let availEnv = availsToNameEnv (nubAvails avails) + (concat . concat) `fmap` (for decls $ \decl -> do + case decl of + (L _ (DocD _ (DocGroup lev docStr))) -> do + !doc <- force <$> processDocString dflags gre (hsDocString . unLoc $ docStr) + return [[ExportGroup lev "" doc]] + (L _ (DocD _ (DocCommentNamed _ docStr))) -> do + !doc <- force <$> processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) + return [[ExportDoc doc]] + (L _ (ValD _ valDecl)) + | name:_ <- collectHsBindBinders CollNoDictBinders valDecl + , Just (EOther (L _ SigD{})) <- M.lookup name declMap + -> return [] + _ -> + for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do + case lookupNameEnv availEnv nm of + Just avail -> + availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags avail + Nothing -> pure []) + +-- | Sometimes the declaration we want to export is not the "main" declaration: +-- it might be an individual record selector or a class method. In these +-- cases we have to extract the required declaration (and somehow cobble +-- together a type signature for it...). +-- +-- This function looks through the declarations in this module to try to find +-- the one with the right name. +extractDecl + :: HasCallStack + => DeclMap -- ^ all declarations in the file + -> Name -- ^ name of the declaration to extract + -> LHsDecl GhcRn -- ^ parent declaration + -> Either String (LHsDecl GhcRn) +extractDecl declMap name decl + | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl + | otherwise = + case unLoc decl of + TyClD _ d@ClassDecl { tcdLName = L _ clsNm + , tcdSigs = clsSigs + , tcdATs = clsATs } -> + let + matchesMethod = + [ lsig + | lsig <- clsSigs + , ClassOpSig _ False _ _ <- pure $ unLoc lsig + -- Note: exclude `default` declarations (see #505) + , name `elem` sigName lsig + ] + + matchesAssociatedType = + [ lfam_decl + | lfam_decl <- clsATs + , name == unLoc (fdLName (unLoc lfam_decl)) + ] + + -- TODO: document fixity + in case (matchesMethod, matchesAssociatedType) of + ([s0], _) -> let tyvar_names = tyClDeclTyVars d + L pos sig = addClassContext clsNm tyvar_names s0 + in pure (L pos (SigD noExtField sig)) + (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl))) + + ([], []) + | Just (EOther famInstDecl) <- M.lookup name declMap + -> extractDecl declMap name famInstDecl + _ -> Left (concat [ "Ambiguous decl for ", getOccString name + , " in class ", getOccString clsNm ]) + + TyClD _ d@DataDecl { tcdLName = L _ dataNm + , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do + let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d) + lsig <- if isDataConName name + then extractPatternSyn name dataNm ty_args (toList dataCons) + else extractRecSel name dataNm ty_args (toList dataCons) + pure (SigD noExtField <$> lsig) + + TyClD _ FamDecl {} + | isValName name + , Just (EOther famInst) <- M.lookup name declMap + -> extractDecl declMap name famInst + InstD _ (DataFamInstD _ (DataFamInstDecl + (FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = defn }))) -> + if isDataConName name + then fmap (SigD noExtField) <$> extractPatternSyn name n tys (toList $ dd_cons defn) + else fmap (SigD noExtField) <$> extractRecSel name n tys (toList $ dd_cons defn) + InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) + | isDataConName name -> + let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts + , name `elem` map unLoc (concatMap (toList . getConNames . unLoc) (dd_cons dd)) + ] + in case matches of + [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0))) + _ -> Left "internal: extractDecl (ClsInstD)" + | otherwise -> + let matches = [ d' | L _ d'@(DataFamInstDecl d ) + <- insts + -- , L _ ConDecl { con_details = RecCon rec } <- toList $ dd_cons (feqn_rhs d) + , Just rec <- toList $ getRecConArgs_maybe . unLoc <$> dd_cons (feqn_rhs d) + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns + , foExt n == name + ] + in case matches of + [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) + _ -> Left "internal: extractDecl (ClsInstD)" + _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) + +extractPatternSyn :: Name -> Name + -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] + -> Either String (LSig GhcRn) +extractPatternSyn nm t tvs cons = + case filter matches cons of + [] -> Left . O.showSDocOneLine O.defaultSDocContext $ + O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t + con:_ -> pure (extract <$> con) + where + matches :: LConDecl GhcRn -> Bool + matches (L _ con) = nm `elem` (unLoc <$> getConNames con) + extract :: ConDecl GhcRn -> Sig GhcRn + extract con = + let args = + case con of + ConDeclH98 { con_args = con_args' } -> case con_args' of + PrefixCon _ args' -> map hsScaledThing args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] + ConDeclGADT { con_g_args = con_args' } -> case con_args' of + PrefixConGADT args' -> map hsScaledThing args' + RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields + typ = longArrow args (data_ty con) + typ' = + case con of + ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ) + _ -> typ + typ'' = noLocA (HsQualTy noExtField (noLocA []) typ') + in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') + + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn + longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs + + data_ty con + | ConDeclGADT{} <- con = con_res_ty con + | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noAnn f + +extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] + -> Either String (LSig GhcRn) +extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" + +extractRecSel nm t tvs (L _ con : rest) = + case getRecConArgs_maybe con of + Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> + pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty)))))) + _ -> extractRecSel nm t tvs rest + where + matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] + matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds + , L l n <- ns, foExt n == nm ] + data_ty + -- ResTyGADT _ ty <- con_res con = ty + | ConDeclGADT{} <- con = con_res_ty con + | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noAnn f + +-- | Keep export items with docs. +pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] +pruneExportItems = filter hasDoc + where + hasDoc (ExportDecl ExportD {expDMbDoc = (Documentation d _, _)}) = isJust d + hasDoc _ = True + + +mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, instMap) exports opts + | OptHide `elem` opts = [] + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns + where + exportName (ExportDecl e@ExportD{}) = name ++ subs ++ patsyns + where subs = map fst (expDSubDocs e) + patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expDPats e) + name = case unLoc $ expDDecl e of + InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap + decl -> getMainDeclBinder emptyOccEnv decl + exportName ExportNoDecl {} = [] -- we don't count these as visible, since + -- we don't want links to go to them. + exportName _ = [] + +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs + +-- | Find a stand-alone documentation comment by its name. +findNamedDoc :: MonadIO m => String -> [HsDecl GhcRn] -> IfM m (Maybe HsDocString) +findNamedDoc name = search + where + search [] = do + -- TODO: Make sure this isn't duplicating messages + warn $ "Cannot find documentation for: $" ++ name + return Nothing + search (DocD _ (DocCommentNamed name' doc) : rest) + | name == name' = return (Just (hsDocString . unLoc $ doc)) + | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/src/Haddock/Interface/Json.hs b/src/Haddock/Interface/Json.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Interface/Json.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE RecordWildCards #-} +module Haddock.Interface.Json ( + jsonInstalledInterface + , jsonInterfaceFile + , renderJson + ) where + +import GHC.Types.Fixity +import GHC.Utils.Json +import GHC.Unit.Module +import GHC.Types.Name +import GHC.Utils.Outputable + +import Control.Arrow +import Data.Map (Map) +import qualified Data.Map as Map + +import Haddock.Types +import Haddock.InterfaceFile + +jsonInterfaceFile :: InterfaceFile -> JsonDoc +jsonInterfaceFile InterfaceFile{..} = + jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv) + , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces)) + ] + +jsonInstalledInterface :: InstalledInterface -> JsonDoc +jsonInstalledInterface InstalledInterface{..} = jsonObject properties + where + properties = + [ ("module" , jsonModule instMod) + , ("is_sig" , jsonBool instIsSig) + , ("info" , jsonHaddockModInfo instInfo) + , ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap) + , ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap) + , ("exports" , jsonArray (map jsonName instExports)) + , ("visible_exports" , jsonArray (map jsonName instVisibleExports)) + , ("options" , jsonArray (map (jsonString . show) instOptions)) + , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap) + ] + +jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc +jsonHaddockModInfo HaddockModInfo{..} = + jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description) + , ("copyright" , jsonMaybe jsonString hmi_copyright) + , ("maintainer" , jsonMaybe jsonString hmi_maintainer) + , ("stability" , jsonMaybe jsonString hmi_stability) + , ("protability" , jsonMaybe jsonString hmi_portability) + , ("safety" , jsonMaybe jsonString hmi_safety) + , ("language" , jsonMaybe (jsonString . show) hmi_language) + , ("extensions" , jsonArray (map (jsonString . show) hmi_extensions)) + ] + +jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc +jsonMap f g = jsonObject . map (f *** g) . Map.toList + +jsonMDoc :: MDoc Name -> JsonDoc +jsonMDoc MetaDoc{..} = + jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) + , ("document", jsonDoc _doc) + ] + +showModName :: Wrap (ModuleName, OccName) -> String +showModName = showWrapped (moduleNameString . fst) + +showName :: Wrap Name -> String +showName = showWrapped nameStableString + + +jsonDoc :: Doc Name -> JsonDoc + +jsonDoc DocEmpty = jsonObject + [ ("tag", jsonString "DocEmpty") ] + +jsonDoc (DocAppend x y) = jsonObject + [ ("tag", jsonString "DocAppend") + , ("first", jsonDoc x) + , ("second", jsonDoc y) + ] + +jsonDoc (DocString s) = jsonObject + [ ("tag", jsonString "DocString") + , ("string", jsonString s) + ] + +jsonDoc (DocParagraph x) = jsonObject + [ ("tag", jsonString "DocParagraph") + , ("document", jsonDoc x) + ] + +jsonDoc (DocIdentifier name) = jsonObject + [ ("tag", jsonString "DocIdentifier") + , ("name", jsonString (showName name)) + ] + +jsonDoc (DocIdentifierUnchecked modName) = jsonObject + [ ("tag", jsonString "DocIdentifierUnchecked") + , ("modName", jsonString (showModName modName)) + ] + +jsonDoc (DocModule (ModLink m _l)) = jsonObject + [ ("tag", jsonString "DocModule") + , ("string", jsonString m) + ] + +jsonDoc (DocWarning x) = jsonObject + [ ("tag", jsonString "DocWarning") + , ("document", jsonDoc x) + ] + +jsonDoc (DocEmphasis x) = jsonObject + [ ("tag", jsonString "DocEmphasis") + , ("document", jsonDoc x) + ] + +jsonDoc (DocMonospaced x) = jsonObject + [ ("tag", jsonString "DocMonospaced") + , ("document", jsonDoc x) + ] + +jsonDoc (DocBold x) = jsonObject + [ ("tag", jsonString "DocBold") + , ("document", jsonDoc x) + ] + +jsonDoc (DocUnorderedList xs) = jsonObject + [ ("tag", jsonString "DocUnorderedList") + , ("documents", jsonArray (fmap jsonDoc xs)) + ] + +jsonDoc (DocOrderedList xs) = jsonObject + [ ("tag", jsonString "DocOrderedList") + , ("items", jsonArray (fmap jsonItem xs)) + ] + where + jsonItem (index, a) = jsonObject [("document", jsonDoc a), ("seq", jsonInt index)] + +jsonDoc (DocDefList xys) = jsonObject + [ ("tag", jsonString "DocDefList") + , ("definitions", jsonArray (fmap jsonDef xys)) + ] + where + jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)] + +jsonDoc (DocCodeBlock x) = jsonObject + [ ("tag", jsonString "DocCodeBlock") + , ("document", jsonDoc x) + ] + +jsonDoc (DocHyperlink hyperlink) = jsonObject + [ ("tag", jsonString "DocHyperlink") + , ("hyperlink", jsonHyperlink hyperlink) + ] + where + jsonHyperlink Hyperlink{..} = jsonObject + [ ("hyperlinkUrl", jsonString hyperlinkUrl) + , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel) + ] + +jsonDoc (DocPic picture) = jsonObject + [ ("tag", jsonString "DocPic") + , ("picture", jsonPicture picture) + ] + where + jsonPicture Picture{..} = jsonObject + [ ("pictureUrl", jsonString pictureUri) + , ("pictureLabel", jsonMaybe jsonString pictureTitle) + ] + +jsonDoc (DocMathInline s) = jsonObject + [ ("tag", jsonString "DocMathInline") + , ("string", jsonString s) + ] + +jsonDoc (DocMathDisplay s) = jsonObject + [ ("tag", jsonString "DocMathDisplay") + , ("string", jsonString s) + ] + +jsonDoc (DocAName s) = jsonObject + [ ("tag", jsonString "DocAName") + , ("string", jsonString s) + ] + +jsonDoc (DocProperty s) = jsonObject + [ ("tag", jsonString "DocProperty") + , ("string", jsonString s) + ] + +jsonDoc (DocExamples examples) = jsonObject + [ ("tag", jsonString "DocExamples") + , ("examples", jsonArray (fmap jsonExample examples)) + ] + where + jsonExample Example{..} = jsonObject + [ ("exampleExpression", jsonString exampleExpression) + , ("exampleResult", jsonArray (fmap jsonString exampleResult)) + ] + +jsonDoc (DocHeader header) = jsonObject + [ ("tag", jsonString "DocHeader") + , ("header", jsonHeader header) + ] + where + jsonHeader Header{..} = jsonObject + [ ("headerLevel", jsonInt headerLevel) + , ("headerTitle", jsonDoc headerTitle) + ] + +jsonDoc (DocTable table) = jsonObject + [ ("tag", jsonString "DocTable") + , ("table", jsonTable table) + ] + where + jsonTable Table{..} = jsonObject + [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows)) + , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows)) + ] + + jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells) + + jsonTableCell TableCell{..} = jsonObject + [ ("tableCellColspan", jsonInt tableCellColspan) + , ("tableCellRowspan", jsonInt tableCellRowspan) + , ("tableCellContents", jsonDoc tableCellContents) + ] + + +jsonModule :: Module -> JsonDoc +jsonModule = JSString . moduleStableString + +jsonName :: Name -> JsonDoc +jsonName = JSString . nameStableString + +jsonFixity :: Fixity -> JsonDoc +jsonFixity (Fixity _ prec dir) = + jsonObject [ ("prec" , jsonInt prec) + , ("direction" , jsonFixityDirection dir) + ] + +jsonFixityDirection :: FixityDirection -> JsonDoc +jsonFixityDirection InfixL = jsonString "infixl" +jsonFixityDirection InfixR = jsonString "infixr" +jsonFixityDirection InfixN = jsonString "infix" + +renderJson :: JsonDoc -> SDoc +renderJson = renderJSON + +jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc +jsonMaybe = maybe jsonNull + +jsonString :: String -> JsonDoc +jsonString = JSString + +jsonObject :: [(String, JsonDoc)] -> JsonDoc +jsonObject = JSObject + +jsonArray :: [JsonDoc] -> JsonDoc +jsonArray = JSArray + +jsonNull :: JsonDoc +jsonNull = JSNull + +jsonInt :: Int -> JsonDoc +jsonInt = JSInt + +jsonBool :: Bool -> JsonDoc +jsonBool = JSBool diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn @@ -13,68 +15,117 @@ ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn ( processDocString + , processDocStringFromString , processDocStringParas , processDocStrings , processModuleHeader ) where -import Data.IntSet (toList) -import Data.List +import Control.Arrow +import Control.Monad +import Control.Monad.State.Strict +import Data.Functor +import Data.List ((\\), maximumBy) +import Data.Ord +import qualified Data.Set as Set import Documentation.Haddock.Doc (metaDocConcat) -import DynFlags (languageExtensions) +import GHC.Driver.Session (languageExtensions) import qualified GHC.LanguageExtensions as LangExt -import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types -import Name -import Outputable ( showPpr ) -import RdrName -import RnEnv (dataTcOccs) +import GHC.Data.EnumSet as EnumSet +import GHC.Driver.Ppr ( showPpr, showSDoc ) +import GHC.Parser.PostProcess +import GHC.Types.Name +import GHC.Types.Avail ( availName ) +import GHC.Types.Name.Reader +import GHC.Utils.Outputable (Outputable) -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] - -> Maybe (MDoc Name) -processDocStrings dflags gre strs = - case metaDocConcat $ map (processDocStringParas dflags gre) strs of +processDocStrings + :: MonadIO m + => DynFlags + -> Maybe Package + -> GlobalRdrEnv + -> [HsDocString] + -> IfM m (Maybe (MDoc Name)) +processDocStrings dflags pkg gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs + case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing - x -> Just x + MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing + x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name -processDocStringParas dflags gre (HsDocString fs) = - overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) +processDocStringParas + :: MonadIO m + => DynFlags + -> Maybe Package + -> GlobalRdrEnv + -> HsDocString + -> IfM m (MDoc Name) +processDocStringParas dflags pkg gre hds = + overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds)) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name -processDocString dflags gre (HsDocString fs) = - rename dflags gre $ parseString dflags (unpackFS fs) +processDocString + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> HsDocString + -> IfM m (Doc Name) +processDocString dflags gre hds = + processDocStringFromString dflags gre (renderHsDocString hds) -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString - -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) -processModuleHeader dflags gre safety mayStr = do +processDocStringFromString + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> String + -> IfM m (Doc Name) +processDocStringFromString dflags gre hds = + rename dflags gre (parseString dflags hds) + +processModuleHeader + :: MonadIO m + => DynFlags + -> Maybe Package + -> GlobalRdrEnv + -> SafeHaskellMode + -> Maybe HsDocString + -> IfM m (HaddockModInfo Name, Maybe (MDoc Name)) +processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs - (hmi, doc) = parseModuleHeader dflags str - !descr = rename dflags gre <$> hmi_description hmi - hmi' = hmi { hmi_description = descr } - doc' = overDoc (rename dflags gre) doc + Just hds -> do + let str = renderHsDocString hds + (hmi, doc) = parseModuleHeader dflags pkgName str + !descr <- case hmi_description hmi of + Just hmi_descr -> Just <$> rename dflags gre hmi_descr + Nothing -> pure Nothing + let hmi' = hmi { hmi_description = descr } + doc' <- overDocF (rename dflags gre) doc return (hmi', Just doc') let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead - flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) - return (hmi { hmi_safety = Just $ showPpr dflags safety - , hmi_language = language dflags - , hmi_extensions = flags - } , doc) + flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags) + return + (hmi { hmi_safety = Just $ showPpr dflags safety + , hmi_language = language dflags + , hmi_extensions = flags + } + , doc + ) where failure = (emptyHaddockModInfo, Nothing) +traverseSnd :: (Traversable t, Applicative f) => (a -> f b) -> t (x, a) -> f (t (x, b)) +traverseSnd f = traverse (\(x, a) -> + (\b -> (x, b)) <$> f a) + -- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the -- definitions and a parsed comment and we attempt to make sense of -- where the identifiers in the comment point to. We're in effect @@ -82,25 +133,45 @@ -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename + :: MonadIO m + => DynFlags + -> GlobalRdrEnv + -> Doc NsRdrName + -> IfM m (Doc Name) rename dflags gre = rn where + rn :: MonadIO m => Doc NsRdrName -> IfM m (Doc Name) rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) - DocIdentifier x -> do + DocAppend a b -> DocAppend <$> rn a <*> rn b + DocParagraph p -> DocParagraph <$> rn p + DocIdentifier i -> do + let NsRdrName ns x = unwrap i + occ = rdrNameOcc x + isValueName = isDataOcc occ || isVarOcc occ + + let valueNsChoices | isValueName = [x] + | otherwise = [] -- is this ever possible? + typeNsChoices | isValueName = [setRdrNameSpace x tcName] + | otherwise = [x] + -- Generate the choices for the possible kind of thing this - -- is. - let choices = dataTcOccs x - -- Try to look up all the names in the GlobalRdrEnv that match - -- the names. - let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + -- is. We narrow down the possibilities with the namespace (if + -- there is one). + let choices = case ns of + Value -> valueNsChoices + Type -> typeNsChoices + None -> valueNsChoices ++ typeNsChoices - case names of + -- Lookup any GlobalRdrElts that match the choices. + case concatMap (\c -> lookupGRE_RdrName c gre) choices of -- We found no names in the env so we start guessing. [] -> case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) + -- The only way this can happen is if a value namespace was + -- specified on something that cannot be a value. + [] -> invalidValue dflags i + -- There was nothing in the environment so we need to -- pick some default from what's available to us. We -- diverge here from the old way where we would default @@ -109,52 +180,133 @@ -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> outOfScope dflags ns (i $> a) -- There is only one name in the environment that matches so -- use it. - [a] -> DocIdentifier a - -- But when there are multiple names available, default to - -- type constructors: somewhat awfully GHC returns the - -- values in the list positionally. - a:b:_ | isTyConName a -> DocIdentifier a - | otherwise -> DocIdentifier b + [a] -> pure $ DocIdentifier (i $> greMangledName a) - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule str -> DocModule str - DocHyperlink l -> DocHyperlink l - DocPic str -> DocPic str - DocMathInline str -> DocMathInline str - DocMathDisplay str -> DocMathDisplay str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) + -- There are multiple names available. + gres -> ambiguous dflags i gres + DocWarning dw -> DocWarning <$> rn dw + DocEmphasis de -> DocEmphasis <$> rn de + DocBold db -> DocBold <$> rn db + DocMonospaced dm -> DocMonospaced <$> rn dm + DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs + DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs + DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list + DocCodeBlock dcb -> DocCodeBlock <$> rn dcb + DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) + DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l + DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l + DocPic str -> pure (DocPic str) + DocMathInline str -> pure (DocMathInline str) + DocMathDisplay str -> pure (DocMathDisplay str) + DocAName str -> pure (DocAName str) + DocProperty p -> pure (DocProperty p) + DocExamples e -> pure (DocExamples e) + DocEmpty -> pure (DocEmpty) + DocString str -> pure (DocString str) + DocHeader (Header l t) -> DocHeader . Header l <$> rn t + DocTable t -> DocTable <$> traverse rn t + -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently -- we simply monospace the identifier in most cases except when the -- identifier is qualified: if the identifier is qualified then we can --- still try to guess and generate anchors accross modules but the +-- still try to guess and generate anchors across modules but the -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> RdrName -> Doc a -outOfScope dflags x = - case x of - Unqual occ -> monospaced occ - Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) - Orig _ occ -> monospaced occ - Exact name -> monospaced name -- Shouldn't happen since x is out of scope +outOfScope :: MonadIO m => DynFlags -> Namespace -> Wrap RdrName -> IfM m (Doc a) +outOfScope dflags ns x = + case unwrap x of + Unqual occ -> warnAndMonospace (x $> occ) + Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) + Orig _ occ -> warnAndMonospace (x $> occ) + Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope where - monospaced a = DocMonospaced (DocString (showPpr dflags a)) + prefix = + case ns of + Value -> "the value " + Type -> "the type " + None -> "" + + warnAndMonospace :: (MonadIO m, Outputable a) => Wrap a -> IfM m (DocH mod id) + warnAndMonospace a = do + let a' = showWrapped (showPpr dflags) a + + -- If we have already warned for this identifier, don't warn again + firstWarn <- Set.notMember a' <$> gets ifeOutOfScopeNames + when firstWarn $ do + warn $ + "Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway." + modify' (\env -> env { ifeOutOfScopeNames = Set.insert a' (ifeOutOfScopeNames env) }) + + pure (monospaced a') + monospaced = DocMonospaced . DocString + +-- | Handle ambiguous identifiers. +-- +-- Prefers local names primarily and type constructors or class names secondarily. +-- +-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. +ambiguous + :: MonadIO m + => DynFlags + -> Wrap NsRdrName + -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. + -> IfM m (Doc Name) +ambiguous dflags x gres = do + let noChildren = map availName (gresToAvailInfo gres) + dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren + nameStr = showNsRdrName dflags x + msg = "Warning: " ++ nameStr ++ " is ambiguous. It is defined\n" ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++ + " You may be able to disambiguate the identifier by qualifying it or\n" ++ + " by specifying the type/value namespace explicitly.\n" ++ + " Defaulting to the one defined " ++ defnLoc dflt + + -- TODO: Once we have a syntax for namespace qualification (#667) we may also + -- want to emit a warning when an identifier is a data constructor for a type + -- of the same name, but not the only constructor. + -- For example, for @data D = C | D@, someone may want to reference the @D@ + -- constructor. + + -- If we have already warned for this name, do not warn again + firstWarn <- Set.notMember nameStr <$> gets ifeAmbiguousNames + when (length noChildren > 1 && firstWarn) $ do + warn msg + modify' (\env -> env { ifeAmbiguousNames = Set.insert nameStr (ifeAmbiguousNames env) }) + + pure (DocIdentifier (x $> dflt)) + where + isLocalName (nameSrcLoc -> RealSrcLoc {}) = True + isLocalName _ = False + defnLoc = showSDoc dflags . pprNameDefnLoc + +-- | Handle value-namespaced names that cannot be for values. +-- +-- Emits a warning that the value-namespace is invalid on a non-value identifier. +invalidValue :: MonadIO m => DynFlags -> Wrap NsRdrName -> IfM m (Doc a) +invalidValue dflags x = do + let nameStr = showNsRdrName dflags x + + -- If we have already warned for this name, do not warn again + firstWarn <- Set.notMember nameStr <$> gets ifeInvalidValues + when firstWarn $ do + warn $ + "Warning: " ++ nameStr ++ " cannot be value, yet it is\n" ++ + " namespaced as such. Did you mean to specify a type namespace\n" ++ + " instead?" + modify' (\env -> env { ifeInvalidValues = Set.insert nameStr (ifeInvalidValues env) }) + pure (DocMonospaced (DocString (showNsRdrName dflags x))) + +-- | Printable representation of a wrapped and namespaced name +showNsRdrName :: DynFlags -> Wrap NsRdrName -> String +showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident + where + ident = showWrapped (showPpr dflags . rdrName) + prefix = renderNs . namespace . unwrap diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE DeriveFunctor #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader @@ -11,12 +13,12 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus) +import Control.Applicative (Alternative (..)) +import Control.Monad (ap) import Data.Char -import DynFlags +import GHC.Driver.Session import Haddock.Parser import Haddock.Types -import RdrName -- ----------------------------------------------------------------------------- -- Parsing module headers @@ -24,36 +26,47 @@ -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName) -parseModuleHeader dflags str0 = +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) +parseModuleHeader dflags pkgName str0 = let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) + kvs :: [(String, String)] + str1 :: String - (_moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (maintainerOpt,str6) = getKey "Maintainer" str5 - (stabilityOpt,str7) = getKey "Stability" str6 - (portabilityOpt,str8) = getKey "Portability" str7 + (kvs, str1) = maybe ([], str0) id $ runP fields str0 + -- trim whitespaces + trim :: String -> String + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + getKey :: String -> Maybe String + getKey key = fmap trim (lookup key kvs) + + descriptionOpt = getKey "Description" + copyrightOpt = getKey "Copyright" + licenseOpt = getKey "License" + licenceOpt = getKey "Licence" + spdxLicenceOpt = getKey "SPDX-License-Identifier" + maintainerOpt = getKey "Maintainer" + stabilityOpt = getKey "Stability" + portabilityOpt = getKey "Portability" + in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags str8) + }, parseParas dflags pkgName str1) --- | This function is how we read keys. +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- + +-- | The below is a small parser framework how we read keys. -- -- all fields in the header are optional and have the form -- @@ -72,78 +85,105 @@ -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 +-- | 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- +data C = C {-# UNPACK #-} !Int Char - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey _ _ [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str +newtype P a = P { unP :: [C] -> Maybe ([C], a) } + deriving Functor - accept = isFirst || sufficientIndentation || allSpaces +instance Applicative P where + pure x = P $ \s -> Just (s, x) + (<*>) = ap - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False +instance Monad P where + return = pure + m >>= k = P $ \s0 -> do + (s1, x) <- unP m s0 + unP (k x) s1 - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 +instance Alternative P where + empty = P $ \_ -> Nothing + a <|> b = P $ \s -> unP a s <|> unP b s - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') + where + input' = concat + [ zipWith C [0..] l ++ [C (length l) '\n'] + | l <- lines input + ] - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | otherwise = ([],s) +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | otherwise = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of + [] -> 0 + C i _ : _ -> i - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix _ [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | otherwise = Nothing +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> + let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs) + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \s -> case s of + [] -> Nothing + (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) + | otherwise -> Nothing + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \s -> case s of + [] -> Nothing + (C _ c' : cs) | c == c' -> Just (cs, c) + | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where + go xs0@[] = ([], xs0) + go xs0@(x:xs) = case f x of + Just y -> let (ys, zs) = go xs in (y : ys, zs) + Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do + fn <- munch1 $ \_ c -> isAlpha c || c == '-' + skipSpaces + _ <- char ':' + skipSpaces + val <- munch $ \j c -> isSpace c || j > i + return (fn, val) + +fields :: P ([(String, String)], String) +fields = do + skipSpaces + i <- curInd + fs <- many (field i) + r <- rest + return (fs, r) + diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -15,285 +20,437 @@ import Data.Traversable (mapM) +import Haddock.Backends.Hoogle (ppExportD) import Haddock.GhcUtils import Haddock.Types -import Bag (emptyBag) +import GHC.Data.Bag (emptyBag) import GHC hiding (NoLink) -import Name +import GHC.Types.Name +import GHC.Types.Name.Reader (RdrName(Exact)) +import GHC.Builtin.Types (eqTyCon_RDR) import Control.Applicative +import Control.DeepSeq (force) import Control.Monad hiding (mapM) -import Data.List -import qualified Data.Map as Map hiding ( Map ) +import Control.Monad.Reader +import Control.Monad.Writer.CPS +import Data.Foldable (traverse_) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Prelude hiding (mapM) - - -renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface dflags renamingEnv warnings iface = - - -- first create the local env, where every name exported by this module - -- is mapped to itself, and everything else comes from the global renaming - -- env - let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) - where fn env name = Map.insert name (ifaceMod iface) env - - -- rename names in the exported declarations to point to things that - -- are closer to, or maybe even exported by, the current module. - (renamedExportItems, missingNames1) - = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - - (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) +import GHC.Types.Basic ( TopLevelFlag(..) ) - (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) +-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to +-- 'DocName'. +-- +-- What this really boils down to is: for each 'Name', figure out which of the +-- modules that export the name is the preferred place to link to. +-- +-- The renamed output gets written into fields in the Haddock interface record +-- that were previously left empty. +renameInterface + :: DynFlags + -- ^ GHC session dyn flags + -> Map.Map (Maybe String) (Set.Set String) + -- ^ Ignored symbols. A map from module names to unqualified names. Module + -- 'Just M' mapping to name 'f' means that link warnings should not be + -- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to + -- name 'f' means that link warnings should not be generated for any 'f'. + -> LinkEnv + -- ^ Link environment. A map from 'Name' to 'Module', where name 'n' maps to + -- module 'M' if 'M' is the preferred link destination for name 'n'. + -> Bool + -- ^ Are warnings enabled? + -> Bool + -- ^ Is Hoogle output enabled? + -> Interface + -- ^ The interface we are renaming. + -> Ghc Interface + -- ^ The renamed interface. Note that there is nothing really special about + -- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or + -- even pure, depending on the link warnings are reported. +renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do + let (iface', warnedNames) = + runRnM + dflags + mdl + localLinkEnv + warnName + (hoogle && not (OptHide `elem` ifaceOptions iface)) + (renameInterfaceRn iface) + reportMissingLinks mdl warnedNames + return iface' + where + -- The current module + mdl :: Module + mdl = ifaceMod iface - (renamedOrphanInstances, missingNames4) - = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface)) + -- The local link environment, where every name exported by this module is + -- mapped to the module itself, and everything else comes from the global + -- renaming env + localLinkEnv :: LinkEnv + localLinkEnv = foldr f renamingEnv (ifaceVisibleExports iface) + where f name !env = Map.insert name mdl env - (finalModuleDoc, missingNames5) - = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) + -- The function used to determine whether we should warn about a name + -- which we do not find in the renaming environment + warnName name = + -- Warnings must be enabled + warnings - -- 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 - (missingNames1 ++ missingNames2 ++ missingNames3 - ++ missingNames4 ++ missingNames5) + -- Current module must not be hidden from Haddock + && not (OptHide `elem` ifaceOptions iface) - -- filter out certain built in type constructors using their string - -- representation. TODO: use the Name constants from the GHC API. --- strings = filter (`notElem` ["()", "[]", "(->)"]) --- (map pretty missingNames) - strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + -- Must be an external name that is not built-in syntax, not a type + -- variable, and not '~' + && isExternalName name + && not (isBuiltInSyntax name) + && not (isTyVarName name) + && Exact name /= eqTyCon_RDR - in do - -- report things that we couldn't link to. Only do this for non-hidden - -- modules. - unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ - tell ["Warning: " ++ moduleString (ifaceMod iface) ++ - ": could not find link destinations for:\n"++ - unwords (" " : strings) ] + -- Must not be in the set of ignored symbols for the module or the + -- unqualified ignored symbols + && not (getOccString name `Set.member` ignoreSet') + where + -- The set of ignored symbols within the module this name is located + -- in unioned with the set of globally ignored symbols + ignoreSet' :: Set.Set String + ignoreSet' = + Set.union + (Map.findWithDefault Set.empty (Just $ modString name) ignoreSet) + (Map.findWithDefault Set.empty Nothing ignoreSet) - return $ iface { ifaceRnDoc = finalModuleDoc, - ifaceRnDocMap = rnDocMap, - ifaceRnArgMap = rnArgMap, - ifaceRnExportItems = renamedExportItems, - ifaceRnOrphanInstances = renamedOrphanInstances} + modString :: Name -> String + modString = moduleString . nameModule +-- | Output warning messages indicating that the renamer could not find link +-- destinations for the names in the given set as they occur in the given +-- module. +reportMissingLinks :: Module -> Set.Set Name -> Ghc () +reportMissingLinks mdl names + | Set.null names = return () + | otherwise = + liftIO $ do + putStrLn $ "Warning: " ++ moduleString mdl ++ ": could not find link destinations for: " + traverse_ (putStrLn . ("\t- " ++) . qualifiedName) names + where + qualifiedName :: Name -> String + qualifiedName name = moduleString (nameModule name) ++ "." ++ getOccString name -------------------------------------------------------------------------------- -- Monad for renaming --- --- The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. -------------------------------------------------------------------------------- - -newtype RnM a = - RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function - -> (a,[Name]) - } - -instance Monad RnM where - (>>=) = thenRn - return = pure - -instance Functor RnM where - fmap f x = do a <- x; return (f a) - -instance Applicative RnM where - pure = returnRn - (<*>) = ap +-- | A renaming monad which provides 'MonadReader' access to a renaming +-- environment, and 'MonadWriter' access to a 'Set' of names for which link +-- warnings should be generated, based on the renaming environment. +newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a } + deriving newtype (Functor, Applicative, Monad, MonadReader RnMEnv, MonadWriter (Set.Set Name)) -returnRn :: a -> RnM a -returnRn a = RnM (const (a,[])) -thenRn :: RnM a -> (a -> RnM b) -> RnM b -m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of - (b,out2) -> (b,out1++out2)) +-- | The renaming monad environment. Stores the linking environment (mapping +-- names to modules), the link warning predicate, and the current module. +data RnMEnv = RnMEnv + { -- | The linking environment (map from names to modules) + rnLinkEnv :: LinkEnv -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) + -- | Link warning predicate (whether failing to find a link destination + -- for a given name should result in a warning) + , rnWarnName :: (Name -> Bool) -outRn :: Name -> RnM () -outRn name = RnM (const ((),[name])) + -- | The current module + , rnModuleString :: String -lookupRn :: Name -> RnM DocName -lookupRn name = do - lkp <- getLookupRn - case lkp name of - (False,maps_to) -> do outRn name; return maps_to - (True, maps_to) -> return maps_to + -- | Should Hoogle output be generated for this module? + , rnHoogleOutput :: Bool + -- | GHC Session DynFlags, necessary for Hoogle output generation + , rnDynFlags :: DynFlags + } -runRnFM :: LinkEnv -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp +-- | Run the renamer action in a renaming environment built using the given +-- module, link env, and link warning predicate. Returns the renamed value along +-- with a set of 'Name's that were not renamed and should be warned for (i.e. +-- they satisfied the link warning predicate). +runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name) +runRnM dflags mdl linkEnv warnName hoogleOutput rn = + runWriter $ runReaderT (unRnM rn) rnEnv where - lkp n = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mdl -> (True, Documented n mdl) - + rnEnv :: RnMEnv + rnEnv = RnMEnv + { rnLinkEnv = linkEnv + , rnWarnName = warnName + , rnModuleString = moduleString mdl + , rnHoogleOutput = hoogleOutput + , rnDynFlags = dflags + } -------------------------------------------------------------------------------- -- Renaming -------------------------------------------------------------------------------- +-- | Rename an `Interface` in the renaming environment. +renameInterfaceRn :: Interface -> RnM Interface +renameInterfaceRn iface = do + exportItems <- renameExportItems (ifaceExportItems iface) + orphans <- mapM renameDocInstance (ifaceOrphanInstances iface) + finalModDoc <- renameDocumentation (ifaceDoc iface) + pure $! iface + { ifaceRnDoc = finalModDoc -rename :: Name -> RnM DocName -rename = lookupRn + -- The un-renamed export items are not used after renaming + , ifaceRnExportItems = exportItems + , ifaceExportItems = [] + -- The un-renamed orphan instances are not used after renaming + , ifaceRnOrphanInstances = orphans + , ifaceOrphanInstances = [] + } -renameL :: Located Name -> RnM (Located DocName) -renameL = mapM rename +-- | Lookup a 'Name' in the renaming environment. +lookupRn :: Name -> RnM DocName +lookupRn name = RnM $ do + linkEnv <- asks rnLinkEnv + case Map.lookup name linkEnv of + Nothing -> return $ Undocumented name + Just mdl -> return $ Documented name mdl +-- | Rename a 'Name' in the renaming environment. This is very similar to +-- 'lookupRn', but tracks any names not found in the renaming environment if the +-- `rnWarnName` predicate is true. +renameName :: Name -> RnM DocName +renameName name = do + warnName <- asks rnWarnName + docName <- lookupRn name + case docName of + Undocumented _ -> do + when (warnName name) $ + tell $ Set.singleton name + return docName + _ -> return docName -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] +-- | Rename a located 'Name' in the current renaming environment. +renameNameL :: GenLocated l Name -> RnM (GenLocated l DocName) +renameNameL = mapM renameName + +-- | Rename a list of export items in the current renaming environment. +renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem +-- | Rename an 'ExportItem' in the current renaming environment. +renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) +renameExportItem item = case item of + ExportModule mdl -> return (ExportModule mdl) + ExportGroup lev id_ doc -> do + doc' <- renameDoc doc + return (ExportGroup lev id_ doc') + ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do + -- If Hoogle output should be generated, generate it + RnMEnv{..} <- ask + let !hoogleOut = force $ + if rnHoogleOutput then + ppExportD rnDynFlags ed + else + [] + 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 RnExportD + { rnExpDExpD = ExportD decl' pats' doc' subs' instances' fixities' splice + , rnExpDHoogle = hoogleOut + } + ExportNoDecl x subs -> do + x' <- lookupRn x + subs' <- mapM lookupRn subs + return (ExportNoDecl x' subs') + ExportDoc doc -> do + doc' <- renameDoc doc + return (ExportDoc doc') + renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) renameDocForDecl (doc, fnArgsDoc) = (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc - renameDocumentation :: Documentation Name -> RnM (Documentation DocName) renameDocumentation (Documentation mDoc mWarning) = Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning - -renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -renameLDocHsSyn = return - +renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b)) +renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse renameName) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc - -renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) -renameLSigType = renameImplicit renameLType +renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI) +renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty + ; return $ HsValArg ty' } +renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki + ; return $ HsTypeArg l ki' } +renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp -renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) -renameLSigWcType = renameImplicit (renameWc renameLType) +renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) +renameLSigType = mapM renameSigType -renameLKind :: LHsKind Name -> RnM (LHsKind DocName) +renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) +renameLSigWcType = renameWc renameLSigType + +renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) -renameFamilyResultSig (L loc NoSig) - = return (L loc NoSig) -renameFamilyResultSig (L loc (KindSig ki)) +renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) +renameFamilyResultSig (L loc (NoSig _)) + = return (L loc (NoSig noExtField)) +renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig ki')) } -renameFamilyResultSig (L loc (TyVarSig bndr)) + ; return (L loc (KindSig noExtField ki')) } +renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig bndr')) } + ; return (L loc (TyVarSig noExtField bndr')) } -renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) -renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) - = do { lhs' <- renameL lhs - ; rhs' <- mapM renameL rhs - ; return (L loc (InjectivityAnn lhs' rhs')) } +renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) +renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs)) + = do { lhs' <- renameNameL lhs + ; rhs' <- mapM renameNameL rhs + ; return (L loc (InjectivityAnn noExtField lhs' rhs')) } -renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) - -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) + -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType Name -> RnM (HsType DocName) +renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) +renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr) +renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr)) +renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr)) +renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p + +renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of - HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do - tyvars' <- mapM renameLTyVarBndr tyvars - ltype' <- renameLType ltype - return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + HsForAllTy { hst_tele = tele, hst_body = ltype } -> do + tele' <- renameHsForAllTelescope tele + ltype' <- renameLType ltype + return (HsForAllTy { hst_xforall = noAnn + , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n + HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype - HsAppTy a b -> do + HsStarTy _ isUni -> return (HsStarTy noAnn isUni) + + HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy a' b') + return (HsAppTy noAnn a' b') - HsFunTy a b -> do + HsAppKindTy _ a b -> do a' <- renameLType a + b' <- renameLKind b + return (HsAppKindTy noAnn a' b') + + HsFunTy _ w a b -> do + a' <- renameLType a b' <- renameLType b - return (HsFunTy a' b') + w' <- renameArrow w + return (HsFunTy noAnn w' a' b') - HsListTy ty -> return . HsListTy =<< renameLType ty - HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) - HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts - HsOpTy a (L loc op) b -> do - op' <- rename op + HsOpTy _ prom a (L loc op) b -> do + op' <- renameName op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (L loc op') b') + return (HsOpTy noAnn prom a' (L loc op') b') - HsParTy ty -> return . HsParTy =<< renameLType ty + HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty - HsKindSig ty k -> do + HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig ty' k') + return (HsKindSig noAnn ty' k') - HsDocTy ty doc -> do + HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy ty' doc') + return (HsDocTy noAnn ty' doc') - HsTyLit x -> return (HsTyLit x) + HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x)) - HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a - HsCoreTy a -> pure (HsCoreTy a) - HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b - HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a - HsAppsTy _ -> error "renameType: HsAppsTy" + HsRecTy _ a -> HsRecTy noAnn <$> mapM renameConDeclFieldField a + XHsType a -> pure (XHsType a) + HsExplicitListTy _ a b -> HsExplicitListTy noAnn a <$> mapM renameLType b + HsExplicitTupleTy _ b -> HsExplicitTupleTy noAnn <$> mapM renameLType b + HsSpliceTy (HsUntypedSpliceTop _ st) _ -> renameType (unLoc st) + HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice" + HsWildCardTy _ -> pure (HsWildCardTy noAnn) -renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) -renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) +renameTyLit :: HsTyLit GhcRn -> HsTyLit DocNameI +renameTyLit t = case t of + HsNumTy _ v -> HsNumTy noExtField v + HsStrTy _ v -> HsStrTy noExtField v + HsCharTy _ v -> HsCharTy noExtField v + + +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) +renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do + bndrs' <- renameOuterTyVarBndrs bndrs + body' <- renameLType body + pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' } + +renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) +renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } - -- This is rather bogus, but I'm not sure what else to do + ; return (HsQTvs { hsq_ext = noExtField + , hsq_explicit = tvs' }) } -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar (L l n))) - = do { n' <- rename n - ; return (L loc (UserTyVar (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) - = do { n' <- rename n +renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) +renameHsForAllTelescope tele = case tele of + HsForAllVis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllVis noExtField bndrs' + HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs + pure $ HsForAllInvis noExtField bndrs' + +renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) +renameLTyVarBndr (L loc (UserTyVar _ fl (L l n))) + = do { n' <- renameName n + ; return (L loc (UserTyVar noExtField fl (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind)) + = do { n' <- renameName n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar (L lv n') kind')) } + ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) +renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name - -renameInstHead :: InstHead Name -> RnM (InstHead DocName) +renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do - cname <- rename ihdClsName - kinds <- mapM renameType ihdKinds + cname <- renameName ihdClsName types <- mapM renameType ihdTypes itype <- case ihdInstType of ClassInst { .. } -> ClassInst @@ -305,299 +462,358 @@ DataInst dd -> DataInst <$> renameTyClD dd return InstHead { ihdClsName = cname - , ihdKinds = kinds , ihdTypes = types , ihdInstType = itype } -renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) +renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d +renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)] +renamePats = mapM + (\(d,doc) -> do { d' <- renameDecl d + ; doc' <- renameDocForDecl doc + ; return (d',doc')}) -renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of - TyClD d -> do + TyClD _ d -> do d' <- renameTyClD d - return (TyClD d') - SigD s -> do + return (TyClD noExtField d') + SigD _ s -> do s' <- renameSig s - return (SigD s') - ForD d -> do + return (SigD noExtField s') + ForD _ d -> do d' <- renameForD d - return (ForD d') - InstD d -> do + return (ForD noExtField d') + InstD _ d -> do d' <- renameInstD d - return (InstD d') + return (InstD noExtField d') + DerivD _ d -> do + d' <- renameDerivD d + return (DerivD noExtField d') _ -> error "renameDecl" -renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) -renameLThing fn (L loc x) = return . L loc =<< fn x +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI)) +renameLThing fn (L loc x) = return . L (locA loc) =<< fn x -renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) +renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFam = decl' }) + return (FamDecl { tcdFExt = noExtField, tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do - lname' <- renameL lname + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do + lname' <- renameNameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) + return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdRhs = rhs' }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do - lname' <- renameL lname + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do + lname' <- renameNameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) - ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars + ClassDecl { tcdLayout = layout + , tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do - lcontext' <- renameLContext lcontext - lname' <- renameL lname + lcontext' <- traverse renameLContext lcontext + lname' <- renameNameL lname ltyvars' <- renameLHsQTyVars ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats - at_defs' <- mapM renameLTyFamDefltEqn at_defs + at_defs' <- mapM (mapM renameTyFamDefltD) at_defs -- we don't need the default methods or the already collected doc entities - return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' + return (ClassDecl { tcdCExt = noExtField + , tcdLayout = renameLayoutInfo layout + , tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' + , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [] }) where - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename (map unLoc xs) - ys' <- mapM rename (map unLoc ys) - return (L loc (map noLoc xs', map noLoc ys')) + renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI) + renameLFunDep (L loc (FunDep _ xs ys)) = do + xs' <- mapM renameName (map unLoc xs) + ys' <- mapM renameName (map unLoc ys) + return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) - renameLSig (L loc sig) = return . L loc =<< renameSig sig + renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameLayoutInfo :: LayoutInfo GhcRn -> LayoutInfo DocNameI +renameLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb +renameLayoutInfo (VirtualBraces n) = VirtualBraces n +renameLayoutInfo NoLayoutInfo = NoLayoutInfo + +renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdResultSig = result + , fdTyVars = ltyvars + , fdFixity = fixity + , fdResultSig = result , fdInjectivityAnn = injectivity }) = do info' <- renameFamilyInfo info - lname' <- renameL lname + lname' <- renameNameL lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdResultSig = result' + return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel + , fdLName = lname' + , fdTyVars = ltyvars' + , fdFixity = fixity + , fdResultSig = result' , fdInjectivityAnn = injectivity' }) -renamePseudoFamilyDecl :: PseudoFamilyDecl Name - -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn + -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo - <*> renameL pfdLName + <*> renameNameL pfdLName <*> mapM renameLType pfdTyVars <*> renameFamilyResultSig pfdKindSig -renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) +renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns + = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) -renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType +renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) +renameDataDefn (HsDataDefn { dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do - lcontext' <- renameLContext lcontext + lcontext' <- traverse renameLContext lcontext k' <- renameMaybeLKind k - cons' <- mapM (mapM renameCon) cons + cons' <- mapM (mapMA renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType - , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) + return (HsDataDefn { dd_ext = noExtField + , dd_ctxt = lcontext', dd_cType = cType + , dd_kindSig = k', dd_cons = cons' + , dd_derivs = [] }) -renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_doc = mbldoc }) = do - lname' <- renameL lname - ltyvars' <- traverse renameLHsQTyVars ltyvars +renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) +renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars + , con_mb_cxt = lcontext, con_args = details + , con_doc = mbldoc + , con_forall = forall_ }) = do + lname' <- renameNameL lname + ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext - details' <- renameDetails details + details' <- renameH98Details details + mbldoc' <- mapM (renameLDocHsSyn) mbldoc + return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' + , con_mb_cxt = lcontext' + , con_forall = forall_ -- Remove when #18311 is fixed + , con_args = details', con_doc = mbldoc' }) + +renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs + , con_dcolon = dcol + , con_mb_cxt = lcontext, con_g_args = details + , con_res_ty = res_ty + , con_doc = mbldoc } = do + lnames' <- mapM renameNameL lnames + bndrs' <- mapM renameOuterTyVarBndrs bndrs + lcontext' <- traverse renameLContext lcontext + details' <- renameGADTDetails details + res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_doc = mbldoc' }) + return (ConDeclGADT + { con_g_ext = noExtField, con_names = lnames' + , con_dcolon = dcol, con_bndrs = bndrs' + , con_mb_cxt = lcontext', con_g_args = details' + , con_res_ty = res_ty', con_doc = mbldoc' }) - where - renameDetails (RecCon (L l fields)) = do - fields' <- mapM renameConDeclFieldField fields - return (RecCon (L l fields')) - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') +renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) + -> RnM (HsScaled DocNameI (LHsType DocNameI)) +renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameCon decl@(ConDeclGADT { con_names = lnames - , con_type = lty - , con_doc = mbldoc }) = do - lnames' <- mapM renameL lnames - lty' <- renameLSigType lty - mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames' - , con_type = lty', con_doc = mbldoc' }) +renameH98Details :: HsConDeclH98Details GhcRn + -> RnM (HsConDeclH98Details DocNameI) +renameH98Details (RecCon (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon (L (locA l) fields')) +renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps +renameH98Details (InfixCon a b) = do + a' <- renameHsScaled a + b' <- renameHsScaled b + return (InfixCon a' b') -renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) -renameConDeclFieldField (L l (ConDeclField names t doc)) = do +renameGADTDetails :: HsConDeclGADTDetails GhcRn + -> RnM (HsConDeclGADTDetails DocNameI) +renameGADTDetails (RecConGADT (L l fields) arr) = do + fields' <- mapM renameConDeclFieldField fields + return (RecConGADT (L (locA l) fields') arr) +renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps + +renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) +renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField names' t' doc') + return $ L (locA l) (ConDeclField noExtField names' t' doc') -renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) -renameLFieldOcc (L l (FieldOcc lbl sel)) = do - sel' <- rename sel - return $ L l (FieldOcc lbl sel') +renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) +renameLFieldOcc (L l (FieldOcc sel lbl)) = do + sel' <- renameName sel + return $ L l (FieldOcc sel' lbl) -renameSig :: Sig Name -> RnM (Sig DocName) +renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of - TypeSig lnames ltype -> do - lnames' <- mapM renameL lnames + TypeSig _ lnames ltype -> do + lnames' <- mapM renameNameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig lnames' ltype') - ClassOpSig is_default lnames sig_ty -> do - lnames' <- mapM renameL lnames + return (TypeSig noExtField lnames' ltype') + ClassOpSig _ is_default lnames sig_ty -> do + lnames' <- mapM renameNameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig is_default lnames' ltype') - PatSynSig lname sig_ty -> do - lname' <- renameL lname + return (ClassOpSig noExtField is_default lnames' ltype') + PatSynSig _ lnames sig_ty -> do + lnames' <- mapM renameNameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig lname' sig_ty' - FixSig (FixitySig lnames fixity) -> do - lnames' <- mapM renameL lnames - return $ FixSig (FixitySig lnames' fixity) - MinimalSig src (L l s) -> do - s' <- traverse renameL s - return $ MinimalSig src (L l s') + return $ PatSynSig noExtField lnames' sig_ty' + FixSig _ (FixitySig _ lnames fixity) -> do + lnames' <- mapM renameNameL lnames + return $ FixSig noExtField (FixitySig noExtField lnames' fixity) + MinimalSig _ (L l s) -> do + s' <- traverse (traverse lookupRn) s + return $ MinimalSig noExtField (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) -renameForD (ForeignImport lname ltype co x) = do - lname' <- renameL lname +renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) +renameForD (ForeignImport _ lname ltype x) = do + lname' <- renameNameL lname ltype' <- renameLSigType ltype - return (ForeignImport lname' ltype' co x) -renameForD (ForeignExport lname ltype co x) = do - lname' <- renameL lname + return (ForeignImport noExtField lname' ltype' (renameForI x)) +renameForD (ForeignExport _ lname ltype x) = do + lname' <- renameNameL lname ltype' <- renameLSigType ltype - return (ForeignExport lname' ltype' co x) + return (ForeignExport noExtField lname' ltype' (renameForE x)) +renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI +renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec -renameInstD :: InstDecl Name -> RnM (InstDecl DocName) +renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI +renameForE (CExport _ spec) = CExport noExtField spec + + +renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExtField, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExtField, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_inst = d' }) + return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' }) -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) +renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) +renameDerivD (DerivDecl { deriv_type = ty + , deriv_strategy = strat + , deriv_overlap_mode = omode }) = do + ty' <- renameLSigWcType ty + strat' <- mapM (mapM renameDerivStrategy) strat + return (DerivDecl { deriv_ext = noExtField + , deriv_type = ty' + , deriv_strategy = strat' + , deriv_overlap_mode = omode }) + +renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) +renameDerivStrategy (StockStrategy a) = pure (StockStrategy a) +renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a) +renameDerivStrategy (NewtypeStrategy a) = pure (NewtypeStrategy a) +renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty + +renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExtField, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) +renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn' <- renameLTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' - , tfid_fvs = placeHolderNames }) } + = do { eqn' <- renameTyFamInstEqn eqn + ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) } -renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats +renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) +renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) + = do { tc' <- renameNameL tc + ; bndrs' <- renameOuterTyVarBndrs bndrs + ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = pats' - , tfe_rhs = rhs' })) } + ; return (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } -renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) -renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; tvs' <- renameLHsQTyVars tvs - ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = tvs' - , tfe_rhs = rhs' })) } +renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) +renameTyFamDefltD = renameTyFamInstD -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn }) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats = pats' - , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) +renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) + = do { eqn' <- rename_data_fam_eqn eqn + ; return (DataFamInstDecl { dfid_eqn = eqn' }) } + where + rename_data_fam_eqn + :: FamEqn GhcRn (HsDataDefn GhcRn) + -> RnM (FamEqn DocNameI (HsDataDefn DocNameI)) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = defn }) + = do { tc' <- renameNameL tc + ; bndrs' <- renameOuterTyVarBndrs bndrs + ; pats' <- mapM renameLTypeArg pats + ; defn' <- renameDataDefn defn + ; return (FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs Name in_thing - -> RnM (HsImplicitBndrs DocName out_thing) -renameImplicit rn_thing (HsIB { hsib_body = thing }) - = do { thing' <- rn_thing thing - ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder }) } +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> RnM (HsOuterTyVarBndrs flag DocNameI) +renameOuterTyVarBndrs (HsOuterImplicit{}) = + pure $ HsOuterImplicit{hso_ximplicit = noExtField} +renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) = + HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs renameWc :: (in_thing -> RnM out_thing) - -> HsWildCardBndrs Name in_thing - -> RnM (HsWildCardBndrs DocName out_thing) + -> HsWildCardBndrs GhcRn in_thing + -> RnM (HsWildCardBndrs DocNameI out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) } + , hswc_ext = noExtField }) } -renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) -renameDocInstance (inst, idoc, L l n) = do +renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) +renameDocInstance (inst, idoc, L l n, m) = do inst' <- renameInstHead inst - n' <- rename n + n' <- renameName n idoc' <- mapM renameDoc idoc - return (inst', idoc',L l n') - -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -renameExportItem item = case item of - ExportModule mdl -> return (ExportModule mdl) - ExportGroup lev id_ doc -> do - doc' <- renameDoc doc - return (ExportGroup lev id_ doc') - ExportDecl decl doc subs instances fixities splice -> do - decl' <- renameLDecl decl - 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) - ExportNoDecl x subs -> do - x' <- lookupRn x - subs' <- mapM lookupRn subs - return (ExportNoDecl x' subs') - ExportDoc doc -> do - doc' <- renameDoc doc - return (ExportDoc doc') - + return (inst', idoc', L l n', m) renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) renameSub (n,doc) = do - n' <- rename n + n' <- renameName n doc' <- renameDocForDecl doc return (n', doc') diff --git a/src/Haddock/Interface/Specialize.hs b/src/Haddock/Interface/Specialize.hs --- a/src/Haddock/Interface/Specialize.hs +++ b/src/Haddock/Interface/Specialize.hs @@ -1,23 +1,26 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} - +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize ( specializeInstHead ) where +import Haddock.GhcUtils ( hsTyVarBndrName ) import Haddock.Syb import Haddock.Types import GHC -import Name -import FastString +import GHC.Types.Name +import GHC.Data.FastString +import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) import Control.Monad -import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.Data @@ -28,73 +31,62 @@ import Data.Set (Set) import qualified Data.Set as Set - --- | Instantiate all occurrences of given name with particular type. -specialize :: (Eq name, Typeable name) - => Data a - => name -> HsType name -> a -> a -specialize name details = - everywhere $ mkT step +-- | Instantiate all occurrences of given names with corresponding types. +specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a +specialize specs = go spec_map0 where - step (HsTyVar (L _ name')) | name == name' = details - step typ = typ + go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x + go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map + strip_kind_sig :: HsType GhcRn -> HsType GhcRn + strip_kind_sig (HsKindSig _ (L _ t) _) = t + strip_kind_sig typ = typ --- | Instantiate all occurrences of given names with corresponding types. --- --- It is just a convenience function wrapping 'specialize' that supports more --- that one specialization. -specialize' :: (Eq name, Typeable name) - => Data a - => [(name, HsType name)] -> a -> a -specialize' = flip $ foldr (uncurry specialize) + specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn + specialize_ty_var spec_map (HsTyVar _ _ (L _ name')) + | Just t <- Map.lookup name' spec_map = t + specialize_ty_var _ typ = typ + -- This is a tricky recursive definition. By adding in the specializations + -- one by one, we should avoid infinite loops. + spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs +{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-} + -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Eq name, DataId name) - => Data a - => LHsQTyVars name -> [HsType name] - -> a -> a -specializeTyVarBndrs bndrs typs = - specialize' $ zip bndrs' typs +specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a +specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where - bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar (L _ name)) = name - bname (KindedTyVar (L _ name) _) = name + bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs -specializePseudoFamilyDecl :: (Eq name, DataId name) - => LHsQTyVars name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name -specializePseudoFamilyDecl bndrs typs decl = - decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) } - where - specializeTyVars = specializeTyVarBndrs bndrs typs +specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> PseudoFamilyDecl GhcRn + -> PseudoFamilyDecl GhcRn +specializePseudoFamilyDecl bndrs typs decl = + decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)} -specializeSig :: forall name . (Eq name, DataId name, SetName name) - => LHsQTyVars name -> [HsType name] - -> Sig name - -> Sig name -specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}}) +specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> Sig GhcRn + -> Sig GhcRn +specializeSig bndrs typs (TypeSig _ lnames typ) = + TypeSig noAnn lnames (typ {hswc_body = noLocA typ'}) where - true_type :: HsType name - true_type = unLoc (hswc_body (hsib_body typ)) - typ' :: HsType name - typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type - fv = foldr Set.union Set.empty . map freeVariables $ typs + true_type :: HsSigType GhcRn + true_type = unLoc (dropWildCards typ) + typ' :: HsSigType GhcRn + typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type + fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Eq name, DataId name, SetName name) - => InstHead name -> InstHead name +specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } where @@ -113,45 +105,36 @@ -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing name, DataId name) - => HsType name -> HsType name -sugar = - everywhere $ mkT step - where - step :: HsType name -> HsType name - step = sugarOperators . sugarTuples . sugarLists - +sugar :: HsType GhcRn -> HsType GhcRn +sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing name => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp - where - name' = getName name - strName = occNameString . nameOccName $ name' +sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) + | getName name == listTyConName = HsListTy noAnn ltyp sugarLists typ = typ -sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ = aux [] typ where - aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp - aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy _ (L _ typ')) = aux apps typ' + aux apps (HsTyVar _ _ (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps where name' = getName name - strName = occNameString . nameOccName $ name' + strName = getOccString name suitable = case parseTupleArity strName of Just arity -> arity == length apps Nothing -> False aux _ _ = typ -sugarOperators :: NamedThing name => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb) - | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb +sugarOperators :: HsType GhcRn -> HsType GhcRn +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb) + | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb + | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb where name' = getName name sugarOperators typ = typ @@ -193,19 +176,25 @@ -- not converted to 'String' or alike to avoid new allocations. Additionally, -- since it is stored mostly in 'Set', fast comparison of 'FastString' is also -- quite nice. -type NameRep = FastString +newtype NameRep + = NameRep FastString + deriving (Eq) +instance Ord NameRep where + compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2 + + getNameRep :: NamedThing name => name -> NameRep -getNameRep = occNameFS . getOccName +getNameRep = NameRep . getOccFS nameRepString :: NameRep -> String -nameRepString = unpackFS +nameRepString (NameRep fs) = unpackFS fs stringNameRep :: String -> NameRep -stringNameRep = mkFastString +stringNameRep = NameRep . mkFastString setInternalNameRep :: SetName name => NameRep -> name -> name -setInternalNameRep = setInternalOccName . mkVarOccFS +setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs) setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name = @@ -215,22 +204,39 @@ nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname) --- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep -freeVariables = - everythingWithState Set.empty Set.union query +-- | Compute set of free variables of a given 'HsType'. +freeVariablesType :: HsType GhcRn -> Set Name +freeVariablesType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType) + +-- | Compute set of free variables of a given 'HsType'. +freeVariablesSigType :: HsSigType GhcRn -> Set Name +freeVariablesSigType = + everythingWithState Set.empty Set.union + (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType) + +queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name) +queryType term ctx = case term of + HsForAllTy _ tele _ -> + (Set.empty, Set.union ctx (teleNames tele)) + HsTyVar _ _ (L _ name) + | getName name `Set.member` ctx -> (Set.empty, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) + _ -> (Set.empty, ctx) where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy bndrs _) -> - (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar (L _ name)) - | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) - _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + teleNames :: HsForAllTelescope GhcRn -> Set Name + teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs + teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs +querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name) +querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx = + (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name +bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + + -- | Make given type visually unambiguous. -- -- After applying 'specialize' method, some free type variables may become @@ -238,140 +244,140 @@ -- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something --- like @(a -> c) -> b@). -rename :: SetName name => Set NameRep -> HsType name -> HsType name -rename fv typ = runReader (renameType typ) $ RenameEnv - { rneFV = fv - , rneCtx = Map.empty - } - +-- like @(a -> b0) -> b@). +rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn +rename fv typ = evalState (renameSigType typ) env + where + env = RenameEnv + { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv + , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ + , rneCtx = Map.empty + } + mkPair name = (getNameRep name, name) -- | Renaming monad. -type Rename name = Reader (RenameEnv name) - --- | Binding generation monad. -type Rebind name = State (RenameEnv name) +type Rename name = State (RenameEnv name) data RenameEnv name = RenameEnv - { rneFV :: Set NameRep - , rneCtx :: Map Name name - } + { rneHeadFVs :: Map NameRep Name + , rneSigFVs :: Set NameRep + , rneCtx :: Map Name name + } -renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> - HsForAllTy - <$> pure bndrs' +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn) +renameSigType (HsSig x bndrs body) = + HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body + +renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn + -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn) +renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) = + HsOuterImplicit <$> mapM renameName imp_tvs +renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = + HsOuterExplicit x <$> mapM renameLBinder exp_bndrs + +renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) +renameType (HsForAllTy x tele lt) = + HsForAllTy x + <$> renameForAllTelescope tele <*> renameLType lt -renameType (HsQualTy lctxt lt) = - HsQualTy - <$> located renameContext lctxt +renameType (HsQualTy x lctxt lt) = + HsQualTy x + <$> renameLContext lctxt <*> renameLType lt -renameType (HsTyVar name) = HsTyVar <$> located renameName name -renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la -renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr -renameType (HsListTy lt) = HsListTy <$> renameLType lt -renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt -renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt -renameType (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb -renameType (HsParTy lt) = HsParTy <$> renameLType lt -renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt -renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb -renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name +renameType t@(HsStarTy _ _) = pure t +renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la +renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk +renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr +renameType (HsListTy x lt) = HsListTy x <$> renameLType lt +renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt +renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt +renameType (HsOpTy x prom la lop lb) = + HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb +renameType (HsParTy x lt) = HsParTy x <$> renameLType lt +renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt +renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc -renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt -renameType t@(HsRecTy _) = pure t -renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ph ltys) = - HsExplicitListTy ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t +renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc +renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt +renameType t@(HsRecTy _ _) = pure t +renameType t@(XHsType _) = pure t +renameType (HsExplicitListTy x ip ltys) = + HsExplicitListTy x ip <$> renameLTypes ltys +renameType (HsExplicitTupleTy x ltys) = + HsExplicitTupleTy x <$> renameLTypes ltys +renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) -renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" +renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) +renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p +renameHsArrow mult = pure mult -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) + +renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType +renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn) +renameLKind = renameLType -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType +renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn) +renameLContext (L l ctxt) = do + ctxt' <- renameContext ctxt + return (L l ctxt') -renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -{- -renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) -renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname --} +renameForAllTelescope :: HsForAllTelescope GhcRn + -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn) +renameForAllTelescope (HsForAllVis x bndrs) = + HsForAllVis x <$> mapM renameLBinder bndrs +renameForAllTelescope (HsForAllInvis x bndrs) = + HsForAllInvis x <$> mapM renameLBinder bndrs +renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) +renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname +renameBinder (KindedTyVar x fl lname lkind) = + KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind +renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) +renameLBinder = located renameBinder + +-- | Core renaming logic. renameName :: SetName name => name -> Rename name name renameName name = do - RenameEnv { rneCtx = ctx } <- ask - pure $ fromMaybe name (Map.lookup (getName name) ctx) - - -rebind :: SetName name - => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) - -> Rename name a -rebind lbndrs action = do - (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask - local (const env') (action lbndrs') - - -rebindLTyVarBndrs :: SetName name - => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] -rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs - - -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar (L l name)) = - UserTyVar . L l <$> rebindName name -rebindTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located rebindName name <*> pure kinds - - -rebindName :: SetName name => name -> Rebind name name -rebindName name = do RenameEnv { .. } <- get - taken <- takenNames case Map.lookup (getName name) rneCtx of - Just name' -> pure name' - Nothing | getNameRep name `Set.member` taken -> freshName name - Nothing -> reuseName name + Nothing + | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs + , headTv /= getName name -> freshName name + Just name' -> return name' + _ -> return name -- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rebind name name +freshName :: SetName name => name -> Rename name name freshName name = do - env@RenameEnv { .. } <- get taken <- takenNames let name' = setInternalNameRep (findFreshName taken rep) name - put $ env { rneCtx = Map.insert nname name' rneCtx } + modify $ \rne -> rne + { rneCtx = Map.insert (getName name) name' (rneCtx rne) } return name' where nname = getName name rep = getNameRep nname -reuseName :: SetName name => name -> Rebind name name -reuseName name = do - env@RenameEnv { .. } <- get - put $ env { rneCtx = Map.insert (getName name) name rneCtx } - return name - - -takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames :: NamedThing name => Rename name (Set NameRep) takenNames = do RenameEnv { .. } <- get - return $ Set.union rneFV (ctxElems rneCtx) + return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx] where + headReps = Set.fromList . Map.keys ctxElems = Set.fromList . map getNameRep . Map.elems @@ -383,24 +389,19 @@ alternativeNames :: NameRep -> [NameRep] -alternativeNames name - | [_] <- nameRepString name = letterNames ++ alternativeNames' name - where - letterNames = map (stringNameRep . pure) ['a'..'z'] -alternativeNames name = alternativeNames' name - - -alternativeNames' :: NameRep -> [NameRep] -alternativeNames' name = +alternativeNames name = [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] where str = nameRepString name -located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b) located f (L loc e) = L loc <$> f e +locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b) +locatedN f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> name -tyVarName (UserTyVar name) = unLoc name -tyVarName (KindedTyVar (L _ name) _) = name + +tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn +tyVarName (UserTyVar _ _ name) = unLoc name +tyVarName (KindedTyVar _ _ (L _ name) _) = name diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -14,59 +16,99 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( - InterfaceFile(..), ifUnitId, ifModule, - readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, - writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility + InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule, + PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo, + readInterfaceFile, writeInterfaceFile, + freshNameCache, + binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where import Haddock.Types -import Haddock.Utils hiding (out) -import Control.Monad -import Data.Array import Data.IORef -import Data.List import qualified Data.Map as Map import Data.Map (Map) +import Data.Version import Data.Word +import Text.ParserCombinators.ReadP (readP_to_S) -import BinIface (getSymtabName, getDictFastString) -import Binary -import FastMutInt -import FastString +import GHC.Iface.Binary (getWithUserData, putSymbolTable) +import GHC.Unit.State +import GHC.Utils.Binary +import GHC.Data.FastMutInt +import GHC.Data.FastString import GHC hiding (NoLink) -import GhcMonad (withSession) -import HscTypes -import IfaceEnv -import Name -import UniqFM -import UniqSupply -import Unique +import GHC.Types.Name.Cache +import GHC.Types.Unique.FM +import GHC.Types.Unique +import Haddock.Options (Visibility (..)) data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv, + -- | Package meta data. Currently it only consist of a package name, which + -- is not read from the interface file, but inferred from its name. + -- + -- issue # + ifPackageInfo :: PackageInfo, ifInstalledIfaces :: [InstalledInterface] } +data PackageInfo = PackageInfo { + piPackageName :: PackageName, + piPackageVersion :: Data.Version.Version +} +ppPackageInfo :: PackageInfo -> String +ppPackageInfo (PackageInfo name version) | version == makeVersion [] + = unpackFS (unPackageName name) +ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version + +data PackageInterfaces = PackageInterfaces { + piPackageInfo :: PackageInfo, + piVisibility :: Visibility, + piInstalledInterfaces :: [InstalledInterface] +} + +mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces +mkPackageInterfaces piVisibility + InterfaceFile { ifPackageInfo + , ifInstalledIfaces + } = + PackageInterfaces { piPackageInfo = ifPackageInfo + , piVisibility + , piInstalledInterfaces = ifInstalledIfaces + } + ifModule :: InterfaceFile -> Module ifModule if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" iface:_ -> instMod iface -ifUnitId :: InterfaceFile -> UnitId +ifUnitId :: InterfaceFile -> Unit ifUnitId if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile" - iface:_ -> moduleUnitId $ instMod iface + iface:_ -> moduleUnit $ instMod iface binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface +-- Note [The DocModule story] +-- +-- Breaking changes to the DocH type result in Haddock being unable to read +-- existing interfaces. This is especially painful for interfaces shipped +-- with GHC distributions since there is no easy way to regenerate them! +-- +-- PR #1315 introduced a breaking change to the DocModule constructor. To +-- maintain backward compatibility we +-- +-- Parse the old DocModule constructor format (tag 5) and parse the contained +-- string into a proper ModLink structure. When writing interfaces we exclusively +-- use the new DocModule format (tag 24) -- IMPORTANT: Since datatypes in the GHC API might change between major -- versions, and because we store GHC datatypes in our interface files, we need @@ -81,8 +123,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 801) -binaryInterfaceVersion = 28 +#if MIN_VERSION_ghc(9,6,0) && !MIN_VERSION_ghc(9,7,0) +binaryInterfaceVersion = 42 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -110,14 +152,12 @@ put_ bh0 symtab_p_p -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 + symtab_next <- newFastMutInt 0 symtab_map <- newIORef emptyUFM let bin_symtab = BinSymbolTable { bin_symtab_next = symtab_next, bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 + dict_next_ref <- newFastMutInt 0 dict_map_ref <- newIORef emptyUFM let bin_dict = BinDictionary { bin_dict_next = dict_next_ref, @@ -125,8 +165,9 @@ -- put the main thing let bh = setUserData bh0 $ newWriteState (putName bin_symtab) + (putName bin_symtab) (putFastString bin_dict) - put_ bh iface + putInterfaceFile_ bh iface -- write the symtab pointer at the front of the file symtab_p <- tellBin bh @@ -153,101 +194,31 @@ return () -type NameCacheAccessor m = (m NameCache, NameCache -> m ()) - - -nameCacheFromGhc :: NameCacheAccessor Ghc -nameCacheFromGhc = ( read_from_session , write_to_session ) - where - read_from_session = do - ref <- withSession (return . hsc_NC) - liftIO $ readIORef ref - write_to_session nc' = do - ref <- withSession (return . hsc_NC) - liftIO $ writeIORef ref nc' - - -freshNameCache :: NameCacheAccessor IO -freshNameCache = ( create_fresh_nc , \_ -> return () ) - where - create_fresh_nc = do - u <- mkSplitUniqSupply 'a' -- ?? - return (initNameCache u []) - +freshNameCache :: IO NameCache +freshNameCache = initNameCache 'a' -- ?? + [] -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. -- -- This function can be called in two ways. Within a GHC session it will -- update the use and update the session's name cache. Outside a GHC session --- a new empty name cache is used. The function is therefore generic in the --- monad being used. The exact monad is whichever monad the first --- argument, the getter and setter of the name cache, requires. --- -readInterfaceFile :: forall m. - MonadIO m - => NameCacheAccessor m +-- a new empty name cache is used. +readInterfaceFile :: NameCache -> FilePath - -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do - bh0 <- liftIO $ readBinMem filename - - magic <- liftIO $ get bh0 - version <- liftIO $ get bh0 - - case () of - _ | magic /= binaryInterfaceMagic -> return . Left $ - "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ - "Interface file is of wrong version: " ++ filename - | otherwise -> with_name_cache $ \update_nc -> do - - dict <- get_dictionary bh0 - - -- read the symbol table so we are capable of reading the actual data - bh1 <- do - let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab <- update_nc (get_symbol_table bh1) - return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) - (getDictFastString dict) - - -- load the actual data - iface <- liftIO $ get bh1 - return (Right iface) - where - with_name_cache :: forall a. - ((forall n b. MonadIO n - => (NameCache -> n (NameCache, b)) - -> n b) - -> m a) - -> m a - with_name_cache act = do - nc_var <- get_name_cache >>= (liftIO . newIORef) - x <- act $ \f -> do - nc <- liftIO $ readIORef nc_var - (nc', x) <- f nc - liftIO $ writeIORef nc_var nc' - return x - liftIO (readIORef nc_var) >>= set_name_cache - return x - - get_dictionary bin_handle = liftIO $ do - dict_p <- get bin_handle - data_p <- tellBin bin_handle - seekBin bin_handle dict_p - dict <- getDictionary bin_handle - seekBin bin_handle data_p - return dict - - get_symbol_table bh1 theNC = liftIO $ do - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 theNC - seekBin bh1 data_p' - return (nc', symtab) + -> Bool -- ^ Disable version check. Can cause runtime crash. + -> IO (Either String InterfaceFile) +readInterfaceFile name_cache filename bypass_checks = do + bh <- readBinMem filename + magic <- get bh + if magic /= binaryInterfaceMagic + then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename + else do + version <- get bh + if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility) + then return . Left $ "Interface file is of wrong version: " ++ filename + else Right <$> getWithUserData name_cache bh ------------------------------------------------------------------------------- -- * Symbol table @@ -272,7 +243,7 @@ data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- The next index to use - bin_symtab_map :: !(IORef (UniqFM (Int,Name))) + bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) -- indexed by Name } @@ -282,72 +253,22 @@ bin_dict_map = out_r} bh f = do out <- readIORef out_r - let unique = getUnique f - case lookupUFM out unique of + let !unique = getUnique f + case lookupUFM_Directly out unique of Just (j, _) -> put_ bh (fromIntegral j :: Word32) Nothing -> do j <- readFastMutInt j_r put_ bh (fromIntegral j :: Word32) writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) + writeIORef out_r $! addToUFM_Directly out unique (j, f) data BinDictionary = BinDictionary { bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM (Int,FastString))) + bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString } - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (eltsUFM symtab)) - mapM_ (\n -> serialiseName bh n symtab) names - - -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) -getSymbolTable bh namecache = do - sz <- get bh - od_names <- replicateM sz (get bh) - let arr = listArray (0,sz-1) names - (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names - return (namecache', arr) - - -type OnDiskName = (UnitId, ModuleName, OccName) - - -fromOnDiskName - :: Array Int Name - -> NameCache - -> OnDiskName - -> (NameCache, Name) -fromOnDiskName _ nc (pid, mod_name, occ) = - let - modu = mkModule pid mod_name - cache = nsNames nc - in - case lookupOrigNameCache cache modu occ of - Just name -> (nc, name) - Nothing -> - let - us = nsUniqs nc - u = uniqFromSupply us - name = mkExternalName u modu occ noSrcSpan - new_cache = extendNameCache cache modu occ name - in - case splitUniqSupply us of { (us',_) -> - ( nc{ nsUniqs = us', nsNames = new_cache }, name ) - } - - -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () -serialiseName bh name _ = do - let modu = nameModule name - put_ bh (moduleUnitId modu, moduleName modu, nameOccName name) - - ------------------------------------------------------------------------------- -- * GhcBinary instances ------------------------------------------------------------------------------- @@ -357,44 +278,60 @@ put_ bh m = put_ bh (Map.toList m) get bh = fmap (Map.fromList) (get bh) +instance Binary PackageInfo where + put_ bh PackageInfo { piPackageName, piPackageVersion } = do + put_ bh (unPackageName piPackageName) + put_ bh (showVersion piPackageVersion) + get bh = do + name <- PackageName <$> get bh + versionString <- get bh + let version = case readP_to_S parseVersion versionString of + [] -> makeVersion [] + vs -> fst (last vs) + return $ PackageInfo name version instance Binary InterfaceFile where - put_ bh (InterfaceFile env ifaces) = do + put_ bh (InterfaceFile env info ifaces) = do put_ bh env + put_ bh info put_ bh ifaces get bh = do env <- get bh + info <- get bh ifaces <- get bh - return (InterfaceFile env ifaces) + return (InterfaceFile env info ifaces) +putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO () +putInterfaceFile_ bh (InterfaceFile env info ifaces) = do + put_ bh env + put_ bh info + put_ bh ifaces + instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap argMap - exps visExps opts subMap fixMap) = do + put_ bh (InstalledInterface modu is_sig info docMap argMap + exps visExps opts fixMap) = do put_ bh modu + put_ bh is_sig put_ bh info - put_ bh docMap - put_ bh argMap + lazyPut bh (docMap, argMap) put_ bh exps put_ bh visExps put_ bh opts - put_ bh subMap put_ bh fixMap get bh = do modu <- get bh + is_sig <- get bh info <- get bh - docMap <- get bh - argMap <- get bh + ~(docMap, argMap) <- lazyGet bh exps <- get bh visExps <- get bh opts <- get bh - subMap <- get bh fixMap <- get bh - - return (InstalledInterface modu info docMap argMap - exps visExps opts subMap fixMap) + return (InstalledInterface modu is_sig info docMap argMap + exps visExps opts fixMap) instance Binary DocOption where @@ -433,7 +370,7 @@ result <- get bh return (Example expression result) -instance Binary Hyperlink where +instance Binary a => Binary (Hyperlink a) where put_ bh (Hyperlink url label) = do put_ bh url put_ bh label @@ -442,6 +379,15 @@ label <- get bh return (Hyperlink url label) +instance Binary a => Binary (ModLink a) where + put_ bh (ModLink m label) = do + put_ bh m + put_ bh label + get bh = do + m <- get bh + label <- get bh + return (ModLink m label) + instance Binary Picture where put_ bh (Picture uri title) = do put_ bh uri @@ -460,9 +406,40 @@ t <- get bh return (Header l t) +instance Binary a => Binary (Table a) where + put_ bh (Table h b) = do + put_ bh h + put_ bh b + get bh = do + h <- get bh + b <- get bh + return (Table h b) + +instance Binary a => Binary (TableRow a) where + put_ bh (TableRow cs) = put_ bh cs + get bh = do + cs <- get bh + return (TableRow cs) + +instance Binary a => Binary (TableCell a) where + put_ bh (TableCell i j c) = do + put_ bh i + put_ bh j + put_ bh c + get bh = do + i <- get bh + j <- get bh + c <- get bh + return (TableCell i j c) + instance Binary Meta where - put_ bh Meta { _version = v } = put_ bh v - get bh = (\v -> Meta { _version = v }) <$> get bh + put_ bh (Meta v p) = do + put_ bh v + put_ bh p + get bh = do + v <- get bh + p <- get bh + return (Meta v p) instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where put_ bh MetaDoc { _meta = m, _doc = d } = do @@ -489,9 +466,6 @@ put_ bh (DocIdentifier ae) = do putByte bh 4 put_ bh ae - put_ bh (DocModule af) = do - putByte bh 5 - put_ bh af put_ bh (DocEmphasis ag) = do putByte bh 6 put_ bh ag @@ -543,6 +517,13 @@ put_ bh (DocMathDisplay x) = do putByte bh 22 put_ bh x + put_ bh (DocTable x) = do + putByte bh 23 + put_ bh x + -- See note [The DocModule story] + put_ bh (DocModule af) = do + putByte bh 24 + put_ bh af get bh = do h <- getByte bh @@ -562,9 +543,13 @@ 4 -> do ae <- get bh return (DocIdentifier ae) + -- See note [The DocModule story] 5 -> do af <- get bh - return (DocModule af) + return $ DocModule ModLink + { modLinkName = af + , modLinkLabel = Nothing + } 6 -> do ag <- get bh return (DocEmphasis ag) @@ -616,6 +601,13 @@ 22 -> do x <- get bh return (DocMathDisplay x) + 23 -> do + x <- get bh + return (DocTable x) + -- See note [The DocModule story] + 24 -> do + af <- get bh + return (DocModule af) _ -> error "invalid binary data found in the interface file" @@ -663,3 +655,28 @@ name <- get bh return (Undocumented name) _ -> error "get DocName: Bad h" + +instance Binary n => Binary (Wrap n) where + put_ bh (Unadorned n) = do + putByte bh 0 + put_ bh n + put_ bh (Parenthesized n) = do + putByte bh 1 + put_ bh n + put_ bh (Backticked n) = do + putByte bh 2 + put_ bh n + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + return (Unadorned name) + 1 -> do + name <- get bh + return (Parenthesized name) + 2 -> do + name <- get bh + return (Backticked name) + _ -> error "get Wrap: Bad h" diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -14,45 +14,45 @@ import Haddock.Types ( MDoc ) -import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString ) -import DynFlags ( DynFlags ) -import Packages ( lookupPackage ) -import PackageConfig ( sourcePackageIdString ) +import GHC ( Name ) +import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString ) +import GHC.Unit.State ( UnitState, lookupUnit, unitPackageIdString ) +import qualified Control.Applicative as A -data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] -mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] + +mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] +mkModuleTree state showPkgs mods = + foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where - modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) + modPkg mod_ | showPkgs = Just (unitString (moduleUnit mod_)) | otherwise = Nothing - modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString - (lookupPackage dflags (moduleUnitId mod_)) + modSrcPkg mod_ | showPkgs = fmap unitPackageIdString + (lookupUnit state (moduleUnit mod_)) | otherwise = Nothing - fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short -addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ _ ts = ts -addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short -addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts +addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ _ ts = ts +addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short +addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) m pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ _ = [] -mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] -mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] +mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ _ = [] +mkSubTree [s] m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []] +mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)] splitModule :: Module -> [String] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -15,6 +15,7 @@ module Haddock.Options ( parseHaddockOpts, Flag(..), + Visibility(..), getUsage, optTitle, outputDir, @@ -24,25 +25,38 @@ optSourceCssFile, sourceUrls, wikiUrls, + baseUrl, + optParCount, optDumpInterfaceFile, + optShowInterfaceFile, optLaTeXStyle, optMathjax, qualification, + sinceQualification, verbosity, ghcFlags, + reexportFlags, readIfaceArgs, optPackageName, - optPackageVersion + optPackageVersion, + modulePackageInfo, + ignoredSymbols ) where import qualified Data.Char as Char +import Data.List (dropWhileEnd) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import Data.Version -import Distribution.Verbosity -import FastString +import Control.Applicative +import GHC.Data.FastString +import GHC ( Module, moduleUnit ) +import GHC.Unit.State import Haddock.Types import Haddock.Utils -import Packages import System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP @@ -53,6 +67,7 @@ -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String + | Flag_ShowInterface String | Flag_Heading String | Flag_Html | Flag_Hoogle @@ -64,10 +79,12 @@ | Flag_SourceEntityURL String | Flag_SourceLEntityURL String | Flag_WikiBaseURL String + | Flag_BaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String + | Flag_QuickJumpIndex | Flag_HyperlinkedSource | Flag_SourceCss String | Flag_Mathjax String @@ -76,12 +93,15 @@ | Flag_Version | Flag_CompatibleInterfaceVersions | Flag_InterfaceVersion + | Flag_BypassInterfaceVersonCheck | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String | Flag_GenIndex | Flag_IgnoreAllExports | Flag_HideModule String + | Flag_ShowModule String + | Flag_ShowAllModules | Flag_ShowExtensions String | Flag_OptGhc String | Flag_GhcLibDir String @@ -96,6 +116,10 @@ | Flag_NoPrintMissingDocs | Flag_PackageName String | Flag_PackageVersion String + | Flag_Reexport String + | Flag_SinceQualification String + | Flag_IgnoreLinkSymbol String + | Flag_ParCount (Maybe Int) deriving (Eq, Show) @@ -112,6 +136,8 @@ "read an interface from FILE", Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") "write the resulting interface to FILE", + Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE") + "print the interface in a human readable form", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) @@ -122,6 +148,8 @@ Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle; you may want --package-name and --package-version too", + Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex) + "generate an index for interactive documentation navigation", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") @@ -137,6 +165,8 @@ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") "URL for a comments link on the contents\nand index pages", + Option [] ["base-url"] (ReqArg Flag_BaseURL "URL") + "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.", Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") "URL for a comments link for each module\n(using the %{MODULE} var)", Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") @@ -159,6 +189,8 @@ "output compatible interface file versions and exit", Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) "output interface file version and exit", + Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck) + "bypass the interface file version check (dangerous)", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") @@ -170,9 +202,13 @@ Option [] ["gen-index"] (NoArg Flag_GenIndex) "generate an HTML index from specified\ninterfaces", Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", + "behave as if all modules have the\nignore-exports attribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", + Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") + "behave as if MODULE does not have the hide attribute", + Option [] ["show-all"] (NoArg Flag_ShowAllModules) + "behave as if not modules have the hide attribute", Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE") "behave as if MODULE has the show-extensions attribute", Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") @@ -190,10 +226,18 @@ "generate html with newlines and indenting (for use with --html)", Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) "don't print information about any undocumented entities", + Option [] ["reexport"] (ReqArg Flag_Reexport "MOD") + "reexport the module MOD, adding it to the index", Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") - "version of the package being documented in usual x.y.z.w format" + "version of the package being documented in usual x.y.z.w format", + Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL") + "package qualification of @since, one of\n'always' (default) or 'only-external'", + Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL") + "name of a symbol which does not trigger a warning in case of link issue", + Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n") + "load modules in parallel" ] @@ -267,17 +311,23 @@ ,optLast [str | Flag_WikiEntityURL str <- flags]) +baseUrl :: [Flag] -> Maybe String +baseUrl flags = optLast [str | Flag_BaseURL str <- flags] + optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optShowInterfaceFile :: [Flag] -> Maybe FilePath +optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] - optMathjax :: [Flag] -> Maybe String optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ] +optParCount :: [Flag] -> Maybe (Maybe Int) +optParCount flags = optLast [ n | Flag_ParCount n <- flags ] qualification :: [Flag] -> Either String QualOption qualification flags = @@ -291,34 +341,114 @@ [arg] -> Left $ "unknown qualification type " ++ show arg _:_ -> Left "qualification option given multiple times" +sinceQualification :: [Flag] -> Either String SinceQual +sinceQualification flags = + case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of + [] -> Right Always + ["always"] -> Right Always + ["external"] -> Right External + [arg] -> Left $ "unknown since-qualification type " ++ show arg + _:_ -> Left "since-qualification option given multiple times" verbosity :: [Flag] -> Verbosity verbosity flags = case [ str | Flag_Verbosity str <- flags ] of - [] -> normal + [] -> Normal x:_ -> case parseVerbosity x of Left e -> throwE e Right v -> v +-- | Get the ignored symbols from the given flags. These are the symbols for +-- which no link warnings will be generated if their link destinations cannot be +-- determined. +-- +-- Symbols may be provided as qualified or unqualified names (e.g. +-- 'Data.Map.dropWhileEnd' or 'dropWhileEnd', resp). If qualified, no link +-- warnings will be produced for occurances of that name when it is imported +-- from that module. If unqualified, no link warnings will be produced for any +-- occurances of that name from any module. +ignoredSymbols :: [Flag] -> Map (Maybe String) (Set String) +ignoredSymbols flags = + foldr addToMap Map.empty [ splitSymbol symbol | Flag_IgnoreLinkSymbol symbol <- flags ] + where + -- Split a symbol into its module name and unqualified name, producing + -- 'Nothing' for the module name if the given symbol is already unqualified + splitSymbol :: String -> (Maybe String, String) + splitSymbol s = + -- Drop the longest suffix not containing a '.' character + case dropWhileEnd (/= '.') s of + -- If the longest suffix is empty, there was no '.'. + -- Assume it is an unqualified name (no module string). + "" -> (Nothing, s) + + -- If the longest suffix is not empty, there was a '.'. + -- Assume it is a qualified name. `s'` will be the module string followed + -- by the last '.', e.g. "Data.List.", so take `init s'` as the module + -- string. Drop the length of `s'` from the original string `s` to + -- obtain to the unqualified name. + s' -> (Just $ init s', drop (length s') s) + + -- Add a (module name, name) pair to the map from modules to their ignored + -- symbols + addToMap :: (Maybe String, String) -> Map (Maybe String) (Set String) -> Map (Maybe String) (Set String) + addToMap (m, name) symbs = Map.insertWith (Set.union) m (Set.singleton name) symbs + ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] +reexportFlags :: [Flag] -> [String] +reexportFlags flags = [ option | Flag_Reexport option <- flags ] -readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] +data Visibility = Visible | Hidden + deriving (Eq, Show) + +readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)] readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] where - parseIfaceOption :: String -> (DocPaths, FilePath) + parseIfaceOption :: String -> (DocPaths, Visibility, FilePath) parseIfaceOption str = case break (==',') str of (fpath, ',':rest) -> case break (==',') rest of - (src, ',':file) -> ((fpath, Just src), file) - (file, _) -> ((fpath, Nothing), file) - (file, _) -> (("", Nothing), file) + (src, ',':rest') -> + let src' = case src of + "" -> Nothing + _ -> Just src + in + case break (==',') rest' of + (visibility, ',':file) | visibility == "hidden" -> + ((fpath, src'), Hidden, file) + | otherwise -> + ((fpath, src'), Visible, file) + (file, _) -> + ((fpath, src'), Visible, file) + (file, _) -> ((fpath, Nothing), Visible, file) + (file, _) -> (("", Nothing), Visible, file) -- | Like 'listToMaybe' but returns the last element instead of the first. optLast :: [a] -> Maybe a optLast [] = Nothing optLast xs = Just (last xs) + + +-- | This function has a potential to return 'Nothing' because package name and +-- versions can no longer reliably be extracted in all cases: if the package is +-- not installed yet then this info is no longer available. +-- +-- The @--package-name@ and @--package-version@ Haddock flags allow the user to +-- specify this information manually and it is returned here if present. +modulePackageInfo :: UnitState + -> [Flag] -- ^ Haddock flags are checked as they may contain + -- the package name or version provided by the user + -- which we prioritise + -> Maybe Module + -> (Maybe PackageName, Maybe Data.Version.Version) +modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing) +modulePackageInfo unit_state flags (Just modu) = + ( optPackageName flags <|> fmap unitPackageName pkgDb + , optPackageVersion flags <|> fmap unitPackageVersion pkgDb + ) + where + pkgDb = lookupUnit unit_state (moduleUnit modu) diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs --- a/src/Haddock/Parser.hs +++ b/src/Haddock/Parser.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving - , FlexibleInstances, UndecidableInstances - , IncoherentInstances #-} -{-# LANGUAGE LambdaCase #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -19,26 +14,43 @@ ) where import qualified Documentation.Haddock.Parser as P -import DynFlags (DynFlags) -import FastString (mkFastString) import Documentation.Haddock.Types -import Lexer (mkPState, unP, ParseResult(POk)) -import Parser (parseIdentifier) -import RdrName (RdrName) -import SrcLoc (mkRealSrcLoc, unLoc) -import StringBuffer (stringToStringBuffer) +import Haddock.Types -parseParas :: DynFlags -> String -> MetaDoc mod RdrName -parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas +import GHC.Driver.Session ( DynFlags ) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Data.FastString ( fsLit ) +import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) +import GHC.Parser ( parseIdentifier ) +import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name.Reader ( RdrName(..) ) +import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..) ) +import GHC.Data.StringBuffer ( stringToStringBuffer ) -parseString :: DynFlags -> String -> DocH mod RdrName + +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName) +parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p + +parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName) parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> String -> Maybe RdrName -parseIdent dflags str0 = - let buffer = stringToStringBuffer str0 - realSrcLc = mkRealSrcLoc (mkFastString "") 0 0 - pstate = mkPState dflags buffer realSrcLc - in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) - _ -> Nothing +parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) +parseIdent dflags ns str0 = + case unP parseIdentifier (pstate str1) of + POk _ (L _ name) + -- Guards against things like 'Q.--', 'Q.case', etc. + -- See https://github.com/haskell/haddock/issues/952 and Trac #14109 + | Qual _ occ <- name + , PFailed{} <- unP parseIdentifier (pstate (occNameString occ)) + -> Nothing + | otherwise + -> Just (wrap (NsRdrName ns name)) + PFailed{} -> Nothing + where + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 + pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) diff --git a/src/Haddock/Syb.hs b/src/Haddock/Syb.hs --- a/src/Haddock/Syb.hs +++ b/src/Haddock/Syb.hs @@ -1,25 +1,25 @@ {-# LANGUAGE Rank2Types #-} - +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Haddock.Syb - ( everything, everythingWithState, everywhere + ( everythingWithState + , everywhereButType , mkT - , combine + , mkQ + , extQ ) where import Data.Data -import Control.Applicative - - --- | Perform a query on each level of a tree. --- --- This is stolen directly from SYB package and copied here to not introduce --- additional dependencies. -everything :: (r -> r -> r) -> (forall a. Data a => a -> r) - -> (forall a. Data a => a -> r) -everything k f x = foldl k (f x) (gmapQ (everything k f) x) +import Data.Maybe +import Data.Foldable +-- | Returns true if a == t. +-- requires AllowAmbiguousTypes +isType :: forall a b. (Typeable a, Typeable b) => b -> Bool +isType _ = isJust $ eqT @a @b -- | Perform a query with state on each level of a tree. -- @@ -31,15 +31,24 @@ -> (forall a. Data a => a -> r) everythingWithState s k f x = let (r, s') = f x s - in foldl k r (gmapQ (everythingWithState s' k f) x) - + in foldl' k r (gmapQ (everythingWithState s' k f) x) --- | Apply transformation on each level of a tree. --- +-- | Variation on everywhere with an extra stop condition -- Just like 'everything', this is stolen from SYB package. -everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) -everywhere f = f . gmapT (everywhere f) +everywhereBut :: (forall a. Data a => a -> Bool) + -> (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhereBut q f x + | q x = x + | otherwise = f (gmapT (everywhereBut q f) x) +-- | Variation of "everywhere" that does not recurse into children of type t +-- requires AllowAmbiguousTypes +everywhereButType :: forall t . (Typeable t) + => (forall a. Data a => a -> a) + -> (forall a. Data a => a -> a) +everywhereButType = everywhereBut (isType @t) + -- | Create generic transformation. -- -- Another function stolen from SYB package. @@ -48,8 +57,17 @@ Just f' -> f' Nothing -> id --- | Combine two queries into one using alternative combinator. -combine :: Alternative f => (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) - -> (forall a. Data a => a -> f r) -combine f g x = f x <|> g x +-- | Create generic query. +-- +-- Another function stolen from SYB package. +mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + +-- | Extend a generic query by a type-specific case. +-- +-- Another function stolen from SYB package. +extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q +extQ f g a = maybe (f a) g (cast a) diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,7 +1,21 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies, RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Types @@ -24,27 +38,28 @@ , module Documentation.Haddock.Types ) where -import Control.Exception -import Control.Arrow hiding ((<+>)) import Control.DeepSeq -import Data.Typeable +import Control.Exception (throw) +import Control.Monad.Catch +import Control.Monad.State.Strict +import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) -import qualified Data.Map as Map +import qualified Data.Set as Set import Documentation.Haddock.Types -import BasicTypes (Fixity(..)) +import qualified GHC.Data.Strict as Strict +import GHC.Types.Fixity (Fixity(..)) +import GHC.Types.Name (stableNameCmp) +import GHC.Types.Name.Reader (RdrName(..)) +import GHC.Types.SourceText (SourceText(..)) +import GHC.Types.SrcLoc (BufSpan(..), BufPos(..)) +import GHC.Types.Var (Specificity) -import GHC hiding (NoLink) -import DynFlags (Language) +import GHC +import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt -import Coercion -import NameSet -import OccName -import Outputable -import Control.Applicative (Applicative(..)) -import Control.Monad (ap) - -import Haddock.Backends.Hyperlinker.Types +import GHC.Types.Name.Occurrence +import GHC.Utils.Outputable ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -56,17 +71,17 @@ type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl Name] -type InstMap = Map SrcSpan Name +type DeclMap = Map Name DeclMapEntry +type InstMap = Map RealSrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources +type WarningMap = Map Name (Doc Name) ----------------------------------------------------------------------------- --- * Interface +-- * Interfaces and Interface creation ----------------------------------------------------------------------------- - -- | 'Interface' holds all information used to render a single Haddock page. -- It represents the /interface/ of a module. The core business of Haddock -- lies in creating this structure. Note that the record contains some fields @@ -77,6 +92,9 @@ -- | The module behind this interface. ifaceMod :: !Module + -- | Is this a signature? + , ifaceIsSig :: !Bool + -- | Original file name of the module. , ifaceOrigFilename :: !FilePath @@ -90,149 +108,186 @@ , ifaceRnDoc :: !(Documentation DocName) -- | Haddock options for this module (prune, ignore-exports, etc). - , ifaceOptions :: ![DocOption] + , ifaceOptions :: [DocOption] -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl Name]) + , ifaceDeclMap :: !DeclMap -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name) , ifaceArgMap :: !(ArgMap Name) - -- | Documentation of declarations originating from the module (including - -- subordinates). - , ifaceRnDocMap :: !(DocMap DocName) - , ifaceRnArgMap :: !(ArgMap DocName) - - , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: ![ExportItem DocName] + , ifaceExportItems :: [ExportItem GhcRn] + , ifaceRnExportItems :: [ExportItem DocNameI] -- | All names exported by the module. - , ifaceExports :: ![Name] + , ifaceExports :: [Name] -- | All \"visible\" names exported by the module. -- A visible name is a name that will show up in the documentation of the -- module. - , ifaceVisibleExports :: ![Name] + , ifaceVisibleExports :: [Name] -- | Aliases of module imports as in @import A.B.C as C@. , ifaceModuleAliases :: !AliasMap -- | Instances exported by the module. - , ifaceInstances :: ![ClsInst] - , ifaceFamInstances :: ![FamInst] + , ifaceInstances :: [HaddockClsInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance Name] - , ifaceRnOrphanInstances :: ![DocInstance DocName] + , ifaceOrphanInstances :: [DocInstance GhcRn] + , ifaceRnOrphanInstances :: [DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. - , ifaceHaddockCoverage :: !(Int, Int) + , ifaceHaddockCoverage :: (Int, Int) -- | Warnings for things defined in this module. - , ifaceWarningMap :: !WarningMap + , ifaceWarningMap :: WarningMap - -- | Tokenized source code of module (avaliable if Haddock is invoked with + -- | Tokenized source code of module (available if Haddock is invoked with -- source generation flag). - , ifaceTokenizedSrc :: !(Maybe [RichToken]) - } - -type WarningMap = Map Name (Doc Name) + , ifaceHieFile :: !(Maybe FilePath) + , ifaceDynFlags :: !DynFlags + } -- | A subset of the fields of 'Interface' that we store in the interface -- files. data InstalledInterface = InstalledInterface { -- | The module represented by this interface. - instMod :: Module + instMod :: Module + -- | Is this a signature? + , 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] - , instFixMap :: Map Name Fixity + , instFixMap :: Map Name Fixity } - -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface - { instMod = ifaceMod 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 + , instFixMap = ifaceFixMap interface } ------------------------------------------------------------------------------ --- * Export items & declarations ------------------------------------------------------------------------------ +-- | A monad in which we create Haddock interfaces. Not to be confused with +-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces. +-- +-- In the past `createInterface` was running in the `Ghc` monad but proved hard +-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting +-- over the Ghc specific clarifies where side effects happen. +newtype IfM m a = IfM { unIfM :: StateT (IfEnv m) m a } +deriving newtype instance Functor m => Functor (IfM m) +deriving newtype instance (Monad m, Applicative m) => Applicative (IfM m) +deriving newtype instance Monad m => Monad (IfM m) +deriving newtype instance MonadIO m => MonadIO (IfM m) +deriving newtype instance Monad m => MonadState (IfEnv m) (IfM m) -data ExportItem name +-- | Interface creation environment. The name sets are used primarily during +-- processing of doc strings to avoid emitting the same type of warning for the +-- same name twice. This was previously done using a Writer monad and then +-- nubbing the list of warning messages after accumulation. This new approach +-- was implemented to avoid the nubbing of potentially large lists of strings. +data IfEnv m = IfEnv + { + -- | Lookup names in the environment. + ifeLookupName :: Name -> m (Maybe TyThing) - -- | An exported declaration. - = ExportDecl + -- | Names which we have warned about for being out of scope + , ifeOutOfScopeNames :: !(Set.Set String) + + -- | Names which we have warned about for being ambiguous + , ifeAmbiguousNames :: !(Set.Set String) + + -- | Named which we have warned about for being inappropriately namespaced + -- as values + , ifeInvalidValues :: !(Set.Set String) + } + +-- | Run an `IfM` action. +runIfM + :: (Monad m) + -- | Lookup a global name in the current session. Used in cases + -- where declarations don't + => (Name -> m (Maybe TyThing)) + -- | The action to run. + -> IfM m a + -- | Result and accumulated error/warning messages. + -> m a +runIfM lookup_name action = do + let + if_env = IfEnv { - -- | A declaration. - expItemDecl :: !(LHsDecl name) + ifeLookupName = lookup_name + , ifeOutOfScopeNames = Set.empty + , ifeAmbiguousNames = Set.empty + , ifeInvalidValues = Set.empty + } + evalStateT (unIfM action) if_env - -- | Maybe a doc comment, and possibly docs for arguments (if this - -- decl is a function or type-synonym). - , expItemMbDoc :: !(DocForDecl name) +-- | Look up a name in the current environment +lookupName :: Monad m => Name -> IfM m (Maybe TyThing) +lookupName name = IfM $ do + lookup_name <- gets ifeLookupName + lift (lookup_name name) - -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: ![(name, DocForDecl name)] +-- | Very basic logging function that simply prints to stdout +warn :: MonadIO m => String -> IfM m () +warn msg = liftIO $ putStrLn msg - -- | Instances relevant to this declaration, possibly with - -- documentation. - , expItemInstances :: ![DocInstance name] +----------------------------------------------------------------------------- +-- * Export items & declarations +----------------------------------------------------------------------------- - -- | Fixity decls relevant to this declaration (including subordinates). - , expItemFixities :: ![(name, Fixity)] - -- | Whether the ExportItem is from a TH splice or not, for generating - -- the appropriate type of Source link. - , expItemSpliced :: !Bool - } +data ExportItem name + -- | An exported declaration. + = ExportDecl (XExportDecl name) + -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl - { expItemName :: !name + { expItemName :: !(IdP name) -- | Subordinate names. - , expItemSubs :: ![name] + , expItemSubs :: [IdP name] } -- | A section heading. @@ -245,31 +300,115 @@ , expItemSectionId :: !String -- | Section heading text. - , expItemSectionText :: !(Doc name) + , expItemSectionText :: !(Doc (IdP name)) } -- | Some documentation. - | ExportDoc !(MDoc name) + | ExportDoc !(MDoc (IdP name)) -- | A cross-reference to another module. | ExportModule !Module +-- | A type family mapping a name type index to types of export declarations. +-- The pre-renaming type index ('GhcRn') is mapped to the type of export +-- declarations which do not include Hoogle output ('ExportD'), since Hoogle output is +-- generated during the Haddock renaming step. The post-renaming type index +-- ('DocNameI') is mapped to the type of export declarations which do include +-- Hoogle output ('RnExportD'). +type family XExportDecl x where + XExportDecl GhcRn = ExportD GhcRn + XExportDecl DocNameI = RnExportD + +-- | Represents an export declaration that Haddock has discovered to be exported +-- from a module. The @name@ index indicated whether the declaration has been +-- renamed such that each 'Name' points to it's optimal link destination. +data ExportD name = ExportD + { + -- | A declaration. + expDDecl :: !(LHsDecl name) + + -- | Bundled patterns for a data type declaration + , expDPats :: [(HsDecl name, DocForDecl (IdP name))] + + -- | Maybe a doc comment, and possibly docs for arguments (if this + -- decl is a function or type-synonym). + , expDMbDoc :: !(DocForDecl (IdP name)) + + -- | Subordinate names, possibly with documentation. + , expDSubDocs :: [(IdP name, DocForDecl (IdP name))] + + -- | Instances relevant to this declaration, possibly with + -- documentation. + , expDInstances :: [DocInstance name] + + -- | Fixity decls relevant to this declaration (including subordinates). + , expDFixities :: [(IdP name, Fixity)] + + -- | Whether the ExportD is from a TH splice or not, for generating + -- the appropriate type of Source link. + , expDSpliced :: !Bool + } + +-- | Represents export declarations that have undergone renaming such that every +-- 'Name' in the declaration points to an optimal link destination. Since Hoogle +-- output is also generated during the renaming step, each declaration is also +-- attached to its Hoogle textual database entries, /if/ Hoogle output is +-- enabled and the module is not hidden in the generated documentation using the +-- @{-# OPTIONS_HADDOCK hide #-}@ pragma. +data RnExportD = RnExportD + { + -- | The renamed export declaration + rnExpDExpD :: !(ExportD DocNameI) + + -- | If Hoogle textbase (textual database) output is enabled, the text + -- output lines for this declaration. If Hoogle output is not enabled, the + -- list will be empty. + , rnExpDHoogle :: [String] + } + data Documentation name = Documentation - { documentationDoc :: Maybe (MDoc name) - , documentationWarning :: !(Maybe (Doc name)) + { documentationDoc :: Maybe (MDoc name) + , documentationWarning :: Maybe (Doc name) } deriving Functor +instance NFData name => NFData (Documentation name) where + rnf (Documentation d w) = d `deepseq` w `deepseq` () -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (MDoc name) type DocForDecl name = (Documentation name, FnArgsDoc name) - noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, mempty) +-- | As we build the declaration map, we really only care to track whether we +-- have only seen a value declaration for a 'Name', or anything else. This type +-- is used to represent those cases. If the only declaration attached to a +-- 'Name' is a 'ValD', we will consult the GHC interface file to determine the +-- type of the value, and attach the 'SrcSpan' from the 'EValD' constructor to +-- it. If we see any other type of declaration for the 'Name', we can just use +-- it. +-- +-- This type saves us from storing /every/ declaration we see for a given 'Name' +-- in the map, which is unnecessary and very problematic for overall memory +-- usage. +data DeclMapEntry + = EValD !SrcSpan + | EOther (LHsDecl GhcRn) +instance Semigroup DeclMapEntry where + (EValD _) <> e = e + e <> _ = e + +-- | Transform a declaration into a 'DeclMapEntry'. If it is a 'ValD' +-- declaration, only the source location will be noted (since that is all we +-- care to store in the 'DeclMap' due to the way top-level bindings with no type +-- signatures are handled). Otherwise, the entire declaration will be kept. +toDeclMapEntry :: LHsDecl GhcRn -> DeclMapEntry +toDeclMapEntry (L l (ValD _ _)) = EValD (locA l) +toDeclMapEntry d = EOther d + ----------------------------------------------------------------------------- -- * Cross-referencing ----------------------------------------------------------------------------- @@ -278,6 +417,15 @@ -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | An 'RdrName' tagged with some type/value namespace information. +data NsRdrName = NsRdrName + { namespace :: !Namespace + , rdrName :: !RdrName + } + +instance NFData NsRdrName where + rnf (NsRdrName ns rdrN) = ns `seq` rdrN `deepseq` () + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module @@ -289,15 +437,17 @@ -- documentation, as far as Haddock knows. deriving (Eq, Data) -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder +data DocNameI -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder +type instance NoGhcTc DocNameI = DocNameI +type instance IdP DocNameI = DocName + +instance CollectPass DocNameI where + collectXXPat _ ext = dataConCantHappen ext + collectXXHsBindsLR ext = dataConCantHappen ext + collectXSplicePat _ ext = dataConCantHappen ext + instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name @@ -326,12 +476,93 @@ setName name' (Documented _ mdl) = Documented name' mdl setName name' (Undocumented _) = Undocumented name' +-- | Adds extra "wrapper" information to a name. +-- +-- This is to work around the fact that most name types in GHC ('Name', 'RdrName', +-- 'OccName', ...) don't include backticks or parens. +data Wrap n + = Unadorned { unwrap :: n } -- ^ don't do anything to the name + | Parenthesized { unwrap :: n } -- ^ add parentheses around the name + | Backticked { unwrap :: n } -- ^ add backticks around the name + deriving (Show, Functor, Foldable, Traversable) +instance NFData n => NFData (Wrap n) where + rnf w = case w of + Unadorned n -> rnf n + Parenthesized n -> rnf n + Backticked n -> rnf n +-- | Useful for debugging +instance Outputable n => Outputable (Wrap n) where + ppr (Unadorned n) = ppr n + ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ] + ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ] + +showWrapped :: (a -> String) -> Wrap a -> String +showWrapped f (Unadorned n) = f n +showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" +showWrapped f (Backticked n) = "`" ++ f n ++ "`" + +instance HasOccName DocName where + + occName = occName . getName + ----------------------------------------------------------------------------- -- * Instances ----------------------------------------------------------------------------- +data HaddockClsInst = HaddockClsInst + { haddockClsInstPprHoogle :: Maybe String + , haddockClsInstName :: Name + , haddockClsInstClsName :: Name + , haddockClsInstIsOrphan :: Bool + , haddockClsInstHead :: ([Int], SName, [SimpleType]) + , haddockClsInstSynified :: InstHead GhcRn + , haddockClsInstTyNames :: Set.Set Name + } + +-- | TODO: This instance is not lawful. We leave the 'InstHead' segment of the +-- class instance evaluated only to WHNF. This should probably be fixed. +instance NFData HaddockClsInst where + rnf (HaddockClsInst h n cn o hd s ns) = + h + `deepseq` n + `deepseq` cn + `deepseq` o + `deepseq` hd + `deepseq` s + `seq` ns + `deepseq` () + +-- | Stable name for stable comparisons. GHC's `Name` uses unstable +-- ordering based on their `Unique`'s. +newtype SName = SName Name + deriving newtype NFData + +instance Eq SName where + SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ + +instance Ord SName where + SName n1 `compare` SName n2 = n1 `stableNameCmp` n2 + +-- | Simplified type for sorting types, ignoring qualification (not visible +-- in Haddock output) and unifying special tycons with normal ones. +-- For the benefit of the user (looks nice and predictable) and the +-- tests (which prefer output to be deterministic). +data SimpleType = SimpleType SName [SimpleType] + | SimpleIntTyLit Integer + | SimpleStringTyLit String + | SimpleCharTyLit Char + deriving (Eq,Ord) + +instance NFData SimpleType where + rnf st = + case st of + SimpleType sn sts -> sn `deepseq` sts `deepseq` () + SimpleIntTyLit i -> rnf i + SimpleStringTyLit s -> rnf s + SimpleCharTyLit c -> rnf c + -- | The three types of instances data InstType name = ClassInst @@ -343,7 +574,8 @@ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance OutputableBndr a => Outputable (InstType a) where +instance (OutputableBndrId p) + => Outputable (InstType (GhcPass p)) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx <+> ppr clsiTyVars @@ -361,13 +593,13 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name - , pfdLName :: Located name + , pfdLName :: LocatedN (IdP name) , pfdTyVars :: [LHsType name] , pfdKindSig :: LFamilyResultSig name } -mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name +mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName @@ -375,21 +607,21 @@ , pfdKindSig = fdResultSig } where - mkType (KindedTyVar (L loc name) lkind) = - HsKindSig tvar lkind + mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn + mkType (KindedTyVar _ _ (L loc name) lkind) = + HsKindSig noAnn tvar lkind where - tvar = L loc (HsTyVar (L loc name)) - mkType (UserTyVar name) = HsTyVar name + tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name)) + mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name -- | An instance head that may have documentation and a source location. -type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) +type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module) --- | The head of an instance. Consists of a class name, a list of kind --- parameters, a list of type parameters and an instance type +-- | The head of an instance. Consists of a class name, a list of type +-- parameters (which may be annotated with kinds), and an instance type data InstHead name = InstHead - { ihdClsName :: name - , ihdKinds :: [HsType name] + { ihdClsName :: IdP name , ihdTypes :: [HsType name] , ihdInstType :: InstType name } @@ -419,9 +651,17 @@ type LDoc id = Located (Doc id) -type Doc id = DocH (ModuleName, OccName) id -type MDoc id = MetaDoc (ModuleName, OccName) id +type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id) +type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id) +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a + +instance NFData Meta where + rnf (Meta v p) = v `deepseq` p `deepseq` () + +instance NFData id => NFData (MDoc id) where + rnf (MetaDoc m d) = m `deepseq` d `deepseq` () + instance (NFData a, NFData mod) => NFData (DocH mod a) where rnf doc = case doc of @@ -448,6 +688,7 @@ DocProperty a -> a `deepseq` () DocExamples a -> a `deepseq` () DocHeader a -> a `deepseq` () + DocTable a -> a `deepseq` () #if !MIN_VERSION_ghc(8,0,2) -- These were added to GHC itself in 8.0.2 @@ -459,47 +700,45 @@ instance NFData id => NFData (Header id) where rnf (Header a b) = a `deepseq` b `deepseq` () -instance NFData Hyperlink where +instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (ModLink id) where + rnf (ModLink a b) = a `deepseq` b `deepseq` () + instance NFData Picture where rnf (Picture a b) = a `deepseq` b `deepseq` () instance NFData Example where rnf (Example a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (Table id) where + rnf (Table h b) = h `deepseq` b `deepseq` () +instance NFData id => NFData (TableRow id) where + rnf (TableRow cs) = cs `deepseq` () + +instance NFData id => NFData (TableCell id) where + rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` () + exampleToString :: Example -> String exampleToString (Example expression result) = ">>> " ++ expression ++ "\n" ++ unlines result - -data DocMarkup id a = Markup - { markupEmpty :: a - , markupString :: String -> a - , markupParagraph :: a -> a - , markupAppend :: a -> a -> a - , markupIdentifier :: id -> a - , markupIdentifierUnchecked :: (ModuleName, OccName) -> a - , markupModule :: String -> a - , markupWarning :: a -> a - , markupEmphasis :: a -> a - , markupBold :: a -> a - , markupMonospaced :: a -> a - , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a - , markupDefList :: [(a,a)] -> a - , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a - , markupAName :: String -> a - , markupPic :: Picture -> a - , markupMathInline :: String -> a - , markupMathDisplay :: String -> a - , markupProperty :: String -> a - , markupExample :: [Example] -> a - , markupHeader :: Header a -> a - } +instance NFData name => NFData (HaddockModInfo name) where + rnf (HaddockModInfo{..}) = + hmi_description + `deepseq` hmi_copyright + `deepseq` hmi_license + `deepseq` hmi_maintainer + `deepseq` hmi_stability + `deepseq` hmi_portability + `deepseq` hmi_safety + `deepseq` hmi_language + `deepseq` hmi_extensions + `deepseq` () +instance NFData LangExt.Extension data HaddockModInfo name = HaddockModInfo { hmi_description :: Maybe (Doc name) @@ -513,7 +752,6 @@ , hmi_extensions :: [LangExt.Extension] } - emptyHaddockModInfo :: HaddockModInfo a emptyHaddockModInfo = HaddockModInfo { hmi_description = Nothing @@ -584,97 +822,321 @@ OptFullQual -> FullQual OptNoQual -> NoQual +-- | Whether to hide empty contexts +-- Since pattern synonyms have two contexts with different semantics, it is +-- important to all of them, even if one of them is empty. +data HideEmptyContexts + = HideEmptyContexts + | ShowEmptyToplevelContexts +-- | When to qualify @since@ annotations with their package +data SinceQual + = Always + | External -- ^ only qualify when the thing being annotated is from + -- an external package + ----------------------------------------------------------------------------- -- * Error handling ----------------------------------------------------------------------------- +-- | Haddock's own exception type. +data HaddockException + = HaddockException String + | WithContext [String] SomeException + deriving Typeable --- A monad which collects error messages, locally defined to avoid a dep on mtl +instance Show HaddockException where + show (HaddockException str) = str + show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se] +throwE :: String -> a +instance Exception HaddockException +throwE str = throw (HaddockException str) -type ErrMsg = String -newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } +withExceptionContext :: MonadCatch m => String -> m a -> m a +withExceptionContext ctxt = + handle (\ex -> + case ex of + HaddockException _ -> throwM $ WithContext [ctxt] (toException ex) + WithContext ctxts se -> throwM $ WithContext (ctxt:ctxts) se + ) . + handle (throwM . WithContext [ctxt]) +----------------------------------------------------------------------------- +-- * Pass sensitive types +----------------------------------------------------------------------------- -instance Functor ErrMsgM where - fmap f (Writer (a, msgs)) = Writer (f a, msgs) +type instance XRec DocNameI a = GenLocated (Anno a) a +instance UnXRec DocNameI where + unXRec = unLoc +instance MapXRec DocNameI where + mapXRec = fmap +instance WrapXRec DocNameI (HsType DocNameI) where + wrapXRec = noLocA -instance Applicative ErrMsgM where - pure a = Writer (a, []) - (<*>) = ap +type instance Anno DocName = SrcSpanAnnN +type instance Anno (HsTyVarBndr flag DocNameI) = SrcSpanAnnA +type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC +type instance Anno (HsType DocNameI) = SrcSpanAnnA +type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA +type instance Anno (DerivStrategy DocNameI) = SrcAnn NoEpAnns +type instance Anno (FieldOcc DocNameI) = SrcAnn NoEpAnns +type instance Anno (ConDeclField DocNameI) = SrcSpan +type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan +type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan +type instance Anno (ConDecl DocNameI) = SrcSpan +type instance Anno (FunDep DocNameI) = SrcSpan +type instance Anno (TyFamInstDecl DocNameI) = SrcSpanAnnA +type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL +type instance Anno (FamilyDecl DocNameI) = SrcSpan +type instance Anno (Sig DocNameI) = SrcSpan +type instance Anno (InjectivityAnn DocNameI) = SrcAnn NoEpAnns +type instance Anno (HsDecl DocNameI) = SrcSpanAnnA +type instance Anno (FamilyResultSig DocNameI) = SrcAnn NoEpAnns +type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA +type instance Anno (HsSigType DocNameI) = SrcSpanAnnA -instance Monad ErrMsgM where - return = pure - m >>= k = Writer $ let - (a, w) = runWriter m - (b, w') = runWriter (k a) - in (b, w ++ w') +type XRecCond a + = ( XParTy a ~ EpAnn AnnParen + , NoGhcTc a ~ a + , MapXRec a + , UnXRec a + , WrapXRec a (HsType a) + ) +type instance XForAllTy DocNameI = EpAnn [AddEpAnn] +type instance XQualTy DocNameI = EpAnn [AddEpAnn] +type instance XTyVar DocNameI = EpAnn [AddEpAnn] +type instance XStarTy DocNameI = EpAnn [AddEpAnn] +type instance XAppTy DocNameI = EpAnn [AddEpAnn] +type instance XAppKindTy DocNameI = EpAnn [AddEpAnn] +type instance XFunTy DocNameI = EpAnn [AddEpAnn] +type instance XListTy DocNameI = EpAnn AnnParen +type instance XTupleTy DocNameI = EpAnn AnnParen +type instance XSumTy DocNameI = EpAnn AnnParen +type instance XOpTy DocNameI = EpAnn [AddEpAnn] +type instance XParTy DocNameI = EpAnn AnnParen +type instance XIParamTy DocNameI = EpAnn [AddEpAnn] +type instance XKindSig DocNameI = EpAnn [AddEpAnn] +type instance XSpliceTy DocNameI = DataConCantHappen +type instance XDocTy DocNameI = EpAnn [AddEpAnn] +type instance XBangTy DocNameI = EpAnn [AddEpAnn] +type instance XRecTy DocNameI = EpAnn [AddEpAnn] +type instance XExplicitListTy DocNameI = EpAnn [AddEpAnn] +type instance XExplicitTupleTy DocNameI = EpAnn [AddEpAnn] +type instance XTyLit DocNameI = EpAnn [AddEpAnn] +type instance XWildCardTy DocNameI = EpAnn [AddEpAnn] +type instance XXType DocNameI = HsCoreTy -tell :: [ErrMsg] -> ErrMsgM () -tell w = Writer ((), w) +type instance XNumTy DocNameI = NoExtField +type instance XStrTy DocNameI = NoExtField +type instance XCharTy DocNameI = NoExtField +type instance XXTyLit DocNameI = DataConCantHappen +type instance XHsForAllVis DocNameI = NoExtField +type instance XHsForAllInvis DocNameI = NoExtField +type instance XXHsForAllTelescope DocNameI = DataConCantHappen --- Exceptions +type instance XUserTyVar DocNameI = NoExtField +type instance XKindedTyVar DocNameI = NoExtField +type instance XXTyVarBndr DocNameI = DataConCantHappen +type instance XCFieldOcc DocNameI = DocName +type instance XXFieldOcc DocNameI = NoExtField --- | Haddock's own exception type. -data HaddockException = HaddockException String deriving Typeable +type instance XFixitySig DocNameI = NoExtField +type instance XFixSig DocNameI = NoExtField +type instance XPatSynSig DocNameI = NoExtField +type instance XClassOpSig DocNameI = NoExtField +type instance XTypeSig DocNameI = NoExtField +type instance XMinimalSig DocNameI = NoExtField +type instance XForeignExport DocNameI = NoExtField +type instance XForeignImport DocNameI = NoExtField -instance Show HaddockException where - show (HaddockException str) = str +type instance XCImport DocNameI = NoExtField +type instance XCExport DocNameI = NoExtField +type instance XXForeignImport DocNameI = DataConCantHappen +type instance XXForeignExport DocNameI = DataConCantHappen -throwE :: String -> a -instance Exception HaddockException -throwE str = throw (HaddockException str) +type instance XConDeclGADT DocNameI = NoExtField +type instance XConDeclH98 DocNameI = NoExtField +type instance XXConDecl DocNameI = DataConCantHappen +type instance XDerivD DocNameI = NoExtField +type instance XInstD DocNameI = NoExtField +type instance XForD DocNameI = NoExtField +type instance XSigD DocNameI = NoExtField +type instance XTyClD DocNameI = NoExtField --- In "Haddock.Interface.Create", we need to gather --- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, --- but we can't just use @GhcT ErrMsgM@ because GhcT requires the --- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } ---instance MonadIO ErrMsgGhc where --- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO ---er, implementing GhcMonad involves annoying ExceptionMonad and ---WarnLogMonad classes, so don't bother. -liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a -liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) -liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = WriterGhc . return . runWriter --- for now, use (liftErrMsg . tell) for this ---tell :: [ErrMsg] -> ErrMsgGhc () ---tell msgs = WriterGhc $ return ( (), msgs ) +type instance XNoSig DocNameI = NoExtField +type instance XCKindSig DocNameI = NoExtField +type instance XTyVarSig DocNameI = NoExtField +type instance XXFamilyResultSig DocNameI = DataConCantHappen +type instance XCFamEqn DocNameI _ = NoExtField +type instance XXFamEqn DocNameI _ = DataConCantHappen -instance Functor ErrMsgGhc where - fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) +type instance XCClsInstDecl DocNameI = NoExtField +type instance XCDerivDecl DocNameI = NoExtField +type instance XStockStrategy DocNameI = NoExtField +type instance XAnyClassStrategy DocNameI = NoExtField +type instance XNewtypeStrategy DocNameI = NoExtField +type instance XViaStrategy DocNameI = LHsSigType DocNameI +type instance XDataFamInstD DocNameI = NoExtField +type instance XTyFamInstD DocNameI = NoExtField +type instance XClsInstD DocNameI = NoExtField +type instance XCHsDataDefn DocNameI = NoExtField +type instance XCFamilyDecl DocNameI = NoExtField +type instance XClassDecl DocNameI = NoExtField +type instance XDataDecl DocNameI = NoExtField +type instance XSynDecl DocNameI = NoExtField +type instance XFamDecl DocNameI = NoExtField +type instance XXFamilyDecl DocNameI = DataConCantHappen +type instance XXTyClDecl DocNameI = DataConCantHappen -instance Applicative ErrMsgGhc where - pure a = WriterGhc (return (a, [])) - (<*>) = ap +type instance XHsWC DocNameI _ = NoExtField -instance Monad ErrMsgGhc where - return = pure - m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> - fmap (second (msgs1 ++)) (runWriterGhc (k a)) +type instance XHsOuterExplicit DocNameI _ = NoExtField +type instance XHsOuterImplicit DocNameI = NoExtField +type instance XXHsOuterTyVarBndrs DocNameI = DataConCantHappen +type instance XHsSig DocNameI = NoExtField +type instance XXHsSigType DocNameI = DataConCantHappen +type instance XHsQTvs DocNameI = NoExtField +type instance XConDeclField DocNameI = NoExtField +type instance XXConDeclField DocNameI = DataConCantHappen + +type instance XXPat DocNameI = DataConCantHappen +type instance XXHsBindsLR DocNameI a = DataConCantHappen + +type instance XSplicePat DocNameI = DataConCantHappen + +type instance XCInjectivityAnn DocNameI = NoExtField + +type instance XCFunDep DocNameI = NoExtField + +type instance XCTyFamInstDecl DocNameI = NoExtField + ----------------------------------------------------------------------------- --- * Pass sensitive types +-- * NFData instances for GHC types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName (Located Name) = Located DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +instance NFData RdrName where + rnf (Unqual on) = rnf on + rnf (Qual mn on) = mn `deepseq` on `deepseq` () + rnf (Orig m on) = m `deepseq` on `deepseq` () + rnf (Exact n) = rnf n -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder +instance NFData SourceText where + rnf NoSourceText = () + rnf (SourceText s) = rnf s + +instance NFData FixityDirection where + rnf InfixL = () + rnf InfixR = () + rnf InfixN = () + +instance NFData Fixity where + rnf (Fixity sourceText n dir) = + sourceText `deepseq` n `deepseq` dir `deepseq` () + +instance NFData ann => NFData (SrcSpanAnn' ann) where + rnf (SrcSpanAnn a ss) = a `deepseq` ss `deepseq` () + +instance NFData (EpAnn NameAnn) where + rnf EpAnnNotUsed = () + rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` () + +instance NFData NameAnn where + rnf (NameAnn a b c d e) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` e + `deepseq` () + rnf (NameAnnCommas a b c d e) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` e + `deepseq` () + rnf (NameAnnBars a b c d e) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` e + `deepseq` () + rnf (NameAnnOnly a b c d) = + a + `deepseq` b + `deepseq` c + `deepseq` d + `deepseq` () + rnf (NameAnnRArrow a b) = + a + `deepseq` b + `deepseq` () + rnf (NameAnnQuote a b c) = + a + `deepseq` b + `deepseq` c + `deepseq` () + rnf (NameAnnTrailing a) = rnf a + +instance NFData TrailingAnn where + rnf (AddSemiAnn epaL) = rnf epaL + rnf (AddCommaAnn epaL) = rnf epaL + rnf (AddVbarAnn epaL) = rnf epaL + +instance NFData NameAdornment where + rnf NameParens = () + rnf NameParensHash = () + rnf NameBackquotes = () + rnf NameSquare = () + +instance NFData EpaLocation where + rnf (EpaSpan ss bs) = ss `seq` bs `deepseq` () + rnf (EpaDelta dp lc) = dp `seq` lc `deepseq` () + +instance NFData EpAnnComments where + rnf (EpaComments cs) = rnf cs + rnf (EpaCommentsBalanced cs1 cs2) = cs1 `deepseq` cs2 `deepseq` () + +instance NFData EpaComment where + rnf (EpaComment t rss) = t `deepseq` rss `seq` () + +instance NFData EpaCommentTok where + rnf (EpaDocComment ds) = rnf ds + rnf (EpaDocOptions s) = rnf s + rnf (EpaLineComment s) = rnf s + rnf (EpaBlockComment s) = rnf s + rnf EpaEofComment = () + + +instance NFData a => NFData (Strict.Maybe a) where + rnf Strict.Nothing = () + rnf (Strict.Just x) = rnf x + +instance NFData BufSpan where + rnf (BufSpan p1 p2) = p1 `deepseq` p2 `deepseq` () + +instance NFData BufPos where + rnf (BufPos n) = rnf n + +instance NFData Anchor where + rnf (Anchor ss op) = ss `seq` op `deepseq` () + +instance NFData AnchorOperation where + rnf UnchangedAnchor = () + rnf (MovedAnchor dp) = rnf dp + +instance NFData DeltaPos where + rnf (SameLine n) = rnf n + rnf (DifferentLine n m) = n `deepseq` m `deepseq` () + diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils @@ -13,17 +16,12 @@ ----------------------------------------------------------------------------- module Haddock.Utils ( - -- * Misc utilities - restrictTo, emptyHsQTvs, - toDescription, toInstalledDescription, - mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, - -- * Filename utilities moduleHtmlFile, moduleHtmlFile', - contentsHtmlFile, indexHtmlFile, - moduleIndexFrameName, mainFrameName, synopsisFrameName, + contentsHtmlFile, indexHtmlFile, indexJsonFile, subIndexHtmlFile, - jsFile, + haddockJsFile, jsQuickJumpFile, + quickJumpCssFile, -- * Anchor and URL utilities moduleNameUrl, moduleNameUrl', moduleUrl, @@ -31,25 +29,21 @@ makeAnchorId, -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + getProgramName, bye, die, escapeStr, + writeUtf8File, withTempDir, -- * HTML cross reference mapping html_xrefs_ref, html_xrefs_ref', -- * Doc markup - markup, - idMarkup, mkMeta, -- * List utilities replace, spanWith, - -- * MTL stuff - MonadIO(..), - -- * Logging - parseVerbosity, + parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, -- * System tools @@ -59,44 +53,54 @@ import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types -import Haddock.GhcUtils import GHC -import Name -import NameSet ( emptyNameSet ) -import HsTypes (selectorFieldOcc) +import GHC.Types.Name -import Control.Monad ( liftM ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Catch ( MonadMask, bracket_ ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) -import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit -import System.IO ( hPutStr, stderr ) +import System.Directory ( createDirectory, removeDirectoryRecursive ) +import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath -import Distribution.Verbosity -import Distribution.ReadE #ifndef mingw32_HOST_OS import qualified System.Posix.Internals #endif -import MonadUtils ( MonadIO(..) ) - - -------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Eq, Ord, Enum, Bounded, Show) -parseVerbosity :: String -> Either String Verbosity -parseVerbosity = runReadE flagToVerbosity +silent, normal, verbose, deafening :: Verbosity +silent = Silent +normal = Normal +verbose = Verbose +deafening = Deafening +-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing. +parseVerbosity :: String -> Either String Verbosity +parseVerbosity "0" = Right Silent +parseVerbosity "1" = Right Normal +parseVerbosity "2" = Right Silent +parseVerbosity "3" = Right Deafening +parseVerbosity "silent" = return Silent +parseVerbosity "normal" = return Normal +parseVerbosity "verbose" = return Verbose +parseVerbosity "debug" = return Deafening +parseVerbosity "deafening" = return Deafening +parseVerbosity other = Left ("Can't parse verbosity " ++ other) -- | Print a message to stdout, if it is not too verbose out :: MonadIO m @@ -113,129 +117,14 @@ -------------------------------------------------------------------------------- --- | Extract a module's short description. -toDescription :: Interface -> Maybe (MDoc Name) -toDescription = fmap mkMeta . hmi_description . ifaceInfo - --- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) -toInstalledDescription = fmap mkMeta . hmi_description . instInfo - mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name --- Dubious, because the implicit binders are empty even --- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty) - -addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name --- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) - = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious - where - go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) - = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) - add_ctxt (L loc preds) = L loc (extra_pred : preds) - -addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine - -lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] -lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv))) - | tv <- hsQTvExplicit tvs ] - -------------------------------------------------------------------------------- --- * Making abstract declarations --------------------------------------------------------------------------------- - - -restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name -restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) - _ -> decl - -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name -restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) - | DataType <- new_or_data - = defn { dd_cons = restrictCons names cons } - | otherwise -- Newtype - = case restrictCons names cons of - [] -> defn { dd_ND = DataType, dd_cons = [] } - [con] -> defn { dd_cons = [con] } - _ -> error "Should not happen" - -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case getConDetails h98d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - h98d = h98ConDecl d - h98ConDecl c@ConDeclH98{} = c - h98ConDecl c@ConDeclGADT{} = c' - where - (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl Name - c' = ConDeclH98 - { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_implicit = mempty - , hsq_explicit = tvs - , hsq_dependent = emptyNameSet } - , con_cxt = Just cxt - , con_details = details - , con_doc = con_doc c - } - - field_avail :: LConDeclField Name -> Bool - field_avail (L _ (ConDeclField fs _ _)) - = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ t _ <- flds ] - - keep _ = Nothing - -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) - - -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] - -emptyHsQTvs :: LHsQTyVars Name --- This function is here, rather than in HsTypes, because it *renamed*, but --- does not necessarily have all the rigt kind variables. It is used --- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] - , hsq_dependent = error "haddock:emptyHsQTvs" } - - --------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. -------------------------------------------------------------------------------- - baseName :: ModuleName -> FilePath baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString @@ -256,16 +145,10 @@ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] -contentsHtmlFile, indexHtmlFile :: String +contentsHtmlFile, indexHtmlFile, indexJsonFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" - - - -moduleIndexFrameName, mainFrameName, synopsisFrameName :: String -moduleIndexFrameName = "modules" -mainFrameName = "main" -synopsisFrameName = "synopsis" +indexJsonFile = "doc-index.json" subIndexHtmlFile :: String -> String @@ -326,17 +209,22 @@ ------------------------------------------------------------------------------- -jsFile :: String -jsFile = "haddock-util.js" +haddockJsFile :: String +haddockJsFile = "haddock-bundle.min.js" +jsQuickJumpFile :: String +jsQuickJumpFile = "quick-jump.min.js" +quickJumpCssFile :: String +quickJumpCssFile = "quick-jump.css" + ------------------------------------------------------------------------------- -- * Misc. ------------------------------------------------------------------------------- getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName +getProgramName = fmap (`withoutSuffix` ".bin") getProgName where str `withoutSuffix` suff | suff `isSuffixOf` str = take (length str - length suff) str | otherwise = str @@ -345,25 +233,6 @@ bye :: String -> IO a bye s = putStr s >> exitSuccess - -dieMsg :: String -> IO () -dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - - -noDieMsg :: String -> IO () -noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) - - -mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] -mapSnd _ [] = [] -mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs - - -mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = liftM Just (f a) - - escapeStr :: String -> String escapeStr = escapeURIString isUnreserved @@ -400,7 +269,20 @@ isDigitChar c = c >= '0' && c <= '9' isAlphaNumChar c = isAlphaChar c || isDigitChar c +-- | Utility to write output to UTF-8 encoded files. +-- +-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from +-- 'getLocaleEncoding', and on some platforms (like Windows) this default +-- encoding isn't enough for the characters we want to write. +writeUtf8File :: FilePath -> String -> IO () +writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do + hSetEncoding h utf8 + hPutStr h contents +withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a +withTempDir dir = bracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) + ----------------------------------------------------------------------------- -- * HTML cross references -- @@ -447,71 +329,6 @@ spanWith p xs@(a:as) | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) | otherwise = ([],xs) - - ------------------------------------------------------------------------------ --- * Put here temporarily ------------------------------------------------------------------------------ - - -markup :: DocMarkup id a -> Doc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - - --- | The identity markup -idMarkup :: DocMarkup a (Doc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupMathInline = DocMathInline, - markupMathDisplay = DocMathDisplay, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - ----------------------------------------------------------------------------- -- * System tools diff --git a/src/Haddock/Utils/Json.hs b/src/Haddock/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/Json.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | Minimal JSON / RFC 7159 support +-- +-- The API is heavily inspired by @aeson@'s API but puts emphasis on +-- simplicity rather than performance. The 'ToJSON' instances are +-- intended to have an encoding compatible with @aeson@'s encoding. +-- +module Haddock.Utils.Json + ( Value(..) + , Object, object, Pair, (.=) + , encodeToString + , encodeToBuilder + , ToJSON(toJSON) + + , Parser(..) + , Result(..) + , FromJSON(parseJSON) + , withObject + , withArray + , withString + , withDouble + , withBool + , fromJSON + , parse + , parseEither + , (.:) + , (.:?) + , decode + , decodeWith + , eitherDecode + , eitherDecodeWith + , decodeFile + , eitherDecodeFile + ) + where + +import Control.Applicative (Alternative (..)) +import Control.Monad (MonadPlus (..), zipWithM, (>=>)) +import qualified Control.Monad as Monad +import qualified Control.Monad.Fail as Fail + +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB +import Data.Char +import Data.Int +import Data.Word +import Data.List (intersperse) +import Data.Monoid + +import GHC.Natural + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy +import qualified Text.ParserCombinators.Parsec as Parsec + +import Haddock.Utils.Json.Types +import Haddock.Utils.Json.Parser + + +infixr 8 .= + +-- | A key-value pair for encoding a JSON object. +(.=) :: ToJSON v => String -> v -> Pair +k .= v = (k, toJSON v) + + +-- | A type that can be converted to JSON. +class ToJSON a where + -- | Convert a Haskell value to a JSON-friendly intermediate type. + toJSON :: a -> Value + +instance ToJSON () where + toJSON () = Array [] + +instance ToJSON Value where + toJSON = id + +instance ToJSON Bool where + toJSON = Bool + +instance ToJSON a => ToJSON [a] where + toJSON = Array . map toJSON + +instance ToJSON a => ToJSON (Maybe a) where + toJSON Nothing = Null + toJSON (Just a) = toJSON a + +instance (ToJSON a,ToJSON b) => ToJSON (a,b) where + toJSON (a,b) = Array [toJSON a, toJSON b] + +instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where + toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] + +instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where + toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] + +instance ToJSON Float where + toJSON = Number . realToFrac + +instance ToJSON Double where + toJSON = Number + +instance ToJSON Int where toJSON = Number . realToFrac +instance ToJSON Int8 where toJSON = Number . realToFrac +instance ToJSON Int16 where toJSON = Number . realToFrac +instance ToJSON Int32 where toJSON = Number . realToFrac + +instance ToJSON Word where toJSON = Number . realToFrac +instance ToJSON Word8 where toJSON = Number . realToFrac +instance ToJSON Word16 where toJSON = Number . realToFrac +instance ToJSON Word32 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Int64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Word64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Integer where toJSON = Number . fromInteger + +------------------------------------------------------------------------------ +-- 'BB.Builder'-based encoding + +-- | Serialise value as JSON/UTF8-encoded 'Builder' +encodeToBuilder :: ToJSON a => a -> Builder +encodeToBuilder = encodeValueBB . toJSON + +encodeValueBB :: Value -> Builder +encodeValueBB jv = case jv of + Bool True -> "true" + Bool False -> "false" + Null -> "null" + Number n + | isNaN n || isInfinite n -> encodeValueBB Null + | Just i <- doubleToInt64 n -> BB.int64Dec i + | otherwise -> BB.doubleDec n + Array a -> encodeArrayBB a + String s -> encodeStringBB s + Object o -> encodeObjectBB o + +encodeArrayBB :: [Value] -> Builder +encodeArrayBB [] = "[]" +encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' + where + go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB + +encodeObjectBB :: Object -> Builder +encodeObjectBB [] = "{}" +encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' + where + go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair + encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x + +encodeStringBB :: String -> Builder +encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' + where + go = BB.stringUtf8 . escapeString + +------------------------------------------------------------------------------ +-- 'String'-based encoding + +-- | Serialise value as JSON-encoded Unicode 'String' +encodeToString :: ToJSON a => a -> String +encodeToString jv = encodeValue (toJSON jv) [] + +encodeValue :: Value -> ShowS +encodeValue jv = case jv of + Bool b -> showString (if b then "true" else "false") + Null -> showString "null" + Number n + | isNaN n || isInfinite n -> encodeValue Null + | Just i <- doubleToInt64 n -> shows i + | otherwise -> shows n + Array a -> encodeArray a + String s -> encodeString s + Object o -> encodeObject o + +encodeArray :: [Value] -> ShowS +encodeArray [] = showString "[]" +encodeArray jvs = ('[':) . go jvs . (']':) + where + go [] = id + go [x] = encodeValue x + go (x:xs) = encodeValue x . (',':) . go xs + +encodeObject :: Object -> ShowS +encodeObject [] = showString "{}" +encodeObject jvs = ('{':) . go jvs . ('}':) + where + go [] = id + go [(l,x)] = encodeString l . (':':) . encodeValue x + go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs + +encodeString :: String -> ShowS +encodeString str = ('"':) . showString (escapeString str) . ('"':) + +------------------------------------------------------------------------------ +-- helpers + +-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not +-- representable loss-free as integral 'Int64' value. +doubleToInt64 :: Double -> Maybe Int64 +doubleToInt64 x + | fromInteger x' == x + , x' <= toInteger (maxBound :: Int64) + , x' >= toInteger (minBound :: Int64) + = Just (fromIntegral x') + | otherwise = Nothing + where + x' = round x + +-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" +escapeString :: String -> String +escapeString s + | not (any needsEscape s) = s + | otherwise = escape s + where + escape [] = [] + escape (x:xs) = case x of + '\\' -> '\\':'\\':escape xs + '"' -> '\\':'"':escape xs + '\b' -> '\\':'b':escape xs + '\f' -> '\\':'f':escape xs + '\n' -> '\\':'n':escape xs + '\r' -> '\\':'r':escape xs + '\t' -> '\\':'t':escape xs + c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs + | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs + | otherwise -> c : escape xs + + -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF + needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] + +------------------------------------------------------------------------------ +-- FromJSON + +-- | Elements of a JSON path used to describe the location of an +-- error. +data JSONPathElement + = Key String + -- ^ JSON path element of a key into an object, + -- \"object.key\". + | Index !Int + -- ^ JSON path element of an index into an + -- array, \"array[index]\". + deriving (Eq, Show, Ord) + +type JSONPath = [JSONPathElement] + +-- | Failure continuation. +type Failure f r = JSONPath -> String -> f r + +-- | Success continuation. +type Success a f r = a -> f r + +newtype Parser a = Parser { + runParser :: forall f r. + JSONPath + -> Failure f r + -> Success a f r + -> f r + } + +modifyFailure :: (String -> String) -> Parser a -> Parser a +modifyFailure f (Parser p) = Parser $ \path kf ks -> + p path (\p' m -> kf p' (f m)) ks + +prependFailure :: String -> Parser a -> Parser a +prependFailure = modifyFailure . (++) + +prependContext :: String -> Parser a -> Parser a +prependContext name = prependFailure ("parsing " ++ name ++ " failed, ") + +typeMismatch :: String -> Value -> Parser a +typeMismatch expected actual = + fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual + +instance Monad.Monad Parser where + m >>= g = Parser $ \path kf ks -> + runParser m path kf + (\a -> runParser (g a) path kf ks) + return = pure + +instance Fail.MonadFail Parser where + fail msg = Parser $ \path kf _ks -> kf (reverse path) msg + +instance Functor Parser where + fmap f m = Parser $ \path kf ks -> + let ks' a = ks (f a) + in runParser m path kf ks' + +instance Applicative Parser where + pure a = Parser $ \_path _kf ks -> ks a + (<*>) = apP + +instance Alternative Parser where + empty = fail "empty" + (<|>) = mplus + +instance MonadPlus Parser where + mzero = fail "mzero" + mplus a b = Parser $ \path kf ks -> + runParser a path (\_ _ -> runParser b path kf ks) ks + +instance Semigroup (Parser a) where + (<>) = mplus + +instance Monoid (Parser a) where + mempty = fail "mempty" + mappend = (<>) + +apP :: Parser (a -> b) -> Parser a -> Parser b +apP d e = do + b <- d + b <$> e + +() :: Parser a -> JSONPathElement -> Parser a +p pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks + +parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a +parseIndexedJSON p idx value = p value Index idx + +unexpected :: Value -> Parser a +unexpected actual = fail $ "unexpected " ++ typeOf actual + +withObject :: String -> (Object -> Parser a) -> Value -> Parser a +withObject _ f (Object obj) = f obj +withObject name _ v = prependContext name (typeMismatch "Object" v) + +withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a +withArray _ f (Array arr) = f arr +withArray name _ v = prependContext name (typeMismatch "Array" v) + +withString :: String -> (String -> Parser a) -> Value -> Parser a +withString _ f (String txt) = f txt +withString name _ v = prependContext name (typeMismatch "String" v) + +withDouble :: String -> (Double -> Parser a) -> Value -> Parser a +withDouble _ f (Number duble) = f duble +withDouble name _ v = prependContext name (typeMismatch "Number" v) + +withBool :: String -> (Bool -> Parser a) -> Value -> Parser a +withBool _ f (Bool arr) = f arr +withBool name _ v = prependContext name (typeMismatch "Boolean" v) + +class FromJSON a where + parseJSON :: Value -> Parser a + + parseJSONList :: Value -> Parser [a] + parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..]) + +instance FromJSON Bool where + parseJSON (Bool b) = pure b + parseJSON v = typeMismatch "Bool" v + +instance FromJSON () where + parseJSON = + withArray "()" $ \v -> + if null v + then pure () + else prependContext "()" $ fail "expected an empty array" + +instance FromJSON Char where + parseJSON = withString "Char" parseChar + + parseJSONList (String s) = pure s + parseJSONList v = typeMismatch "String" v + +parseChar :: String -> Parser Char +parseChar t = + if length t == 1 + then pure $ head t + else prependContext "Char" $ fail "expected a string of length 1" + +parseRealFloat :: RealFloat a => String -> Value -> Parser a +parseRealFloat _ (Number s) = pure $ realToFrac s +parseRealFloat _ Null = pure (0/0) +parseRealFloat name v = prependContext name (unexpected v) + +instance FromJSON Double where + parseJSON = parseRealFloat "Double" + +instance FromJSON Float where + parseJSON = parseRealFloat "Float" + +parseNatural :: Integer -> Parser Natural +parseNatural integer = + if integer < 0 then + fail $ "parsing Natural failed, unexpected negative number " <> show integer + else + pure $ fromIntegral integer + +parseIntegralFromDouble :: Integral a => Double -> Parser a +parseIntegralFromDouble d = + let r = toRational d + x = truncate r + in if toRational x == r + then pure x + else fail $ "unexpected floating number " <> show d + +parseIntegral :: Integral a => String -> Value -> Parser a +parseIntegral name = withDouble name parseIntegralFromDouble + +instance FromJSON Integer where + parseJSON = parseIntegral "Integer" + +instance FromJSON Natural where + parseJSON = withDouble "Natural" + (parseIntegralFromDouble >=> parseNatural) + +instance FromJSON Int where + parseJSON = parseIntegral "Int" + +instance FromJSON Int8 where + parseJSON = parseIntegral "Int8" + +instance FromJSON Int16 where + parseJSON = parseIntegral "Int16" + +instance FromJSON Int32 where + parseJSON = parseIntegral "Int32" + +instance FromJSON Int64 where + parseJSON = parseIntegral "Int64" + +instance FromJSON Word where + parseJSON = parseIntegral "Word" + +instance FromJSON Word8 where + parseJSON = parseIntegral "Word8" + +instance FromJSON Word16 where + parseJSON = parseIntegral "Word16" + +instance FromJSON Word32 where + parseJSON = parseIntegral "Word32" + +instance FromJSON Word64 where + parseJSON = parseIntegral "Word64" + +instance FromJSON a => FromJSON [a] where + parseJSON = parseJSONList + +data Result a = Error String + | Success a + deriving (Eq, Show) + +fromJSON :: FromJSON a => Value -> Result a +fromJSON = parse parseJSON + +parse :: (a -> Parser b) -> a -> Result b +parse m v = runParser (m v) [] (const Error) Success + +parseEither :: (a -> Parser b) -> a -> Either String b +parseEither m v = runParser (m v) [] onError Right + where onError path msg = Left (formatError path msg) + +formatError :: JSONPath -> String -> String +formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg + +formatPath :: JSONPath -> String +formatPath path = "$" ++ formatRelativePath path + +formatRelativePath :: JSONPath -> String +formatRelativePath path = format "" path + where + format :: String -> JSONPath -> String + format pfx [] = pfx + format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts + format pfx (Key key:parts) = format (pfx ++ formatKey key) parts + + formatKey :: String -> String + formatKey key + | isIdentifierKey key = "." ++ key + | otherwise = "['" ++ escapeKey key ++ "']" + + isIdentifierKey :: String -> Bool + isIdentifierKey [] = False + isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs + + escapeKey :: String -> String + escapeKey = concatMap escapeChar + + escapeChar :: Char -> String + escapeChar '\'' = "\\'" + escapeChar '\\' = "\\\\" + escapeChar c = [c] + +explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a +explicitParseField p obj key = + case key `lookup` obj of + Nothing -> fail $ "key " ++ key ++ " not found" + Just v -> p v Key key + +(.:) :: FromJSON a => Object -> String -> Parser a +(.:) = explicitParseField parseJSON + +explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a) +explicitParseFieldMaybe p obj key = + case key `lookup` obj of + Nothing -> pure Nothing + Just v -> Just <$> p v Key key + +(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a) +(.:?) = explicitParseFieldMaybe parseJSON + + +decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a +decodeWith decoder bsl = + case Parsec.parse parseJSONValue "" bsl of + Left _ -> Nothing + Right json -> + case decoder json of + Success a -> Just a + Error _ -> Nothing + +decode :: FromJSON a => BSL.ByteString -> Maybe a +decode = decodeWith fromJSON + +eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a +eitherDecodeWith decoder bsl = + case Parsec.parse parseJSONValue "" bsl of + Left parsecError -> Left (show parsecError) + Right json -> + case decoder json of + Success a -> Right a + Error err -> Left err + +eitherDecode :: FromJSON a => BSL.ByteString -> Either String a +eitherDecode = eitherDecodeWith fromJSON + + +decodeFile :: FromJSON a => FilePath -> IO (Maybe a) +decodeFile filePath = do + parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath + case parsecResult of + Right r -> + case fromJSON r of + Success a -> return (Just a) + Error _ -> return Nothing + Left _ -> return Nothing + + +eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a) +eitherDecodeFile filePath = do + parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath + case parsecResult of + Right r -> + case fromJSON r of + Success a -> return (Right a) + Error err -> return (Left err) + Left err -> return $ Left (show err) + diff --git a/src/Haddock/Utils/Json/Parser.hs b/src/Haddock/Utils/Json/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/Json/Parser.hs @@ -0,0 +1,102 @@ +-- | Json "Parsec" parser, based on +-- [json](https://hackage.haskell.org/package/json) package. +-- +module Haddock.Utils.Json.Parser + ( parseJSONValue + ) where + +import Prelude hiding (null) + +import Control.Applicative (Alternative (..)) +import Control.Monad (MonadPlus (..)) +import Data.Char (isHexDigit) +import Data.Functor (($>)) +import qualified Data.ByteString.Lazy.Char8 as BSCL +import Numeric +import Text.Parsec.ByteString.Lazy (Parser) +import Text.ParserCombinators.Parsec (()) +import qualified Text.ParserCombinators.Parsec as Parsec + +import Haddock.Utils.Json.Types hiding (object) + +parseJSONValue :: Parser Value +parseJSONValue = Parsec.spaces *> parseValue + +tok :: Parser a -> Parser a +tok p = p <* Parsec.spaces + +parseValue :: Parser Value +parseValue = + parseNull + <|> Bool <$> parseBoolean + <|> Array <$> parseArray + <|> String <$> parseString + <|> Object <$> parseObject + <|> Number <$> parseNumber + "JSON value" + +parseNull :: Parser Value +parseNull = tok + $ Parsec.string "null" + $> Null + +parseBoolean :: Parser Bool +parseBoolean = tok + $ Parsec.string "true" $> True + <|> Parsec.string "false" $> False + +parseArray :: Parser [Value] +parseArray = + Parsec.between + (tok (Parsec.char '[')) + (tok (Parsec.char ']')) + (parseValue `Parsec.sepBy` tok (Parsec.char ',')) + +parseString :: Parser String +parseString = + Parsec.between + (tok (Parsec.char '"')) + (tok (Parsec.char '"')) + (many char) + where + char = (Parsec.char '\\' >> escapedChar) + <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\') + + escapedChar = + Parsec.char '"' $> '"' + <|> Parsec.char '\\' $> '\\' + <|> Parsec.char '/' $> '/' + <|> Parsec.char 'b' $> '\b' + <|> Parsec.char 'f' $> '\f' + <|> Parsec.char 'n' $> '\n' + <|> Parsec.char 'r' $> '\r' + <|> Parsec.char 't' $> '\t' + <|> Parsec.char 'u' *> uni + "escape character" + + uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit) + where + check x | code <= max_char = return (toEnum code) + | otherwise = mzero + where code = fst $ head $ readHex x + max_char = fromEnum (maxBound :: Char) + +parseObject :: Parser Object +parseObject = + Parsec.between + (tok (Parsec.char '{')) + (tok (Parsec.char '}')) + (field `Parsec.sepBy` tok (Parsec.char ',')) + where + field :: Parser (String, Value) + field = (,) + <$> parseString + <* tok (Parsec.char ':') + <*> parseValue + +parseNumber :: Parser Double +parseNumber = tok $ do + s <- BSCL.unpack <$> Parsec.getInput + case readSigned readFloat s of + [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n + _ -> mzero diff --git a/src/Haddock/Utils/Json/Types.hs b/src/Haddock/Utils/Json/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/Json/Types.hs @@ -0,0 +1,42 @@ +module Haddock.Utils.Json.Types + ( Value(..) + , typeOf + , Pair + , Object + , object + ) where + +import Data.String + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) + +typeOf :: Value -> String +typeOf v = case v of + Object _ -> "Object" + Array _ -> "Array" + String _ -> "String" + Number _ -> "Number" + Bool _ -> "Boolean" + Null -> "Null" + +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) + +-- | A JSON \"object\" (key/value map). +type Object = [Pair] + +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object + +instance IsString Value where + fromString = String diff --git a/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/test/Haddock/Backends/Hyperlinker/ParserSpec.hs --- a/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -1,98 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where - import Test.Hspec import Test.QuickCheck +import GHC ( runGhc, getSessionDynFlags ) +import GHC.Driver.Session ( DynFlags ) +import Control.Monad.IO.Class + +import Data.String ( fromString ) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + +import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types +withDynFlags :: (DynFlags -> IO ()) -> IO () +withDynFlags cont = do + libDir <- fmap snd (getGhcDirs []) + runGhc libDir $ do + dflags <- getSessionDynFlags + liftIO $ cont dflags + main :: IO () main = hspec spec spec :: Spec -spec = do - describe "parse" parseSpec +spec = describe "parse" parseSpec +-- | Defined for its instance of 'Arbitrary'. Represents strings that, when +-- considered as GHC source, won't be rewritten. +newtype NoGhcRewrite = NoGhcRewrite String deriving (Show, Eq) + +-- | Filter out strings where GHC would replace/remove some characters during +-- lexing. +noGhcRewrite :: String -> Bool +noGhcRewrite ('\t':_) = False -- GHC replaces tabs with 8 spaces +noGhcRewrite ('\r':_) = False +noGhcRewrite ('\f':_) = False +noGhcRewrite ('\v':_) = False +noGhcRewrite (' ':'\n':_) = False -- GHC strips whitespace on empty lines +noGhcRewrite (_:s) = noGhcRewrite s +noGhcRewrite "" = True + +instance Arbitrary NoGhcRewrite where + arbitrary = fmap NoGhcRewrite (arbitrary `suchThat` noGhcRewrite) + shrink (NoGhcRewrite src) = [ NoGhcRewrite shrunk + | shrunk <- shrink src + , noGhcRewrite shrunk + ] + + parseSpec :: Spec -parseSpec = do +parseSpec = around withDynFlags $ do - it "is total" $ - property $ \src -> length (parse src) `shouldSatisfy` (>= 0) + it "is total" $ \dflags -> + property $ \src -> length (parse dflags "" (fromString src)) `shouldSatisfy` (>= 0) - it "retains file layout" $ - property $ \src -> concatMap tkValue (parse src) == src + it "retains file layout" $ \dflags -> + property $ \(NoGhcRewrite src) -> + let orig = fromString src + lexed = BS.concat (map tkValue (parse dflags "" orig)) + in lexed == orig context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ - "-- some very simple comment\nidentifier" - `shouldParseTo` - [TkComment, TkSpace, TkIdentifier] + it "should ignore content until the end of line" $ \dflags -> + shouldParseTo + "-- some very simple comment\nidentifier" + [TkComment, TkSpace, TkIdentifier] + dflags - it "should allow endline escaping" $ - "-- first line\\\nsecond line\\\nand another one" - `shouldParseTo` - [TkComment] + it "should allow endline escaping" $ \dflags -> + shouldParseTo + "#define first line\\\nsecond line\\\nand another one" + [TkCpp] + dflags context "when parsing multi-line comments" $ do - it "should support nested comments" $ - "{- comment {- nested -} still comment -} {- next comment -}" - `shouldParseTo` - [TkComment, TkSpace, TkComment] + it "should support nested comments" $ \dflags -> + shouldParseTo + "{- comment {- nested -} still comment -} {- next comment -}" + [TkComment, TkSpace, TkComment] + dflags - it "should distinguish compiler pragma" $ - "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" - `shouldParseTo` - [TkComment, TkPragma, TkComment] + it "should distinguish compiler pragma" $ \dflags -> + shouldParseTo + "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" + [TkComment, TkPragma, TkComment] + dflags - it "should recognize preprocessor directives" $ do - "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp] - "x # y" `shouldParseTo` - [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + it "should recognize preprocessor directives" $ \dflags -> do + shouldParseTo + "\n#define foo bar" + [TkCpp] + dflags + shouldParseTo + "x # y" + [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + dflags - it "should distinguish basic language constructs" $ do - "(* 2) <$> (\"abc\", foo)" `shouldParseTo` + it "should distinguish basic language constructs" $ \dflags -> do + + shouldParseTo + "(* 2) <$> (\"abc\", foo)" [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] - "let foo' = foo in foo' + foo'" `shouldParseTo` + dflags + + shouldParseTo + "let foo' = foo in foo' + foo'" [ TkKeyword, TkSpace, TkIdentifier , TkSpace, TkGlyph, TkSpace , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] - "square x = y^2 where y = x" `shouldParseTo` + dflags + + shouldParseTo + "square x = y^2 where y = x" [ TkIdentifier, TkSpace, TkIdentifier , TkSpace, TkGlyph, TkSpace , TkIdentifier, TkOperator, TkNumber , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] + dflags - it "should parse do-notation syntax" $ do - "do { foo <- getLine; putStrLn foo }" `shouldParseTo` + it "should parse do-notation syntax" $ \dflags -> do + shouldParseTo + "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] + dflags - unlines - [ "do" - , " foo <- getLine" - , " putStrLn foo" - ] `shouldParseTo` + shouldParseTo + (fromString $ unlines + [ "do" + , " foo <- getLine" + , " putStrLn foo" + ]) [ TkKeyword, TkSpace, TkIdentifier , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] - - -shouldParseTo :: String -> [TokenType] -> Expectation -str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens + dflags + where + shouldParseTo :: ByteString -> [TokenType] -> DynFlags -> Expectation + shouldParseTo str tokens dflags = [ tkType tok + | tok <- parse dflags "" str + , not (BS.null (tkValue tok)) ] `shouldBe` tokens