diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.22.0 +version: 2.23.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -29,22 +29,23 @@ 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.12.0 - , Cabal ^>= 2.4.0 - , ghc ^>= 8.6 + build-depends: base ^>= 4.13.0 + , ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.7.0 + , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -64,7 +65,7 @@ ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 ghc-options: -Wall if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances exposed-modules: Documentation.Haddock @@ -95,7 +96,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 @@ -128,7 +128,6 @@ Haddock Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker - Haddock.Backends.Hyperlinker.Ast Haddock.Backends.Hyperlinker.Renderer Haddock.Backends.Hyperlinker.Utils Haddock.Backends.LaTeX @@ -166,13 +165,12 @@ Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: Cabal ^>= 2.4 - , ghc ^>= 8.6 - , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.7.0 + build-depends: ghc ^>= 8.8 + , ghc-paths ^>= 0.1.0.12 + , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 - , hspec >= 2.4.4 && < 2.6 - , QuickCheck ^>= 2.11 + , hspec >= 2.4.4 && < 2.8 + , QuickCheck >= 2.11 && < 2.14 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version @@ -188,7 +186,7 @@ , transformers build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.6 + hspec-discover:hspec-discover >= 2.4.4 && < 2.8 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 { 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,877 @@ +/* @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 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,647 +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 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 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; -} - -:target { - background-color: #ffff00; -} - -/* @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 --- a/resources/html/haddock-bundle.min.js +++ b/resources/html/haddock-bundle.min.js @@ -1,2 +1,2 @@ -!function e(t,n,o){function r(s,a){if(!n[s]){if(!t[s]){var l="function"==typeof require&&require;if(!a&&l)return l(s,!0);if(i)return i(s,!0);var c=new Error("Cannot find module '"+s+"'");throw c.code="MODULE_NOT_FOUND",c}var u=n[s]={exports:{}};t[s][0].call(u.exports,function(e){var n=t[s][1][e];return r(n||e)},u,u.exports,e,t,n,o)}return n[s].exports}for(var i="function"==typeof require&&require,s=0;s element with id '"+e+"'");return t}function r(e){for(var t=e.target,n=t.id,r=o(n),i=r.element.open,s=0,l=r.toggles;s0&&(d[n.id]={element:n,openByDefault:!!n.open,toggles:[]},n.addEventListener("toggle",r))}}function s(e){var t=o(e).element;t.open=!t.open}function a(){var e=Object.keys(p);document.cookie="toggled="+encodeURIComponent(e.join("+"))}function l(){var e=h.getCookie("toggled");if(e)for(var t=0,n=e.split("+");t=0&&e.followActiveLink()),"s"===t.key&&"input"!==t.target.tagName.toLowerCase()&&(t.preventDefault(),e.show())})},t.prototype.hide=function(){this.setState({isVisible:!1,searchString:""})},t.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},t.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},t.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t={};this.state.fuse.search(e).forEach(function(e){var n=e.item.module;(t[n]||(t[n]=[])).push(e)});var n=[];for(var o in t)!function(e){var o=t[e],r=0;o.forEach(function(e){r+=1/e.score}),n.push({module:e,totalScore:1/r,items:o})}(o);n.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:n})},t.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.top=0}function s(e,t){var n=o(e.className||"");n.indexOf(" "+t+" ")<0&&(e.className=r(n+" "+t))}function a(e,t){var n=o(e.className||"");n=n.replace(" "+t+" "," "),e.className=r(n)}function l(e,t,n,o){return null==o&&(o=!i(e,t)),o?(a(e,n),s(e,t)):(a(e,t),s(e,n)),o}function c(e){var t=document.getElementById("page-menu");if(t&&t.firstChild){var n=t.firstChild.cloneNode(!1);n.innerHTML=e,t.appendChild(n)}}function u(){return Array.prototype.slice.call(document.getElementsByTagName("link")).filter(function(e){return-1!=e.rel.indexOf("style")&&e.title})}function h(){var e=u(),t="";e.forEach(function(e){t+="
  • "+e.title+"
    • "}),e.length>1&&c("")}function d(e){for(var t=u(),n=null,o=0;on)return i(e,this.pattern,o);var r=this.options,a=r.location,l=r.distance,c=r.threshold,u=r.findAllMatches,h=r.minMatchCharLength;return s(e,this.pattern,this.patternAlphabet,{location:a,distance:l,threshold:c,findAllMatches:u,minMatchCharLength:h})}}]),e}();e.exports=l},function(e,t,n){"use strict";var o=n(0),r=function e(t,n,r){if(n){var i=n.indexOf("."),s=n,a=null;-1!==i&&(s=n.slice(0,i),a=n.slice(i+1));var l=t[s];if(null!==l&&void 0!==l)if(a||"string"!=typeof l&&"number"!=typeof l)if(o(l))for(var c=0,u=l.length;c0&&void 0!==arguments[0]?arguments[0]:[],t=arguments.length>1&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i=t&&n.push([o,r]),o=-1)}return e[i-1]&&i-o>=t&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o2&&void 0!==arguments[2]?arguments[2]:/ +/g,r=new RegExp(t.replace(o,"\\$&").replace(n,"|")),i=e.match(r),s=!!i,a=[];if(s)for(var l=0,c=i.length;l=E;P-=1){var R=P-1,U=n[e.charAt(R)];if(U&&(b[R]=1),j[P]=(j[P+1]<<1|1)&U,0!==I&&(j[P]|=(L[P+1]|L[P])<<1|1|L[P+1]),j[P]&N&&(C=o(t,{errors:I,currentLocation:R,expectedLocation:g,distance:c}))<=y){if(y=C,(_=R)<=g)break;E=Math.max(1,2*g-_)}}if(o(t,{errors:I+1,currentLocation:g,expectedLocation:g,distance:c})>y)break;L=j}return{isMatch:_>=0,score:0===C?.001:C,matchedIndices:r(b,v)}}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;n0&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o0&&void 0!==arguments[0]?arguments[0]:[],t=arguments[1],n=this.list,o={},r=[];if("string"==typeof n[0]){for(var i=0,s=n.length;i1)throw new Error("Key weight has to be > 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,l=e.index,c=t.tokenSearchers,u=void 0===c?[]:c,h=t.fullSearcher,d=void 0===h?[]:h,p=t.resultMap,f=void 0===p?{}:p,v=t.results,g=void 0===v?[]:v;if(void 0!==i&&null!==i){var m=!1,y=-1,_=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var k=d.search(i);if(this._log('Full text: "'+i+'", score: '+k.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),x=[],w=0;w-1&&(E=(E+y)/2),this._log("Score average:",E);var T=!this.options.tokenize||!this.options.matchAllTokens||_>=u.length;if(this._log("\nCheck Matches: "+T),(m||k.isMatch)&&T){var j=f[l];j?j.output.push({key:n,arrayIndex:r,value:i,score:E,matchedIndices:k.matchedIndices}):(f[l]={item:s,output:[{key:n,arrayIndex:r,value:i,score:E,matchedIndices:k.matchedIndices}]},g.push(f[l]))}}else if(a(i))for(var P=0,R=i.length;P-1&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;o2;)A.push(arguments[s]);for(n&&null!=n.children&&(A.length||A.push(n.children),delete n.children);A.length;)if((r=A.pop())&&void 0!==r.pop)for(s=r.length;s--;)A.push(r[s]);else"boolean"==typeof r&&(r=null),(i="function"!=typeof t)&&(null==r?r="":"number"==typeof r?r=String(r):"string"!=typeof r&&(i=!1)),i&&o?a[a.length-1]+=r:a===O?a=[r]:a.push(r),o=i;var l=new e;return l.nodeName=t,l.children=a,l.attributes=null==n?void 0:n,l.key=null==n?void 0:n.key,void 0!==I.vnode&&I.vnode(l),l}function o(e,t){for(var n in t)e[n]=t[n];return e}function r(e){!e.__d&&(e.__d=!0)&&1==j.push(e)&&(I.debounceRendering||E)(i)}function i(){var e,t=j;for(j=[];e=t.pop();)e.__d&&L(e)}function s(e,t,n){return"string"==typeof t||"number"==typeof t?void 0!==e.splitText:"string"==typeof t.nodeName?!e._componentConstructor&&a(e,t.nodeName):n||e._componentConstructor===t.nodeName}function a(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function l(e){var t=o({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var r in n)void 0===t[r]&&(t[r]=n[r]);return t}function c(e,t){var n=t?document.createElementNS("http://www.w3.org/2000/svg",e):document.createElement(e);return n.__n=e,n}function u(e){var t=e.parentNode;t&&t.removeChild(e)}function h(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===T.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,p,s):e.removeEventListener(t,p,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e)d(e,t,null==o?"":o),null!=o&&!1!==o||e.removeAttribute(t);else{var a=r&&t!==(t=t.replace(/^xlink\:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function d(e,t,n){try{e[t]=n}catch(e){}}function p(e){return this.__l[e.type](I.event&&I.event(e)||e)}function f(){for(var e;e=P.pop();)I.afterMount&&I.afterMount(e),e.componentDidMount&&e.componentDidMount()}function v(e,t,n,o,r,i){R++||(U=null!=r&&void 0!==r.ownerSVGElement,D=null!=e&&!("__preactattr_"in e));var s=g(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(D=!1,i||f()),s}function g(e,t,n,o,r){var i=e,s=U;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),y(e,!0))),i.__preactattr_=!0,i;var l=t.nodeName;if("function"==typeof l)return C(e,t,n,o);if(U="svg"===l||"foreignObject"!==l&&U,l=String(l),(!e||!a(e,l))&&(i=c(l,U),e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),y(e,!0)}var u=i.firstChild,h=i.__preactattr_,d=t.children;if(null==h){h=i.__preactattr_={};for(var p=i.attributes,f=p.length;f--;)h[p[f].name]=p[f].value}return!D&&d&&1===d.length&&"string"==typeof d[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=d[0]&&(u.nodeValue=d[0]):(d&&d.length||null!=u)&&m(i,d,n,o,D||null!=h.dangerouslySetInnerHTML),k(i,t.attributes,h),U=s,i}function m(e,t,n,o,r){var i,a,l,c,h,d=e.childNodes,p=[],f={},v=0,m=0,_=d.length,k=0,b=t?t.length:0;if(0!==_)for(L=0;L<_;L++){var x=d[L],w=x.__preactattr_;null!=(S=b&&w?x._component?x._component.__k:w.key:null)?(v++,f[S]=x):(w||(void 0!==x.splitText?!r||x.nodeValue.trim():r))&&(p[k++]=x)}if(0!==b)for(L=0;L2?[].slice.call(arguments,2):e.children)},Component:N,render:function(e,t,n){return v(n,e,{},!1,t,!1)},rerender:i,options:I};void 0!==t?t.exports=F:self.preact=F}()},{}]},{},[3]); +!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&&e.followActiveLink()),"s"===t.key&&"input"!==t.target.tagName.toLowerCase()&&(t.preventDefault(),e.show())})},t.prototype.hide=function(){this.setState({isVisible:!1,searchString:""})},t.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},t.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},t.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t={};this.state.fuse.search(e).forEach(function(e){var n=e.item.module;(t[n]||(t[n]=[])).push(e)});var n=[];for(var o in t)!function(e){var o=t[e],r=0;o.forEach(function(e){r+=1/e.score}),n.push({module:e,totalScore:1/r,items:o})}(o);n.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:n})},t.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return i(e,this.pattern,o);var r=this.options,a=r.location,l=r.distance,c=r.threshold,u=r.findAllMatches,h=r.minMatchCharLength;return s(e,this.pattern,this.patternAlphabet,{location:a,distance:l,threshold:c,findAllMatches:u,minMatchCharLength:h})}}]),e}();e.exports=l},function(e,t,n){"use strict";var o=n(0),r=function e(t,n,r){if(n){var i=n.indexOf("."),s=n,a=null;-1!==i&&(s=n.slice(0,i),a=n.slice(i+1));var l=t[s];if(null!==l&&void 0!==l)if(a||"string"!=typeof l&&"number"!=typeof l)if(o(l))for(var c=0,u=l.length;c0&&void 0!==arguments[0]?arguments[0]:[],t=arguments.length>1&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i=t&&n.push([o,r]),o=-1)}return e[i-1]&&i-o>=t&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o2&&void 0!==arguments[2]?arguments[2]:/ +/g,r=new RegExp(t.replace(o,"\\$&").replace(n,"|")),i=e.match(r),s=!!i,a=[];if(s)for(var l=0,c=i.length;l=O;E-=1){var R=E-1,U=n[e.charAt(R)];if(U&&(b[R]=1),P[E]=(P[E+1]<<1|1)&U,0!==I&&(P[E]|=(L[E+1]|L[E])<<1|1|L[E+1]),P[E]&N&&(C=o(t,{errors:I,currentLocation:R,expectedLocation:_,distance:c}))<=m){if(m=C,(y=R)<=_)break;O=Math.max(1,2*_-y)}}if(o(t,{errors:I+1,currentLocation:_,expectedLocation:_,distance:c})>m)break;L=P}return{isMatch:y>=0,score:0===C?.001:C,matchedIndices:r(b,v)}}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;n0&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o0&&void 0!==arguments[0]?arguments[0]:[],t=arguments[1],n=this.list,o={},r=[];if("string"==typeof n[0]){for(var i=0,s=n.length;i1)throw new Error("Key weight has to be > 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,l=e.index,c=t.tokenSearchers,u=void 0===c?[]:c,h=t.fullSearcher,p=void 0===h?[]:h,d=t.resultMap,f=void 0===d?{}:d,v=t.results,_=void 0===v?[]:v;if(void 0!==i&&null!==i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var k=p.search(i);if(this._log('Full text: "'+i+'", score: '+k.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),x=[],w=0;w-1&&(O=(O+m)/2),this._log("Score average:",O);var j=!this.options.tokenize||!this.options.matchAllTokens||y>=u.length;if(this._log("\nCheck Matches: "+j),(g||k.isMatch)&&j){var P=f[l];P?P.output.push({key:n,arrayIndex:r,value:i,score:O,matchedIndices:k.matchedIndices}):(f[l]={item:s,output:[{key:n,arrayIndex:r,value:i,score:O,matchedIndices:k.matchedIndices}]},_.push(f[l]))}}else if(a(i))for(var E=0,R=i.length;E-1&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;o2;)A.push(arguments[s]);for(n&&null!=n.children&&(A.length||A.push(n.children),delete n.children);A.length;)if((r=A.pop())&&void 0!==r.pop)for(s=r.length;s--;)A.push(r[s]);else"boolean"==typeof r&&(r=null),(i="function"!=typeof t)&&(null==r?r="":"number"==typeof r?r=String(r):"string"!=typeof r&&(i=!1)),i&&o?a[a.length-1]+=r:a===T?a=[r]:a.push(r),o=i;var l=new e;return l.nodeName=t,l.children=a,l.attributes=null==n?void 0:n,l.key=null==n?void 0:n.key,void 0!==I.vnode&&I.vnode(l),l}function o(e,t){for(var n in t)e[n]=t[n];return e}function r(e){!e.__d&&(e.__d=!0)&&1==P.push(e)&&(I.debounceRendering||O)(i)}function i(){var e,t=P;for(P=[];e=t.pop();)e.__d&&L(e)}function s(e,t,n){return"string"==typeof t||"number"==typeof t?void 0!==e.splitText:"string"==typeof t.nodeName?!e._componentConstructor&&a(e,t.nodeName):n||e._componentConstructor===t.nodeName}function a(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function l(e){var t=o({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var r in n)void 0===t[r]&&(t[r]=n[r]);return t}function c(e,t){var n=t?document.createElementNS("http://www.w3.org/2000/svg",e):document.createElement(e);return n.__n=e,n}function u(e){var t=e.parentNode;t&&t.removeChild(e)}function h(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===j.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,d,s):e.removeEventListener(t,d,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e)p(e,t,null==o?"":o),null!=o&&!1!==o||e.removeAttribute(t);else{var a=r&&t!==(t=t.replace(/^xlink\:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function p(e,t,n){try{e[t]=n}catch(e){}}function d(e){return this.__l[e.type](I.event&&I.event(e)||e)}function f(){for(var e;e=E.pop();)I.afterMount&&I.afterMount(e),e.componentDidMount&&e.componentDidMount()}function v(e,t,n,o,r,i){R++||(U=null!=r&&void 0!==r.ownerSVGElement,D=null!=e&&!("__preactattr_"in e));var s=_(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(D=!1,i||f()),s}function _(e,t,n,o,r){var i=e,s=U;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),m(e,!0))),i.__preactattr_=!0,i;var l=t.nodeName;if("function"==typeof l)return C(e,t,n,o);if(U="svg"===l||"foreignObject"!==l&&U,l=String(l),(!e||!a(e,l))&&(i=c(l,U),e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),m(e,!0)}var u=i.firstChild,h=i.__preactattr_,p=t.children;if(null==h){h=i.__preactattr_={};for(var d=i.attributes,f=d.length;f--;)h[d[f].name]=d[f].value}return!D&&p&&1===p.length&&"string"==typeof p[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=p[0]&&(u.nodeValue=p[0]):(p&&p.length||null!=u)&&g(i,p,n,o,D||null!=h.dangerouslySetInnerHTML),k(i,t.attributes,h),U=s,i}function g(e,t,n,o,r){var i,a,l,c,h,p=e.childNodes,d=[],f={},v=0,g=0,y=p.length,k=0,b=t?t.length:0;if(0!==y)for(L=0;L2?[].slice.call(arguments,2):e.children)},Component:N,render:function(e,t,n){return v(n,e,{},!1,t,!1)},rerender:i,options:I};void 0!==t?t.exports=F:self.preact=F}()},{}]},{},[1]); +!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)) import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) @@ -76,7 +80,7 @@ import Panic (handleGhcException) import Module import FastString -import qualified DynamicLoading +import Outputable (defaultUserStyle) -------------------------------------------------------------------------------- -- * Exception handling @@ -161,18 +165,32 @@ Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + -- 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 + unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning + when noChecks $ + hPutStrLn stderr noCheckWarning - ghc flags' $ do + ghc flags' $ withDir $ do dflags <- getDynFlags forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do - mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do - putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + logOutput dflags (defaultUserStyle dflags) (renderJson (jsonInterfaceFile ifaceFile)) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -192,17 +210,30 @@ throwE "No input file(s)." -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). liftIO $ renderStep dflags 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") 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 @@ -212,15 +243,17 @@ 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) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. let ifaceFiles = map snd packages @@ -268,9 +301,9 @@ allIfaces = map toInstalledIface ifaces ++ installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] - pkgMod = ifaceMod (head ifaces) - pkgKey = moduleUnitId pkgMod - pkgStr = Just (unitIdString pkgKey) + pkgMod = fmap ifaceMod (listToMaybe ifaces) + pkgKey = fmap moduleUnitId pkgMod + pkgStr = fmap unitIdString pkgKey pkgNameVer = modulePackageInfo dflags flags pkgMod pkgName = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer) sincePkg = case sinceQual of @@ -289,16 +322,22 @@ pkgSrcMap = Map.mapKeys moduleUnitId 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') @@ -375,7 +414,8 @@ 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" @@ -404,13 +444,14 @@ readInterfaceFiles :: MonadIO m => NameCacheAccessor m -> [(DocPaths, FilePath)] + -> Bool -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do +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 + readInterfaceFile name_cache_accessor file bypass_version_check >>= \case Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) @@ -426,14 +467,10 @@ -- | 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 - } +withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a +withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do + dynflags' <- parseGhcFlags =<< getSessionDynFlags + -- We disable pattern match warnings because than can be very -- expensive to check let dynflags'' = unsetPatternMatchWarnings $ @@ -443,10 +480,7 @@ -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' - hscenv <- GHC.getSession - dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'') - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' + ghcActs dynflags'' where -- ignore sublists of flags that start with "+RTS" and end in "-RTS" @@ -464,11 +498,19 @@ parseGhcFlags dynflags = do -- TODO: handle warnings? - let flags' = filterRtsFlags 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) + { hscTarget = HscNothing + , ghcMode = CompManager + , ghcLink = NoLink + } + flags' = filterRtsFlags flags + + (dynflags'', rest, _) <- parseDynamicFlags 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 = @@ -618,7 +660,7 @@ h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags Nothing str + return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" 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 @@ -17,14 +17,14 @@ ppHoogle ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) +import BasicTypes ( OverlapFlag(..), OverlapMode(..), SourceText(..) + , PromotionFlag(..) ) import InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) -import HsBinds (emptyLHsBinds) import GHC import Outputable import NameSet @@ -36,7 +36,6 @@ import System.Directory import System.FilePath -import System.IO prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" @@ -56,10 +55,7 @@ | 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 = @@ -80,6 +76,7 @@ f (HsQualTy x a e) = HsQualTy x a (g e) f (HsBangTy x a b) = HsBangTy x a (g b) f (HsAppTy x a b) = HsAppTy x (g a) (g b) + f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b) f (HsFunTy x a b) = HsFunTy x (g a) (g b) f (HsListTy x a) = HsListTy x (g a) f (HsTupleTy x a b) = HsTupleTy x a (map g b) @@ -266,9 +263,15 @@ -- 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 NoExt NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat)) + as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + in apps (map noLoc (c : as)) + tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn + tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k + tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" + ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where @@ -332,7 +335,7 @@ markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), markupModule = box (TagInline "a") . str, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), @@ -345,7 +348,7 @@ markupOrderedList = box (TagL 'o'), 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, 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,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker ( ppHyperlinkedSource , module Haddock.Backends.Hyperlinker.Types @@ -6,17 +7,26 @@ import Haddock.Types +import Haddock.Utils (writeUtf8File) 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 HieTypes ( HieFile(..), HieASTs(..) ) +import HieBin ( readHieFile, hie_file_result) +import Data.Map as M +import FastString ( mkFastString ) +import Module ( Module, moduleName ) +import NameCache ( initNameCache ) +import UniqSupply ( mkSplitUniqSupply ) + -- | Generate hyperlinked source for given interfaces. -- -- Note that list of interfaces should also contain interfaces normally hidden @@ -26,10 +36,10 @@ -> 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 outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile @@ -38,17 +48,39 @@ mapM_ (ppHyperlinkedModuleSource 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 :: FilePath -> Bool -> SrcMaps -> Interface -> IO () +ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of + Just hfp -> do + -- Parse the GHC-produced HIE file + u <- mkSplitUniqSupply 'a' + HieFile { hie_hs_file = file + , hie_asts = HieASTs asts + , hie_types = types + , hie_hs_src = rawSrc + } <- (hie_file_result . fst) + <$> (readHieFile (initNameCache u []) hfp) + + -- Get the AST and tokens corresponding to the source file we want + let mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup (mkFastString file) asts + tokens = parse df file rawSrc + + -- Produce and write out the hyperlinked sources + case mast of + Just ast -> + let fullAst = recoverFullIfaceTypes df types ast + in writeUtf8File path . renderToString pretty . render' fullAst $ tokens + Nothing + | M.size asts == 0 -> return () + | otherwise -> error $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + 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) -- | Name of CSS file in output directory. @@ -62,3 +94,4 @@ -- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" + 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,219 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} - -module Haddock.Backends.Hyperlinker.Ast (enrich) where - - -import qualified Haddock.Syb as Syb -import Haddock.Backends.Hyperlinker.Types - -import qualified GHC -import qualified SrcLoc -import qualified Outputable as GHC - -import Control.Applicative -import Control.Monad (guard) -import Data.Data -import qualified Data.Map.Strict as Map -import Data.Maybe - -import Prelude hiding (span) - -everythingInRenamedSource :: (Alternative f, Data x) - => (forall a. Data a => a -> f r) -> x -> f r -everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f - --- | 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 = - mkDetailsMap (concatMap ($ src) - [ variables - , types - , decls - , binds - , imports - ]) - -type LTokenDetails = [(GHC.SrcSpan, TokenDetails)] - --- | A map containing association between source locations and "details" of --- this location. --- -type DetailsMap = Map.Map Position (Span, TokenDetails) - -mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap -mkDetailsMap xs = - Map.fromListWith select_details [ (start, (span, token_details)) - | (ghc_span, token_details) <- xs - , GHC.RealSrcSpan span <- [ghc_span] - , let start = SrcLoc.realSrcSpanStart span - ] - where - -- favour token details which appear earlier in the list - select_details _new old = old - -lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan span details = do - let pos = SrcLoc.realSrcSpanStart span - (_, (tok_span, tok_details)) <- Map.lookupLE pos details - guard (tok_span `SrcLoc.containsSpan` span) - return tok_details - -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 -> LTokenDetails -variables = - everythingInRenamedSource (var `Syb.combine` rec) - where - var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) -> - 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.GhcRn) _) -> - pure (sspan, RtkVar name) - _ -> empty - --- | Obtain details map for types. -types :: GHC.RenamedSource -> LTokenDetails -types = everythingInRenamedSource ty - where - ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] - ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> - pure (sspan, RtkType (GHC.unLoc name)) - (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) -> - (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) - _ -> 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 -> LTokenDetails -binds = everythingInRenamedSource - (fun `Syb.combine` pat `Syb.combine` tvar) - where - fun term = case cast term of - (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> - pure (sspan, RtkBind name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) -> - pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args - _ -> empty - patsyn_binds term = case cast term of - (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) - _ -> empty - pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> - pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> - [(sspan, RtkVar name)] ++ everythingInRenamedSource 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.GhcRn) _)) -> - pure (sspan, RtkVar name) - _ -> empty - tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> - 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 -> LTokenDetails -decls (group, _, _, _) = concatMap ($ group) - [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds - , everythingInRenamedSource fun . GHC.hs_valds - , everythingInRenamedSource fix . GHC.hs_fixds - , everythingInRenamedSource (con `Syb.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 - ++ concatMap tyfam tcdATs - GHC.XTyClDecl {} -> GHC.panic "haddock:decls" - fun term = case cast term of - (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) - | GHC.isExternalName name -> pure (sspan, RtkDecl name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _))) - | GHC.isExternalName name -> pure (sspan, RtkDecl name) - _ -> empty - con term = case cast term of - (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> - map decl (GHC.getConNames cdcl) - ++ everythingInRenamedSource fld cdcl - Nothing -> empty - ins term = case cast term of - (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) - :: GHC.InstDecl GHC.GhcRn)) - -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> - pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - _ -> empty - fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.GhcRn) - -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field - Nothing -> empty - fix term = case cast term of - Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn) - -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names - Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) - -> GHC.panic "haddock:decls" - Nothing -> empty - tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] - tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" - sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names - sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names - sig (GHC.L _ (GHC.ClassOpSig _ _ 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 -> LTokenDetails -imports src@(_, imps, _, _) = - everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps - where - ie term = case cast term of - (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith _ t _ vs _fls)) -> - [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs - (Just (GHC.IEModuleContents _ m)) -> pure $ modu m - _ -> empty - typ (GHC.L sspan name) = (sspan, RtkType name) - var (GHC.L sspan name) = (sspan, RtkVar name) - modu (GHC.L sspan name) = (sspan, RtkModule name) - imp idecl - | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl)) - | otherwise = Nothing 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,213 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Haddock.Backends.Hyperlinker.Parser (parse) where -import Data.Either ( isRight, isLeft ) -import Data.List ( foldl', isPrefixOf, isSuffixOf ) -import Data.Maybe ( maybeToList ) -import Data.Char ( isSpace ) -import qualified Text.Read as R +import Control.Applicative ( Alternative(..) ) +import Data.List ( isPrefixOf, isSuffixOf ) -import GHC ( DynFlags, addSourceToTokens ) -import SrcLoc +import qualified Data.ByteString as BS + +import BasicTypes ( IntegralLit(..) ) +import DynFlags +import ErrUtils ( emptyMessages ) import FastString ( mkFastString ) -import StringBuffer ( stringToStringBuffer ) -import Lexer ( Token(..) ) -import qualified Lexer as L +import Lexer ( P(..), ParseResult(..), PState(..), Token(..) + , mkPStatePure, lexer, mkParserFlags' ) +import Outputable ( showSDoc, panic ) +import SrcLoc +import 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: --- --- prop> concat . map tkValue . parse = id --- --- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v', --- characters, since GHC transforms those into ' ' and '\n') -parse :: DynFlags -> FilePath -> String -> [T.Token] -parse dflags fp = ghcToks . processCPP dflags fp . filterCRLF +-- 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 _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++ + ": " ++ showSDoc dflags errMsg where - -- Remove CRLFs from source - filterCRLF :: String -> String - filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs - filterCRLF (c:cs) = c : filterCRLF cs - filterCRLF [] = [] --- | Parse the source into tokens using the GHC lexer. --- --- * CPP lines are removed and reinserted as line-comments --- * top-level file pragmas are parsed as block comments (see the --- 'ITblockComment' case of 'classify' for more details) --- -processCPP :: DynFlags -- ^ GHC's flags - -> FilePath -- ^ source file name (for position information) - -> String -- ^ source file contents - -> [(Located L.Token, String)] -processCPP dflags fpath s = addSrc . go start . splitCPP $ s - where + initState = mkPStatePure pflags buf start + buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - addSrc = addSourceToTokens start (stringToStringBuffer s) - - -- Transform a list of Haskell/CPP lines into a list of tokens - go :: RealSrcLoc -> [Either String String] -> [Located L.Token] - go _ [] = [] - go pos ls = - let (hLinesRight, ls') = span isRight ls - (cppLinesLeft, rest) = span isLeft ls' - - hSrc = concat [ hLine | Right hLine <- hLinesRight ] - cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ] + pflags = mkParserFlags' (warningFlags dflags) + (extensionFlags dflags) + (thisPackage dflags) + (safeImportsOn dflags) + False -- lex Haddocks as comment tokens + True -- produce comment tokens + False -- produce position pragmas tokens - in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of + 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 + (newToks, inPrag') <- parseCppLine <|> parsePlainTok inPrag <|> unknownLine + go inPrag' (newToks ++ toks) + else + pure toks - -- Stuff that fails to lex gets turned into comments - L.PFailed _ _ss _msg -> - let (src_pos, failed) = mkToken ITunknown pos hSrc - (new_pos, cpp) = mkToken ITlineComment src_pos cppSrc - in failed : cpp : go new_pos rest + -- | 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 - -- Successfully lexed - L.POk ss toks -> - let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc - in toks ++ [cpp] ++ go new_pos rest + -- | Try to parse a CPP line (can fail) + parseCppLine :: P ([T.Token], Bool) + parseCppLine = 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 ([cppTok], False) + _ -> empty - -- Manually make a token from a 'String', advancing the cursor position - mkToken tok start' str = - let end = foldl' advanceSrcLoc start' str - in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str)) + -- | Try to parse a regular old token (can fail) + parsePlainTok :: Bool -> P ([T.Token], Bool) -- return list is only ever 0-2 elements + parsePlainTok inPrag = do + (bInit, lInit) <- getInput + L sp tok <- Lexer.lexer False return + (bEnd, _) <- 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 + (bEnd', inPrag') <- case tok of --- | Split apart the initial file into Haskell source lines ('Left' entries) and --- CPP lines ('Right' entries). --- --- All characters in the input are present in the output: --- --- prop> concat . map (either id id) . splitCPP = id -splitCPP :: String -> [Either String String] -splitCPP "" = [] -splitCPP s | isCPPline s = Left l : splitCPP rest - | otherwise = Right l : splitCPP rest - where - ~(l, rest) = spanToNewline 0 s + -- Update internal line + file position if this is a LINE pragma + ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL { il_value = line })) <- wrappedLexer + L _ (ITstring _ file) <- wrappedLexer + L spF ITclose_prag <- wrappedLexer + let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) + (bEnd'', _) <- getInput + setInput (bEnd'', newLoc) --- | Heuristic to decide if a line is going to be a CPP line. This should be a --- cheap operation since it is going to be run on every line being processed. --- --- Right now it just checks if the first non-whitespace character in the first --- five characters of the line is a '#': --- --- >>> isCPPline "#define FOO 1" --- True --- --- >>> isCPPline "\t\t #ifdef GHC" --- True --- --- >>> isCPPline " #endif" --- False --- -isCPPline :: String -> Bool -isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5 + pure (bEnd'', False) + -- Update internal column position if this is a COLUMN pragma + ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL { il_value = col })) <- wrappedLexer + L spF ITclose_prag <- wrappedLexer --- | Split a "line" off the front of a string, hopefully without cutting tokens --- in half. I say "hopefully" because knowing what a token is requires lexing, --- yet lexing depends on this function. --- --- All characters in the input are present in the output: --- --- prop> curry (++) . spanToNewLine 0 = id -spanToNewline :: Int -- ^ open '{-' - -> String -- ^ input - -> (String, String) + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- getInput + setInput (bEnd'', newLoc) --- Base case and space characters -spanToNewline _ "" = ("", "") -spanToNewline n ('\n':str) | n <= 0 = ("\n", str) -spanToNewline n ('\n':str) | n <= 0 = ("\n", str) -spanToNewline n ('\\':'\n':str) = - let (str', rest) = spanToNewline n str - in ('\\':'\n':str', rest) + pure (bEnd'', False) --- Block comments -spanToNewline n ('{':'-':str) = - let (str', rest) = spanToNewline (n+1) str - in ('{':'-':str', rest) -spanToNewline n ('-':'}':str) = - let (str', rest) = spanToNewline (n-1) str - in ('-':'}':str', rest) + _ -> pure (bEnd, inPragDef) --- When not in a block comment, try to lex a Haskell token -spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) = - if all (== '-') lexed && length lexed >= 2 - -- A Haskell line comment - then case span (/= '\n') str' of - (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest) - (_, _) -> (str, "") + 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 } - -- An actual Haskell token - else let (str'', rest) = spanToNewline 0 str' - in (lexed ++ str'', rest) + pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag') --- In all other cases, advance one character at a time -spanToNewline n (c:str) = - let (str', rest) = spanToNewline n str - in (c:str', rest) + -- | 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) --- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of --- Haddock's 'T.Token'. -ghcToks :: [(Located L.Token, String)] -> [T.Token] -ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) - where - start = mkRealSrcLoc (mkFastString "lexing") 1 1 - - go :: (RealSrcLoc, [T.Token], Bool) - -- ^ current position, tokens accumulated, currently in pragma (or not) - - -> (Located L.Token, String) - -- ^ next token, its content - - -> (RealSrcLoc, [T.Token], Bool) - -- ^ new position, new tokens accumulated, currently in pragma (or not) +-- | Get the input +getInput :: P (StringBuffer, RealSrcLoc) +getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) - go (pos, toks, in_prag) (L l tok, raw) = - ( next_pos - , classifiedTok ++ maybeToList white ++ toks - , inPragma in_prag tok - ) - where - (next_pos, white) = mkWhitespace pos l - - classifiedTok = [ Token (classify' tok) raw rss - | RealSrcSpan rss <- [l] - , not (null raw) - ] - - classify' | in_prag = const TkPragma - | otherwise = classify +-- | Set the input +setInput :: (StringBuffer, RealSrcLoc) -> P () +setInput (buf, srcLoc) = P $ \p -> POk (p { buffer = buf, loc = srcLoc }) () --- | Find the correct amount of whitespace between tokens. -mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token) -mkWhitespace prev spn = - case spn of - UnhelpfulSpan _ -> (prev,Nothing) - RealSrcSpan s | null wsstring -> (end, Nothing) - | otherwise -> (end, Just (Token TkSpace wsstring wsspan)) - where - start = realSrcSpanStart s - end = realSrcSpanEnd s - wsspan = mkRealSrcSpan prev start - nls = srcLocLine start - srcLocLine prev - spaces = if nls == 0 then srcLocCol start - srcLocCol prev - else srcLocCol start - 1 - wsstring = replicate nls '\n' ++ replicate spaces ' ' +-- | Orphan instance that adds backtracking to 'P' +instance Alternative P where + empty = P $ \_ -> PFailed (const emptyMessages) noSrcSpan "Alterative.empty" + P x <|> P y = P $ \s -> case x s of { p@POk{} -> p + ; _ -> y s } +-- | Try a parser. If it fails, backtrack and return the pure value. +tryOrElse :: a -> P a -> P a +tryOrElse x p = p <|> pure x -- | Classify given tokens as appropriate Haskell token type. -classify :: L.Token -> TokenType +classify :: Lexer.Token -> TokenType classify tok = case tok of ITas -> TkKeyword @@ -378,15 +334,11 @@ ITLarrowtail {} -> TkGlyph ITRarrowtail {} -> TkGlyph + ITcomment_line_prag -> TkUnknown ITunknown {} -> TkUnknown ITeof -> TkUnknown - -- Line comments are only supposed to start with '--'. Starting with '#' - -- means that this was probably a CPP. - ITlineComment s - | isCPPline s -> TkCpp - | otherwise -> TkComment - + ITlineComment {} -> TkComment ITdocCommentNext {} -> TkComment ITdocCommentPrev {} -> TkComment ITdocCommentNamed {} -> TkComment @@ -403,9 +355,9 @@ | otherwise -> TkComment -- | Classify given tokens as beginning pragmas (or not). -inPragma :: Bool -- ^ currently in pragma - -> L.Token -- ^ current token - -> Bool -- ^ new information about whether we are in a pragma +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 = 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,4 +1,8 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -6,15 +10,19 @@ 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 HieTypes +import Module ( ModuleName, moduleNameString ) +import Name ( getOccString, isInternalName, Name, nameModule, nameUnique ) +import SrcLoc +import Unique ( getKey ) +import Encoding ( utf8DecodeByteString ) + import System.FilePath.Posix (()) -import Data.List -import Data.Maybe import qualified Data.Map as Map +import qualified Data.Set as Set import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html @@ -22,22 +30,24 @@ type StyleClass = String - -render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken] - -> Html -render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens +-- | 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 (richToken srcs) $ 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 ! @@ -51,26 +61,133 @@ , Html.src scriptFile ] + +splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token]) +splitTokens ast toks = (before,during,after) + where + (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 + 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') + + -- | Given information about the source position of definitions, render a token -richToken :: SrcMap -> RichToken -> Html -richToken srcs (RichToken Token{..} details) - | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue - | otherwise = linked content +richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html +richToken srcs details Token{..} + | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' + | otherwise = annotate details $ linked content where + tkValue' = filterCRLF $ utf8DecodeByteString tkValue content = tokenSpan ! [ multiclass style ] - tokenSpan = Html.thespan (Html.toHtml tkValue) - style = tokenStyle tkType ++ maybe [] richTokenStyle details + tokenSpan = Html.thespan (Html.toHtml tkValue') + style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts + contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details + + -- pick an arbitary identifier to hyperlink with + identDet = Map.lookupMin . nodeIdentifiers $ details + -- If we have name information, we can make links - linked = case details of - Just d -> externalAnchor d . internalAnchor d . hyperlink srcs d + 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, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ] + 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 + tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] tokenStyle TkKeyword = ["hs-keyword"] @@ -87,61 +204,70 @@ 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 + internalHyperlink name content = + Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html -externalModHyperlink srcs name content = - let srcs' = Map.mapKeys GHC.moduleName srcs in - 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 + externalNameHyperlink 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 $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." path) ] + 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) -> Html.anchor content ! + [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." path) ] + 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 ] @@ -151,4 +277,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,17 +1,24 @@ +{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Types where - import qualified GHC +import Data.ByteString ( ByteString ) + import Data.Map (Map) data Token = Token { tkType :: TokenType - , tkValue :: String + , tkValue :: ByteString -- ^ UTF-8 encoded , tkSpan :: {-# UNPACK #-} !Span } 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 + type Position = GHC.RealSrcLoc type Span = GHC.RealSrcSpan @@ -31,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 @@ -63,5 +47,5 @@ | SrcLocal -- | Mapping from modules to cross-package source paths. -type SrcMap = Map GHC.Module SrcPath +type SrcMaps = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) 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 HieTypes ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) +import IfaceType +import Name ( getOccFS, getOccString ) +import Outputable ( showSDoc ) +import Var ( VarBndr(..) ) +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 procesddsing + +-- This belongs in GHC's HieUtils... + +-- | 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 +-- mutliple 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 a b) = IfaceFunTy a b + go (HQualTy con b) = IfaceDFunTy con b + 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,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX @@ -22,6 +24,7 @@ import Pretty hiding (Doc, quote) import qualified Pretty +import BasicTypes ( PromotionFlag(..) ) import GHC import OccName import Name ( nameOccName ) @@ -100,6 +103,10 @@ 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 90 1 txtPrinter "" ppLaTeXTop :: String @@ -135,7 +142,7 @@ filename = odir (fromMaybe "haddock" packageStr <.> "tex") - writeFile filename (show tex) + writeUtf8File filename (show tex) ppLaTeXModule :: String -> FilePath -> Interface -> IO () @@ -153,7 +160,7 @@ text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ + text " " <> fsep (punctuate (char ',') $ map exportListItem $ filter forSummary exports), text " ) where" @@ -168,7 +175,7 @@ body = processExports exports -- - writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) + writeUtf8File (odir moduleLaTeXFile mdl) (show tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -243,8 +250,8 @@ -- | 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 + -> ( LaTeX -- to print before each name in an export list + , [DocName] -- names being declared ) declNames (L _ decl) = case decl of TyClD _ d -> (empty, [tcdName d]) @@ -284,7 +291,7 @@ -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode + 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 -- Family instances happen via FamInst now @@ -292,7 +299,7 @@ -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -304,7 +311,7 @@ ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig Nothing doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -314,13 +321,14 @@ ------------------------------------------------------------------------------- -- | Pretty-print a data\/type family declaration -ppFamDecl :: Documentation DocName -- ^ this decl's docs +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 doc instances decl unicode = - declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) +ppFamDecl associated doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -332,6 +340,7 @@ 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") @@ -342,7 +351,7 @@ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts } }) - = hsep [ ppAppNameTypes n (map unLoc ts) unicode + = hsep [ ppAppNameTypeArgs n ts unicode , equals , ppType unicode (unLoc rhs) ] @@ -353,22 +362,26 @@ -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print - -> Bool -- ^ unicode - -> LaTeX -ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX +ppFamHeader (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity }) - unicode = - leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + 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 @@ -411,17 +424,23 @@ ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( 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 @@ -430,23 +449,15 @@ -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigType ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. ppTypeOrFunSig :: HsType DocNameI -> DocForDecl DocName -- ^ documentation - -> ( LaTeX -- ^ first-line (no-argument docs only) - , LaTeX -- ^ first-line (argument docs only) - , LaTeX -- ^ type prefix (argument docs only) + -> ( LaTeX -- first-line (no-argument docs only) + , LaTeX -- first-line (argument docs only) + , LaTeX -- type prefix (argument docs only) ) -> Bool -- ^ unicode -> LaTeX @@ -458,7 +469,7 @@ text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) --- This splits up a type signature along `->` and adds docs (when they exist) +-- | 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 @@ -476,12 +487,13 @@ do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] do_args _n leader (HsForAllTy _ tvs ltype) = [ ( decltt leader - , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + , decltt (ppForAllPart unicode tvs) <+> ppLType unicode ltype ) ] do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) - : do_largs n (darrow unicode) ltype + = ( decltt leader + , decltt (ppLContextNoArrow lctxt unicode) <+> nl + ) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) @@ -500,9 +512,9 @@ -- 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) (text "\\ ")) <> text "," - gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" - gadtOpen = text "\\{" + 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] -> HsType DocNameI -> Bool -> LaTeX @@ -512,8 +524,9 @@ <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars = map (ppSymName . getName . hsLTyVarName) +-- | Pretty-print type variables. +ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] +ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -524,10 +537,9 @@ 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 (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" $$ + maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ text "\\end{haddockdesc}" @@ -538,9 +550,9 @@ multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" | decl <- decls ] $$ text "\\end{haddockdesc}" @@ -584,6 +596,7 @@ hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -604,18 +617,28 @@ body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" + | otherwise = Just (atTable $$ methodTable) + atTable = + text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ + vcat [ ppFamDecl True (fst doc) [] (FamDecl noExt decl) True + | L _ decl <- ats + , let name = unL . fdLName $ decl + doc = lookupAnySubdoc name subdocs + ] + + methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig 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? + vcat [ ppFunSig leader doc names (hsSigType 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 @@ -634,6 +657,7 @@ 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 @@ -716,17 +740,23 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> 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 " ") +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr DocNameI] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Bool -- ^ unicode + -> LaTeX +ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt where - ppForall = case forall of - True -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - False -> empty + ppForall + | null tvs || not forall_ = empty + | otherwise = ppForAllPart unicode tvs + ppCtxt + | null ctxt = empty + | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space + -- | Pretty-print a constructor ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs -> Bool -- ^ unicode @@ -753,11 +783,10 @@ -- First line of the constructor (no doc, no fields, single-line) decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) cxt) header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' @@ -905,6 +934,11 @@ 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 @@ -923,7 +957,6 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) - ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- @@ -953,7 +986,7 @@ pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context [] _ = empty -pp_hs_context [p] unicode = ppType unicode p +pp_hs_context [p] unicode = ppCtxType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) @@ -974,7 +1007,7 @@ sumParens :: [LaTeX] -> LaTeX -sumParens = ubxparens . hsep . punctuate (text " | ") +sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- @@ -988,16 +1021,22 @@ ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) - -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX +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 +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode +ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX 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 "" + ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" ppLKind :: Bool -> LHsKind DocNameI -> LaTeX @@ -1010,13 +1049,17 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppForAllPart :: Bool -> [LHsTyVarBndr DocNameI] -> LaTeX +ppForAllPart unicode tvs = hsep (forallSymbol unicode : ppTyVars unicode tvs) <> dot + + 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 _ tvs ty) unicode - = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + = sep [ ppForAllPart unicode tvs , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode = sep [ ppLContext ctxt unicode @@ -1027,27 +1070,30 @@ 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 _ Promoted (L _ name)) _ = char '\'' <> 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 (HsKindSig _ ty kind) u = 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 = brackets (ppIPName n <+> dcolon u <+> 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 {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +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 _ ty1 op ty2) unicode = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode where - ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op - occName = nameOccName . getName . unLoc $ 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) @@ -1056,7 +1102,7 @@ ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = text "\\_" +ppr_mono_ty (HsWildCardTy _) _ = char '_' ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1076,16 +1122,13 @@ ppBinder :: OccName -> LaTeX ppBinder n - | isInfixName n = parens $ ppOccName n - | otherwise = ppOccName n + | isSymOcc n = parens $ ppOccName n + | otherwise = ppOccName n ppBinderInfix :: OccName -> LaTeX ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = cat [ char '`', ppOccName n, char '`' ] - -isInfixName :: OccName -> Bool -isInfixName n = isVarSym n || isConSym n + | isSymOcc n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] ppSymName :: Name -> LaTeX ppSymName name @@ -1093,28 +1136,16 @@ | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString - ppIPName :: HsIPName -> LaTeX -ppIPName ip = text $ unpackFS $ hsIPNameFS ip +ppIPName = text . ('?':) . unpackFS . hsIPNameFS 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 @@ -1152,9 +1183,10 @@ latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s +latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s +latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- @@ -1162,34 +1194,40 @@ ------------------------------------------------------------------------------- -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), - markupTable = \(Table h b) p -> table h b p +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 = \m _ -> 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 @@ -1202,8 +1240,11 @@ 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) + 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 aribtrary choice. @@ -1218,35 +1259,28 @@ markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" - markupId ppId_ id v = + markupId v wrappedOcc = 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 - + 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 - +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 rdrLatexMarkup doc Plain +rdrDocToLaTeX doc = markup latexMarkup doc Plain empty -data StringContext = Plain | Verb | Mono +data StringContext + = Plain -- ^ all special characters have to be escape + | Mono -- ^ on top of special characters, escape space chraacters + | Verb -- ^ don't escape anything latexStripTrailingWhitespace :: Doc a -> Doc a @@ -1271,23 +1305,23 @@ itemizedList :: [LaTeX] -> LaTeX itemizedList items = - text "\\begin{itemize}" $$ + text "\\vbox{\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" + text "\\end{itemize}}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = - text "\\begin{enumerate}" $$ + text "\\vbox{\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" + 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}" + text "\\vbox{\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ + text "\\end{description}}" tt :: LaTeX -> LaTeX @@ -1295,8 +1329,8 @@ decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - +decltt ltx = text "\\haddockdecltt" <> braces (text filtered) + where filtered = latexMonoFilter (latex2String ltx) emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx @@ -1304,6 +1338,12 @@ bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx +-- TODO: @verbatim@ is too much since +-- +-- * Haddock supports markup _inside_ of codeblocks. 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 @@ -1315,12 +1355,13 @@ quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX +dcolon, arrow, darrow, forallSymbol, starSymbol, atSign :: 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") starSymbol unicode = text (if unicode then "★" else "*") +atSign unicode = text (if unicode then "@" else "@") dot :: LaTeX dot = char '.' @@ -1335,7 +1376,7 @@ ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" +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 @@ -33,12 +33,13 @@ 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 Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) +import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( () ) @@ -120,17 +121,26 @@ headHtml :: String -> Themes -> Maybe String -> Html headHtml docTitle themes mathjax_url = - header << [ - meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], - thetitle << docTitle, - styleSheet themes, - thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml, - script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml, - script ! [src mjUrl, thetype "text/javascript"] << noHtml + header << + [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] + , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] + , thetitle << docTitle + , styleSheet themes + , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml + , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml + , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml + , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf + , script ! [src mjUrl, thetype "text/javascript"] << noHtml ] where - mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/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: \".*\"" + , "}" + , "});" ] srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = @@ -177,13 +187,13 @@ pageContent = body << [ divPackageHeader << [ + nonEmptySectionName << doctitle, 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 + ! [theclass "links", identifier "page-menu"] ], divContent << pageContent, divFooter << paragraph << ( @@ -283,7 +293,7 @@ ppModuleTree pkg qual tree ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html @@ -321,6 +331,7 @@ cBtn = case (ts, leaf) of (_:_, 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 @@ -377,7 +388,7 @@ | Just item_html <- processExport True links_info unicode pkg qual item = [ Object [ "display_html" .= String (showHtmlFragment item_html) - , "name" .= String (intercalate " " (map nameString names)) + , "name" .= String (unwords (map getOccString names)) , "module" .= String (moduleString mdl) , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) ] @@ -386,18 +397,15 @@ where names = exportName item ++ exportSubs item - exportSubs :: ExportItem name -> [IdP name] + exportSubs :: ExportItem DocNameI -> [IdP DocNameI] exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs exportSubs _ = [] - exportName :: ExportItem name -> [IdP name] + exportName :: ExportItem DocNameI -> [IdP DocNameI] exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] - nameString :: NamedThing name => name -> String - nameString = occNameString . nameOccName . getName - nameLink :: NamedThing name => Module -> name -> String nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName @@ -425,9 +433,9 @@ 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 = @@ -468,7 +476,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] @@ -562,7 +570,7 @@ ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" @@ -629,9 +637,9 @@ | 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 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,6 +1,8 @@ {-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -32,7 +34,9 @@ import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) +import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula @@ -72,14 +76,14 @@ [Located DocName] -> LHsType 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 doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +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 = ppLType unicode qual HideEmptyContexts typ @@ -122,16 +126,16 @@ 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 + | 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 + +++ docSection curname pkg qual doc where - curName = getName <$> listToMaybe docnames + curname = getName <$> listToMaybe docnames --- This splits up a type signature along `->` and adds docs (when they exist) to --- the arguments. +-- | 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. @@ -149,9 +153,7 @@ do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n leader' ltype - where - leader' = leader <+> ppForAll tvs unicode qual + = do_largs n (leader <+> ppForAllPart unicode qual tvs) ltype do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) @@ -185,15 +187,6 @@ gadtOpen = toHtml "{" - -ppForAll :: [LHsTyVarBndr DocNameI] -> 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 @@ -226,7 +219,7 @@ -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -258,10 +251,6 @@ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan -> [DocName] -> HsType DocNameI -> Html @@ -290,10 +279,11 @@ -> 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 Nothing pkg qual doc +++ instancesBit + | 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 @@ -311,7 +301,7 @@ ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_rhs = rhs , feqn_pats = ts } }) - = ( ppAppNameTypes n (map unLoc ts) unicode qual + = ( ppAppNameTypeArgs n ts unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing , [] @@ -414,6 +404,11 @@ 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 @@ -426,7 +421,6 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) - ------------------------------------------------------------------------------- -- * Contexts ------------------------------------------------------------------------------- @@ -503,7 +497,7 @@ -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -524,13 +518,16 @@ -> [(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 }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , 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 Nothing pkg qual d + | otherwise = classheader +++ docSection curname pkg qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where + curname = Just $ getName nm + sigs = map unLoc lsigs classheader @@ -540,28 +537,68 @@ -- 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 pkg qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = ppDefaultAssocTy name <$> lookupDAT name + ] - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. + -- Default associated types + ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl + splice unicode pkg qual + where + synDecl = SynDecl { tcdSExt = noExt + , tcdLName = noLoc n + , tcdTyVars = vs + , tcdFixity = GHC.Prefix + , tcdRhs = t } + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ, doc)) + | L _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }) <- atsDefs + , let doc = noDocForDecl -- TODO: get docs for associated type defaults + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] (hsSigType 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] (hsSigType 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] == @@ -570,7 +607,7 @@ -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -585,6 +622,7 @@ 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 @@ -690,7 +728,7 @@ [ "o:" | orphan ] ++ [ qual origin , ":" ++ getOccString origin - , ":" ++ (occNameString . getOccName . ihdClsName) ihd + , ":" ++ getOccString (ihdClsName ihd) , ":" ++ show no ] where @@ -759,10 +797,11 @@ splice unicode pkg qual | summary = ppShortDataDecl summary False dataDecl pats unicode qual - | otherwise = header_ +++ docSection Nothing pkg qual doc +++ constrBit +++ patternBit +++ instancesBit + | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where docname = tcdName dataDecl + curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of ConDeclH98 {} -> True @@ -810,24 +849,23 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) 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) args) + ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) , noHtml , noHtml ) -- Record constructor, e.g. 'Identity { runIdentity :: a }' RecCon (L _ fields) -> - ( header_ +++ ppOcc <+> char '{' + ( header_ <+> ppOcc <+> char '{' , shortSubDecls dataInst [ ppShortField summary unicode qual field | L _ field <- fields ] @@ -836,7 +874,7 @@ -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 -> - ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 ] @@ -884,28 +922,27 @@ decl = case con of ConDeclH98{ con_args = det - , con_ex_tvs = vars + , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt - } -> let tyVars = map (getName . hsLTyVarName) vars - context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False + } -> let context = unLoc (fromMaybe (noLoc []) 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 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppOcc , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) , fixity ] -- Record constructor, e.g. 'Identity { runIdentity :: a }' - RecCon _ -> header_ +++ ppOcc <+> fixity + RecCon _ -> header_ <+> ppOcc <+> fixity -- Infix constructor, e.g. 'a :| [a]' InfixCon arg1 arg2 - | hasArgDocs -> header_ +++ ppOcc <+> fixity - | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + | hasArgDocs -> header_ <+> ppOcc <+> fixity + | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts arg1 , ppOccInfix , ppLParendType unicode qual HideEmptyContexts arg2 , fixity @@ -958,17 +995,17 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -- ^ print explicit foralls - -> [Name] -- ^ type variables - -> HsContext DocNameI -- ^ context - -> Unicode -> Qualification -> Html +ppConstrHdr + :: Bool -- ^ print explicit foralls + -> [LHsTyVarBndr 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 = forallSymbol unicode - <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " + | otherwise = ppForAllPart unicode qual tvs ppCtxt | null ctxt = noHtml @@ -1096,6 +1133,11 @@ 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 +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 "" ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppDocName qual Raw False name @@ -1156,8 +1198,9 @@ ppr_mono_ty (HsBangTy _ b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ = - ppDocName q Prefix True name +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 _ ty1 ty2) u q e = @@ -1169,7 +1212,7 @@ ppr_mono_ty (HsSumTy _ tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) ppr_mono_ty (HsKindSig _ ty kind) u q e = - parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind) + 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 @@ -1179,7 +1222,7 @@ -- placeholder in the signature, which is followed by the field -- declarations. ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +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 @@ -1187,6 +1230,10 @@ = 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 _ ty1 op ty2) unicode qual _ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where @@ -1204,10 +1251,9 @@ ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts = ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty (HsWildCardTy _) _ _ _ = 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) - 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 @@ -62,15 +62,15 @@ 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, @@ -171,12 +171,12 @@ -- 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 -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +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' 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]) @@ -206,7 +206,7 @@ -- | 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 @@ -220,7 +220,7 @@ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + 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. @@ -228,16 +228,16 @@ -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -273,7 +273,7 @@ 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 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, divModuleList, divContentsList, sectionName, nonEmptySectionName, @@ -35,6 +35,7 @@ subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -74,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, divModuleList, divContentsList :: Html -> Html divPackageHeader = sectionDiv "package-header" @@ -88,6 +89,7 @@ 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" @@ -195,17 +197,18 @@ subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual --- | Generate sub table for instance declarations, with source +-- | Generate collapsible sub table for instance declarations, with source subInstances :: Maybe Package -> Qualification -> String -- ^ Class name, used for anchor generation -> LinksInfo -> Bool -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable where - wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) + wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) instTable = subTableSrc pkg qual lnks splice subSection = thediv ! [theclass "subs instances"] - summary = thesummary << "Instances" + hdr = h4 ! collapseControl id_ "instances" << "Instances" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instances details" id_ = makeAnchorId $ "i:" ++ nm @@ -256,6 +259,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 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 @@ -24,7 +25,7 @@ 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 hiding (LexicalFixity(..)) import Name @@ -49,9 +50,11 @@ 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 @@ -68,6 +71,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 +95,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 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 @@ -58,7 +58,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. 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 @@ -22,6 +22,7 @@ braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList, arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote, + atSign, hsep, vcat, @@ -183,15 +184,15 @@ ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" -dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow unicode = toHtml (if unicode then "→" else "->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" - +atSign unicode = toHtml (if unicode then "@" else "@") dot :: Html dot = toHtml "." diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -12,12 +12,16 @@ -- 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. +module Haddock.Convert ( + tyThingToLHsDecl, + synifyInstHead, + synifyFamInst, + PrintRuntimeReps(..), +) where import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) ) +import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) + , PromotionFlag(..), DefMethSpec(..) ) import Class import CoAxiom import ConLike @@ -36,9 +40,10 @@ import Type import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey - , tYPETyConKey, liftedRepDataConKey ) +import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName + , unitTy, promotedNilDataCon, promotedConsDataCon ) +import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey + , liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut , splitAtList ) @@ -47,12 +52,22 @@ import Haddock.Types import Haddock.Interface.Specialize +import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) +import Data.Maybe ( catMaybes, maybeToList ) +-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check +-- out Note [Defaulting RuntimeRep variables] in IfaceType.hs for the +-- motivation. +data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show + -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) -tyThingToLHsDecl t = case t of +tyThingToLHsDecl + :: PrintRuntimeReps + -> TyThing + -> Either ErrMsg ([ErrMsg], (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 @@ -61,40 +76,60 @@ -- 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 noExt (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (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 ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl _ d) = return $ noLoc d + -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a) + extractFamilyDecl (FamDecl _ d) = return 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 noExt $ ClassDecl + extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn + extractFamDefDecl fd rhs = FamEqn + { feqn_ext = noExt + , feqn_tycon = fdLName fd + , feqn_bndrs = Nothing + -- TODO: this must change eventually + , feqn_pats = fdTyVars fd + , feqn_fixity = fdFixity fd + , feqn_rhs = synifyType WithinType [] rhs } + + extractAtItem + :: ClassATItem + -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn)) + extractAtItem (ATI at_tc def) = do + tyDecl <- synifyTyCon prr Nothing at_tc + famDecl <- extractFamilyDecl tyDecl + let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def + pure (noLoc famDecl, defEqnTy) + + atTyClDecls = map extractAtItem (classATItems cl) + (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) + vs = tyConVisibleTyVars (classTyCon cl) + + in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) - , tcdFixity = Prefix + , tcdTyVars = synifyTyVars vs + , tcdFixity = synifyFixity cl , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : - map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) - (classMethods cl) + [ noLoc 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 = rights atFamDecls - , tcdATDefs = [] --ignore associated type defaults + , tcdATs = atFamDecls + , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD noExt + -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -102,7 +137,7 @@ -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] - (synifySigWcType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) @@ -114,16 +149,17 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args - typats = map (synifyType WithinType) args_types_only + typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats - hs_rhs = synifyType WithinType rhs - in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs - , hsib_closed = True } + hs_rhs = synifyType WithinType [] rhs + in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name - , feqn_pats = annot_typats - , feqn_fixity = Prefix + , feqn_bndrs = Nothing + -- TODO: this must change eventually + , feqn_pats = map HsValArg annot_typats + , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where fam_tvs = tyConVisibleTyVars tc @@ -138,42 +174,51 @@ | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD noExt + = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" --- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) -synifyTyCon _coax tc +-- | 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 ErrMsg (TyClDecl GhcRn) +synifyTyCon prr _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 noExt (noLoc (getName fakeTyVar)) - (synifyKindSig realKind) - in HsQTvs { hsq_ext = + , tcdTyVars = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] -- No kind polymorphism , hsq_dependent = emptyNameSet } - , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) - alphaTyVars --a, b, c... which are unfortunately all kind * + , hsq_explicit = zipWith mk_hs_tv + tyVarKinds + alphaTyVars --a, b, c... which are unfortunately all kind * } - , tcdFixity = Prefix + , tcdFixity = synifyFixity tc , tcdDataDefn = HsDataDefn { dd_ext = noExt , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } , tcdDExt = DataDeclRn False placeHolderNamesTc } + where + -- tyConTyVars doesn't work on fun/prim, but we can make them up: + mk_hs_tv realKind fakeTyVar + | isLiftedTypeKind realKind = noLoc $ UserTyVar noExt (noLoc (getName fakeTyVar)) + | otherwise = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) -synifyTyCon _coax tc + conKind = defaultType prr (tyConKind tc) + tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind + +synifyTyCon _prr _coax tc | Just flav <- famTyConFlav_maybe tc = case flav of -- Type families @@ -197,7 +242,7 @@ , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) - , fdFixity = Prefix + , fdFixity = synifyFixity tc , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = @@ -205,13 +250,13 @@ (tyConInjectivityInfo tc) } -synifyTyCon coax tc +synifyTyCon _prr coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdSExt = emptyNameSet , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) - , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty } + , tcdFixity = synifyFixity tc + , tcdRhs = synifyType WithinType [] ty } | otherwise = -- (closed) newtype and data let @@ -239,7 +284,7 @@ -- 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) + use_gadt_syntax = isGadtSyntaxTyCon tc consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. @@ -253,31 +298,31 @@ , dd_derivs = alg_deriv } in case lefts consRaw of [] -> return $ - DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix + DataDecl { tcdLName = name, tcdTyVars = tyvars + , tcdFixity = synifyFixity name , tcdDataDefn = defn , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs --- In this module, every TyCon being considered has come from an interface +-- | 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 :: *) +-- > 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 :: *) --- :: * -> (* -> *) -> * -> * +-- > data Foo (w :: *) (m :: * -> *) (a :: *) +-- > :: * -> (* -> *) -> * -> * -- --- Which is entirely wrong (#548). We only want to display the *return* kind, +-- Which is entirely wrong (#548). We only want to display the /return/ kind, -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of - (_, ret_kind) - | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * - | otherwise -> Just (synifyKindSig ret_kind) + | 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) @@ -288,8 +333,9 @@ in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn -synifyFamilyResultSig Nothing kind = - noLoc $ KindSig noExt (synifyKindSig kind) +synifyFamilyResultSig Nothing kind + | isLiftedTypeKind kind = noLoc $ NoSig noExt + | otherwise = noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) @@ -307,14 +353,16 @@ 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 + (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + user_tvs = dataConUserTyVars dc -- Used for GADT data constructors -- skip any EqTheta, use 'orig'inal syntax - ctx = synifyCtx theta + ctx | null theta = Nothing + | otherwise = Just $ synifyCtx theta linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty + let tySyn = synifyType WithinType [] ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExt bang' tySyn) @@ -338,33 +386,55 @@ then return $ noLoc $ ConDeclGADT { con_g_ext = noExt , con_names = [name] - , con_forall = noLoc True - , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) - , con_mb_cxt = Just ctx - , con_args = hat - , con_res_ty = synifyType WithinType res_ty - , con_doc = Nothing } + , con_forall = noLoc $ not $ null user_tvs + , con_qvars = synifyTyVars user_tvs + , con_mb_cxt = ctx + , con_args = hat + , con_res_ty = synifyType WithinType [] res_ty + , con_doc = Nothing } else return $ noLoc $ ConDeclH98 { con_ext = noExt , con_name = name - , con_forall = noLoc True + , con_forall = noLoc False , con_ex_tvs = map synifyTyVar ex_tvs - , con_mb_cxt = Just ctx + , con_mb_cxt = ctx , con_args = hat , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (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 :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) +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 noExt [synifyName i] (synifySigWcType s vs t) + where + t = defaultType prr (varType i) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (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 noExt False [synifyName i] (mainSig (varType i)) ] ++ + [ ClassOpSig noExt True [noLoc 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 = noLoc . map (synifyType WithinType) +synifyCtx = noLoc . map (synifyType WithinType []) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -373,13 +443,20 @@ , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn -synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name)) - | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) +synifyTyVar = synifyTyVar' emptyVarSet + +-- | Like 'synifyTyVar', but accepts a set of variables for which to omit kind +-- signatures (even if they don't have the lifted type kind). +synifyTyVar' :: VarSet -> TyVar -> LHsTyVarBndr GhcRn +synifyTyVar' no_kinds tv + | isLiftedTypeKind kind || tv `elemVarSet` no_kinds + = noLoc (UserTyVar noExt (noLoc name)) + | otherwise = noLoc (KindedTyVar noExt (noLoc 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 @@ -391,7 +468,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty - hs_ki = synifyType WithinType ki + hs_ki = synifyType WithinType [] ki in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty @@ -414,7 +491,8 @@ -- 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. + -- 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@) @@ -423,22 +501,33 @@ -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn +synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? -synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) +synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn +synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) -synifyType _ (TyConApp tc tys) +-- | 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) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) +synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where res_ty :: LHsType GhcRn @@ -456,39 +545,55 @@ BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) vis_tys) + (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys) -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy noExt (synifyType WithinType ty) + | getName tc == listTyConName, [ty] <- vis_tys = + noLoc $ HsListTy noExt (synifyType WithinType vs ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLoc $ HsExplicitListTy noExt 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 + -> noLoc $ HsExplicitListTy noExt IsPromoted (hTy : tTy') + | otherwise + -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc eqTyConName) - (synifyType WithinType ty2) + (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc $ getName tc) - (synifyType WithinType ty2)) + (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noExt prom $ noLoc (getName tc)) vis_tys where + prom = if isPromotedDataCon tc then IsPromoted else NotPromoted mk_app_tys ty_app ty_args = foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) (noLoc ty_app) - (map (synifyType WithinType) $ + (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) vis_tys = filterOutInvisibleTypes tc tys @@ -499,7 +604,7 @@ maybe_sig ty' | needs_kind_sig = let full_kind = typeKind (mkTyConApp tc tys) - full_kind' = synifyType WithinType full_kind + full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' @@ -517,76 +622,174 @@ in not (subVarSet result_vars dropped_vars) -synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 -synifyType _ (AppTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 +synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 +synifyType _ vs (AppTy t1 t2) = let + s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExt s1 s2 -synifyType _ (FunTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsFunTy noExt s1 s2 -synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty +synifyType s vs funty@(FunTy t1 t2) + | isPredTy t1 = synifyForAllType s vs funty + | otherwise = let s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 + in noLoc $ HsFunTy noExt s1 s2 +synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty + +synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t +synifyType s vs (CastTy t _) = synifyType s vs t +synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" + +-- | Process a 'Type' which starts with a forall or a constraint into +-- an 'HsType' +synifyForAllType + :: SynifyTypeState -- ^ what to do with the 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyForAllType s vs ty = + let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt - , hst_body = synifyType WithinType tau } + , hst_xqual = noExt + , hst_body = synifyType WithinType (tvs' ++ vs) tau } + + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + sTvs = map synifyTyVar 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 tau - WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc sPhi } - ImplicitizeForAll -> noLoc sPhi + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau -synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t -synifyType s (CastTy t _) = synifyType s t -synifyType _ (CoercionTy {}) = error "synifyType:Coercion" + -- Put a forall in if there are any type variables + WithinType + | not (null tvs) -> noLoc sTy + | otherwise -> noLoc 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 + -> [TyVar] -- ^ 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 = noLoc sTy + | tvs' /= tvs = noLoc sTy + | otherwise = noLoc sPhi + where + sRho = synInner (tvs' ++ vs) tau + sPhi | null ctx = unLoc sRho + | otherwise + = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExt + , hst_body = synInner (tvs' ++ vs) tau } + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + no_kinds_needed = noKindTyVars tycons tau + sTvs = map (synifyTyVar' 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) + , 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 t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (CastTy t _) = noKindTyVars ts t +noKindTyVars _ _ = emptyVarSet + synifyPatSynType :: PatSyn -> LHsType GhcRn -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_xforall = noExt - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_xqual = noExt - , 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 +synifyPatSynType ps = + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig 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)) + (mkFunTys arg_tys res_ty) + synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn -synifyKindSig k = synifyType WithinType k +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 (_, preds, cls, types) = specializeInstHead $ InstHead +synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType) preds + { clsiCtx = map (unLoc . synifyType WithinType []) preds , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls + (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) ts + ts' = map (synifyType WithinType vs) ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) - synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification + synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) @@ -600,9 +803,9 @@ where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs + return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs ityp (DataFamilyInst c) = - DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c + DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c fam_tc = famInstTyCon fi fam_flavor = fi_flavor fi fam_lhs = fi_tys fi @@ -622,7 +825,7 @@ = fam_lhs ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs - synifyTypes = map (synifyType WithinType) + synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) @@ -652,8 +855,8 @@ tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) tcSplitForAllTysPreserveSynonyms ty = split ty ty [] where - split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) 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,6 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -18,37 +19,44 @@ import Control.Arrow +import Data.Char ( isSpace ) + import Haddock.Types( DocNameI ) import Exception -import Outputable +import FV +import Outputable ( Outputable, panic, showPpr ) import Name import NameSet -import Lexeme import Module import HscTypes import GHC import Class import DynFlags +import SrcLoc ( advanceSrcLoc ) +import Var ( VarBndr(..), TyVarBinder, tyVarKind, updateTyVarKind, + isInvisibleArgFlag ) +import VarSet ( VarSet, emptyVarSet ) +import VarEnv ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) +import TyCoRep ( Type(..), isRuntimeRepVar ) +import TysWiredIn( liftedRepDataConTyCon ) -import HsTypes (HsType(..)) +import StringBuffer ( StringBuffer ) +import qualified StringBuffer as S +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS + 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 -> [IdP name] +getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + HsDecl p -> [IdP p] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -141,12 +149,6 @@ isValD (ValD _ _) = True isValD _ = False - -declATs :: HsDecl a -> [IdP a] -declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d -declATs _ = [] - - pretty :: Outputable a => DynFlags -> a -> String pretty = showPpr @@ -237,6 +239,8 @@ 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) @@ -263,22 +267,27 @@ 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 _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind) go _ (HsListTy x ty) = HsListTy x (reparenLType ty) go _ (HsRecTy x flds) = HsRecTy x (map (fmap 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_CTX $ HsIParamTy x n (reparenLType ty) + = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) go p (HsForAllTy x tvs ty) = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) go p (HsQualTy x ctxt ty) - = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + = let p' [_] = PREC_CTX + p' _ = PREC_TOP -- parens will get added anyways later... + in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty) go p (HsFunTy x ty1 ty2) = paren p PREC_FUN $ HsFunTy x (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 ty1 op ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed @@ -426,13 +435,230 @@ ------------------------------------------------------------------------------- -setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags +setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags setObjectDir f d = d{ objectDir = Just f} setHiDir f d = d{ hiDir = Just f} +setHieDir f d = d{ hieDir = Just f} setStubDir f d = d{ stubDir = Just f , includePaths = addGlobalInclude (includePaths d) [f] } -- -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 +setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f + +------------------------------------------------------------------------------- +-- * '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 } + +-- | 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' + +------------------------------------------------------------------------------- +-- * 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 Name +-- >>> import TyCoRep +-- >>> import TysPrim +-- >>> import 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 arg res) a b c = (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 IfaceType.hs 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 + , isInvisibleArgFlag 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 + = TyConApp liftedRepDataConTyCon [] + | otherwise + = TyVarTy (updateTyVarKind (go subs) tv) + + go subs (TyConApp tc tc_args) + = TyConApp tc (map (go subs) tc_args) + + go subs (FunTy arg res) + = FunTy (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 diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -43,27 +43,24 @@ import Haddock.Utils import Control.Monad +import Control.Exception (evaluate) import Data.List import qualified Data.Map as Map import qualified Data.Set as Set -import Distribution.Verbosity -import System.Directory -import System.FilePath import Text.Printf import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) import Digraph import DynFlags hiding (verbosity) -import Exception import GHC hiding (verbosity) import HscTypes import FastString (unpackFS) -import MonadUtils (liftIO) import TcRnTypes (tcg_rdr_env) import Name (nameIsFromExternalPackage, nameOccName) import OccName (isTcOcc) import RdrName (unQualOK, gre_name, globalRdrEnvElts) import ErrUtils (withTiming) +import DynamicLoading (initializePlugins) #if defined(mingw32_HOST_OS) import System.IO @@ -91,7 +88,7 @@ out verbosity verbose "Creating interfaces..." let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap + (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap let exportedNames = Set.unions $ map (Set.fromList . ifaceExports) $ @@ -124,39 +121,15 @@ -------------------------------------------------------------------------------- -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) -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 - createIfaces verbosity flags instIfaceMap modGraph - - where - useTempDir :: Bool - useTempDir = Flag_NoTmpCompDir `notElem` flags - - - 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 - - - depAnalysis :: Ghc ModuleGraph - depAnalysis = do - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - depanal [] False - +createIfaces :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) +createIfaces verbosity modules flags instIfaceMap = do + -- Ask GHC to tell us what the module graph is + targets <- mapM (\filePath -> guessTarget filePath Nothing) modules + setTargets targets + modGraph <- depanal [] False -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet) -createIfaces verbosity flags instIfaceMap mods = do - let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing + -- Visit modules in that order + let sortedMods = flattenSCCs $ topSortModuleGraph False modGraph Nothing out verbosity normal "Haddock coverage:" (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods return (reverse ifaces, ms) @@ -177,8 +150,14 @@ processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum + -- Since GHC 8.6, plugins are initialized on a per module basis + hsc_env' <- getSession + dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum)) + let modsum' = modsum { ms_hspp_opts = dynflags' } + + tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' + if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-} @@ -264,12 +243,3 @@ 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,4 @@ -{-# LANGUAGE CPP, MagicHash, BangPatterns #-} +{-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -19,6 +19,7 @@ import Haddock.Convert import Haddock.GhcUtils +import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) @@ -31,7 +32,6 @@ import CoreSyn (isOrphan) import ErrUtils import FamInstEnv -import FastString import GHC import InstEnv import Module ( ModuleSet, moduleSetElts ) @@ -39,13 +39,11 @@ import Name import NameEnv import Outputable (text, sep, (<+>)) -import PrelNames import SrcLoc import TyCon import TyCoRep -import TysPrim( funTyCon ) +import TysPrim( funTyConName ) import Var hiding (varName) -#define FSLIT(x) (mkFastString# (x#)) type ExportedNames = Set.Set Name type Modules = Set.Set Module @@ -63,16 +61,24 @@ ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] attach index iface = do - newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap) + + 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 GhcRn] -attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = - [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing) +attachOrphanInstances + :: ExportInfo + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> [ClsInst] -- ^ a list of orphan instances + -> [DocInstance GhcRn] +attachOrphanInstances expInfo getInstDoc cls_instances = + [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing) | 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 @@ -80,40 +86,40 @@ attachToExportItem - :: NameEnv ([ClsInst], [FamInst]) + :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of) -> ExportInfo - -> Interface - -> IfaceMap - -> InstIfaceMap + -> (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 iface ifaceMap instIfaceMap export = +attachToExportItem index expInfo getInstDoc getFixity export = case attachFixities export of e@ExportDecl { expItemDecl = 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 = [ ( synifyFamInst i opaque - , doc - , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) + fam_insts = [ ( synFamInst + , getInstDoc n + , spanNameE n synFamInst (L eSpan (tcdName d)) , nameModule_maybe n ) | 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) + , let synFamInst = synifyFamInst i opaque ] - cls_insts = [ ( synifyInstHead i - , instLookup instDocMap n iface ifaceMap instIfaceMap - , spanName n (synifyInstHead i) (L eSpan (tcdName d)) + cls_insts = [ ( synClsInst + , getInstDoc n + , spanName n synClsInst (L eSpan (tcdName d)) , nameModule_maybe n ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys + , let synClsInst = synifyInstHead i ] -- fam_insts but with failing type fams filtered out cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] @@ -133,7 +139,7 @@ nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d , n' <- n : (map fst subDocs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , f <- maybeToList (getFixity n') ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns @@ -152,17 +158,21 @@ let L l r = spanName s ok linst in L l (Right r) +-- | 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) -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 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 -------------------------------------------------------------------------------- @@ -210,13 +220,6 @@ instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } = (map argCount ts, 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 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 @@ -20,27 +20,21 @@ module Haddock.Interface.Create (createInterface) where import Documentation.Haddock.Doc (metaDocAppend) -import Documentation.Haddock.Utf8 as Utf8 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 Data.Bifunctor import Data.Bitraversable -import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe import Data.Ord import Control.Applicative -import Control.Exception (evaluate) import Control.Monad import Data.Traversable @@ -59,9 +53,8 @@ import RdrName import TcRnTypes import FastString ( unpackFS, fastStringToByteString) -import BasicTypes ( StringLiteral(..), SourceText(..) ) +import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O -import HsDecls ( getConArgs ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -85,7 +78,7 @@ !instances = modInfoInstances mi !fam_instances = md_fam_insts md !exportedNames = modInfoExportsWithSelectors mi - (pkgNameFS, _) = modulePackageInfo dflags flags mdl + (pkgNameFS, _) = modulePackageInfo dflags flags (Just mdl) pkgName = fmap (unpackFS . (\(PackageName n) -> n)) pkgNameFS (TcGblEnv { tcg_rdr_env = gre @@ -117,7 +110,7 @@ let declsWithDocs = topDecls group_ - exports0 = fmap (reverse . map (first unLoc)) mayExports + exports0 = fmap (map (first unLoc)) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 @@ -132,8 +125,8 @@ fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances + $ map getName fam_instances + ++ map getName instances -- Locations of all TH splices splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] @@ -170,8 +163,6 @@ modWarn <- liftErrMsg (moduleWarning dflags gre warnings) - tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm - return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig @@ -197,7 +188,8 @@ , ifaceRnOrphanInstances = [] -- Filled in `renameInterface` , ifaceHaddockCoverage = coverage , ifaceWarningMap = warningMap - , ifaceTokenizedSrc = tokenizedSrc + , ifaceHieFile = Just $ ml_hie_file $ ms_location ms + , ifaceDynFlags = dflags } @@ -899,7 +891,7 @@ Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing - Just x -> case tyThingToLHsDecl x of + Just x -> case tyThingToLHsDecl ShowRuntimeRep x of Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing Right (m, t') -> liftErrMsg (tell $ map bugWarn m) >> return (Just $ noLoc t') @@ -1077,8 +1069,8 @@ TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) - else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + then SigD noExt <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap @@ -1113,10 +1105,11 @@ in case matches of [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) _ -> error "internal: extractDecl (ClsInstD)" - _ -> error "internal: extractDecl" - + _ -> O.pprPanic "extractDecl" $ + O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" + O.$$ O.nest 4 (O.ppr decl) -extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractPatternSyn nm t tvs cons = case filter matches cons of [] -> error "extractPatternSyn: constructor pattern not found" @@ -1144,9 +1137,13 @@ data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] +extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" @@ -1162,7 +1159,11 @@ data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs + where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn + mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] @@ -1191,34 +1192,6 @@ seqList :: [a] -> () seqList [] = () seqList (x : xs) = x `seq` seqList xs - -mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule - -> ErrMsgGhc (Maybe [RichToken]) -mkMaybeTokenizedSrc dflags flags tm - | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of - Just src -> do - tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags 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 :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc dflags ms src = do - -- make sure to read the whole file at once otherwise - -- we run out of file descriptors (see #495) - rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate - let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc) - return $ Hyperlinker.enrich src tokens - where - filepath = msHsFilePath ms -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) diff --git a/src/Haddock/Interface/Json.hs b/src/Haddock/Interface/Json.hs --- a/src/Haddock/Interface/Json.hs +++ b/src/Haddock/Interface/Json.hs @@ -62,7 +62,10 @@ ] jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) +jsonDoc doc = jsonString (show (bimap showModName showName doc)) + where + showModName = showWrapped (moduleNameString . fst) + showName = showWrapped nameStableString jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString 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 @@ -19,9 +19,9 @@ , processModuleHeader ) where -import Avail import Control.Arrow import Control.Monad +import Data.Functor (($>)) import Data.List import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) @@ -34,8 +34,8 @@ import Name import Outputable ( showPpr, showSDoc ) import RdrName +import RdrHsSyn (setRdrNameSpace) import EnumSet -import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -89,24 +89,38 @@ -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) +rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier x -> do + 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 + -- 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 -- 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 - -- This shouldn't happen as 'dataTcOccs' always returns at least its input. - [] -> pure (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 @@ -116,14 +130,14 @@ -- 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] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (i $> gre_name a)) -- There are multiple names available. - gres -> ambiguous dflags x gres + gres -> ambiguous dflags i gres DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -135,7 +149,7 @@ DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) DocModule str -> pure (DocModule str) - DocHyperlink l -> pure (DocHyperlink 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) @@ -155,20 +169,25 @@ -- 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 -> ErrMsgM (Doc a) -outOfScope dflags x = - case x of - Unqual occ -> warnAndMonospace occ - Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) - Orig _ occ -> warnAndMonospace occ - Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope +outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (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 + prefix = case ns of + Value -> "the value " + Type -> "the type " + None -> "" + warnAndMonospace a = do - tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it\n" ++ - " it anyway."] - pure (monospaced a) - monospaced a = DocMonospaced (DocString (showPpr dflags a)) + let a' = showWrapped (showPpr dflags) a + tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway."] + pure (monospaced a') + monospaced = DocMonospaced . DocString -- | Handle ambiguous identifiers. -- @@ -176,26 +195,39 @@ -- -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. ambiguous :: DynFlags - -> RdrName + -> Wrap NsRdrName -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do - let noChildren = map availName (gresToAvailInfo gres) - dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres + msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by hiding some imports.\n" ++ - " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + " 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. - when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier dflt) + when (length (gresToAvailInfo gres) > 1) $ tell [msg] + pure (DocIdentifier (x $> gre_name dflt)) where - isLocalName (nameSrcLoc -> RealSrcLoc {}) = True - isLocalName _ = False - x_str = '\'' : showPpr dflags x ++ "'" - defnLoc = showSDoc dflags . pprNameDefnLoc + defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name + +-- | Handle value-namespaced names that cannot be for values. +-- +-- Emits a warning that the value-namespace is invalid on a non-value identifier. +invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) +invalidValue dflags x = do + tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ + " namespaced as such. Did you mean to specify a type namespace\n" ++ + " instead?"] + 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,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -11,12 +12,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 Haddock.Parser import Haddock.Types -import RdrName -- ----------------------------------------------------------------------------- -- Parsing module headers @@ -24,37 +25,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 -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +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 - (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 - (maintainerOpt,str7) = getKey "Maintainer" str6 - (stabilityOpt,str8) = getKey "Stability" str7 - (portabilityOpt,str9) = getKey "Portability" str8 + (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 = spdxLicenceOpt `mplus` 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 pkgName str9) + }, 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 -- @@ -73,78 +84,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,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename @@ -23,15 +24,15 @@ import Name import Outputable ( panic ) import RdrName (RdrName(Exact)) -import PrelNames (eqTyCon_RDR) +import TysWiredIn (eqTyCon_RDR) import Control.Applicative +import Control.Arrow ( first ) import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) - renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface renameInterface dflags renamingEnv warnings iface = @@ -92,56 +93,53 @@ -------------------------------------------------------------------------------- -- 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. -------------------------------------------------------------------------------- +-- | 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]) + RnM { unRn :: (Name -> (Bool, DocName)) + -- Name lookup function. The 'Bool' indicates that if the name + -- was \"found\" in the environment. + + -> (a, [Name] -> [Name]) + -- Value returned, as well as a difference list of the names not + -- found } instance Monad RnM where - (>>=) = thenRn - return = pure + m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp + (b, out2) = unRn (k a) lkp + in (b, out1 . out2) instance Functor RnM where - fmap f x = do a <- x; return (f a) + fmap f (RnM lkp) = RnM (first f . lkp) instance Applicative RnM where - pure = returnRn - (<*>) = ap - -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)) - -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) - -outRn :: Name -> RnM () -outRn name = RnM (const ((),[name])) + pure a = RnM (const (a, id)) + mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp + (x, out2) = unRn mx lkp + in (f x, out1 . out2) +-- | Look up a 'Name' in the renaming environment. lookupRn :: Name -> RnM DocName -lookupRn name = do - lkp <- getLookupRn +lookupRn name = RnM $ \lkp -> case lkp name of - (False,maps_to) -> do outRn name; return maps_to - (True, maps_to) -> return maps_to - + (False,maps_to) -> (maps_to, (name :)) + (True, maps_to) -> (maps_to, id) -runRnFM :: LinkEnv -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp +-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. +-- Returns the renamed value along with a list of `Name`'s that could not be +-- renamed because they weren't in the environment. +runRnFM :: LinkEnv -> RnM a -> (a, [Name]) +runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist []) where - lkp n = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mdl -> (True, Documented n mdl) + lkp n | isTyVarName n = (True, Undocumented n) + | otherwise = case Map.lookup n env of + Nothing -> (False, Undocumented n) + Just mdl -> (True, Documented n mdl) -------------------------------------------------------------------------------- @@ -175,8 +173,8 @@ renameLDocHsSyn = return -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse rename) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc @@ -185,6 +183,13 @@ renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType +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 + renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType @@ -240,6 +245,11 @@ b' <- renameLType b return (HsAppTy NoExt a' b') + HsAppKindTy _ a b -> do + a' <- renameLType a + b' <- renameLKind b + return (HsAppKindTy NoExt a' b') + HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b @@ -276,7 +286,7 @@ HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsSpliceTy _ s -> renameHsSpliceTy s - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsWildCardTy a -> pure (HsWildCardTy a) -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: @@ -311,9 +321,6 @@ context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo -renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) - renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName @@ -600,13 +607,16 @@ rename_ty_fam_eqn :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI)) - rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = rhs }) + rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType pats + ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; pats' <- mapM renameLTypeArg pats ; rhs' <- renameLType rhs ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } @@ -620,6 +630,7 @@ ; rhs' <- renameLType rhs ; return (L loc (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = Nothing -- this is always Nothing , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } @@ -633,13 +644,16 @@ rename_data_fam_eqn :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI)) - rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = defn }) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = defn }) = do { tc' <- renameL tc - ; pats' <- mapM renameLType pats + ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs + ; pats' <- mapM renameLTypeArg pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } 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 @@ -15,6 +15,8 @@ import GHC import Name import FastString +import TysPrim ( funTyConName ) +import TysWiredIn ( listTyConName ) import Control.Monad import Control.Monad.Trans.State @@ -47,14 +49,13 @@ -- 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 :: Data a - => LHsQTyVars GhcRn -> [HsType GhcRn] - -> a -> a +specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where @@ -64,11 +65,12 @@ bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] -> PseudoFamilyDecl GhcRn -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = - decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} + decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)} specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn @@ -110,10 +112,7 @@ sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp - where - name' = getName name - strName = occNameString . nameOccName $ name' + | getName name == listTyConName = HsListTy NoExt ltyp sugarLists typ = typ @@ -127,7 +126,7 @@ | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name - strName = occNameString . nameOccName $ name' + strName = getOccString name suitable = case parseTupleArity strName of Just arity -> arity == length apps Nothing -> False @@ -137,7 +136,7 @@ sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) 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 NoExt la lb + | funTyConName == name' = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ @@ -182,7 +181,7 @@ type NameRep = FastString getNameRep :: NamedThing name => name -> NameRep -getNameRep = occNameFS . getOccName +getNameRep = getOccFS nameRepString :: NameRep -> String nameRepString = unpackFS @@ -256,6 +255,7 @@ renameType (HsTyVar x ip name) = HsTyVar x ip <$> located 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 la lr) = HsFunTy x <$> renameLType la <*> renameLType lr renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt @@ -281,6 +281,8 @@ renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType +renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn) +renameLKind = renameLType renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -82,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) -binaryInterfaceVersion = 33 +#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) +binaryInterfaceVersion = 35 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -190,8 +190,9 @@ MonadIO m => NameCacheAccessor m -> FilePath + -> Bool -- ^ Disable version check. Can cause runtime crash. -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do +readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do bh0 <- liftIO $ readBinMem filename magic <- liftIO $ get bh0 @@ -200,7 +201,8 @@ case () of _ | magic /= binaryInterfaceMagic -> return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + | not bypass_checks + , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $ "Interface file is of wrong version: " ++ filename | otherwise -> with_name_cache $ \update_nc -> do @@ -432,7 +434,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 @@ -699,3 +701,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/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -43,7 +43,6 @@ import qualified Data.Char as Char import Data.Version import Control.Applicative -import Distribution.Verbosity import FastString import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types @@ -84,6 +83,7 @@ | Flag_Version | Flag_CompatibleInterfaceVersions | Flag_InterfaceVersion + | Flag_BypassInterfaceVersonCheck | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String @@ -175,6 +175,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") @@ -186,7 +188,7 @@ 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") @@ -329,7 +331,7 @@ 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 @@ -371,9 +373,10 @@ -> [Flag] -- ^ Haddock flags are checked as they may contain -- the package name or version provided by the user -- which we prioritise - -> Module + -> Maybe Module -> (Maybe PackageName, Maybe Data.Version.Version) -modulePackageInfo dflags flags modu = +modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing) +modulePackageInfo dflags flags (Just modu) = ( optPackageName flags <|> fmap packageName pkgDb , optPackageVersion flags <|> fmap packageVersion pkgDb ) 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,33 @@ ) 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 -> Maybe Package -> String -> MetaDoc mod RdrName +import DynFlags ( DynFlags ) +import FastString ( fsLit ) +import Lexer ( mkPState, unP, ParseResult(POk) ) +import Parser ( parseIdentifier ) +import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) +import StringBuffer ( stringToStringBuffer ) + + +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 RdrName +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 +parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) +parseIdent dflags ns str0 = + let buffer = stringToStringBuffer str1 + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) + POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) _ -> Nothing diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -28,23 +30,19 @@ import Control.Exception import Control.Arrow hiding ((<+>)) import Control.DeepSeq +import Control.Monad (ap) import Control.Monad.IO.Class (MonadIO(..)) -import Data.Typeable +import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) -import qualified Data.Map as Map import Documentation.Haddock.Types -import BasicTypes (Fixity(..)) +import BasicTypes (Fixity(..), PromotionFlag(..)) -import GHC hiding (NoLink) +import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt import OccName -import Outputable -import Control.Applicative (Applicative(..)) -import Control.Monad (ap) - -import Haddock.Backends.Hyperlinker.Types +import Outputable hiding ((<>)) ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -143,7 +141,8 @@ -- | Tokenized source code of module (avaliable if Haddock is invoked with -- source generation flag). - , ifaceTokenizedSrc :: !(Maybe [RichToken]) + , ifaceHieFile :: !(Maybe FilePath) + , ifaceDynFlags :: !DynFlags } type WarningMap = Map Name (Doc Name) @@ -274,7 +273,7 @@ noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, mempty) ----------------------------------------------------------------------------- @@ -285,6 +284,12 @@ -- | 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 + } + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module @@ -329,8 +334,31 @@ 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) +-- | 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 ----------------------------------------------------------------------------- @@ -424,10 +452,10 @@ 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 (ModuleName, OccName) id a +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a instance (NFData a, NFData mod) => NFData (DocH mod a) where @@ -467,7 +495,7 @@ 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 Picture where @@ -674,6 +702,7 @@ type instance XTyVar DocNameI = NoExt type instance XStarTy DocNameI = NoExt type instance XAppTy DocNameI = NoExt +type instance XAppKindTy DocNameI = NoExt type instance XFunTy DocNameI = NoExt type instance XListTy DocNameI = NoExt type instance XTupleTy DocNameI = NoExt @@ -689,7 +718,7 @@ type instance XExplicitListTy DocNameI = NoExt type instance XExplicitTupleTy DocNameI = NoExt type instance XTyLit DocNameI = NoExt -type instance XWildCardTy DocNameI = HsWildCardInfo +type instance XWildCardTy DocNameI = NoExt type instance XXType DocNameI = NewHsTypeX type instance XUserTyVar DocNameI = NoExt @@ -742,3 +771,19 @@ type instance XHsQTvs DocNameI = NoExt type instance XConDeclField DocNameI = NoExt +type instance XXPat DocNameI = Located (Pat DocNameI) + +type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI +instance HasSrcSpan (LPat DocNameI) where + -- NB: The following chooses the behaviour of the outer location + -- wrapper replacing the inner ones. + composeSrcSpan (L sp p) = if sp == noSrcSpan + then p + else XPat (L sp (stripSrcSpanPat p)) + -- NB: The following only returns the top-level location, if any. + decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) + decomposeSrcSpan p = L noSrcSpan p + +stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI +stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p +stripSrcSpanPat p = p diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -33,6 +33,7 @@ -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + writeUtf8File, withTempDir, -- * HTML cross reference mapping html_xrefs_ref, html_xrefs_ref', @@ -48,7 +49,7 @@ MonadIO(..), -- * Logging - parseVerbosity, + parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, -- * System tools @@ -60,9 +61,10 @@ import Haddock.Types import Haddock.GhcUtils +import BasicTypes ( PromotionFlag(..) ) +import Exception (ExceptionMonad) import GHC import Name -import HsTypes (extFieldOcc) import Outputable ( panic ) import Control.Monad ( liftM ) @@ -75,11 +77,10 @@ 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(..), stderr, 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 @@ -92,10 +93,27 @@ -- * 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 @@ -395,6 +413,19 @@ 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 :: (ExceptionMonad m) => FilePath -> m a -> m a +withTempDir dir = gbracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) ----------------------------------------------------------------------------- -- * HTML cross references 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,21 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where - import Test.Hspec import Test.QuickCheck -import qualified GHC +import GHC ( runGhc, getSessionDynFlags ) +import DynFlags ( 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 :: (GHC.DynFlags -> IO ()) -> IO () +withDynFlags :: (DynFlags -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs []) - GHC.runGhc (Just libDir) $ do - dflags <- GHC.getSessionDynFlags + runGhc (Just libDir) $ do + dflags <- getSessionDynFlags liftIO $ cont dflags @@ -54,10 +59,13 @@ parseSpec = around withDynFlags $ do it "is total" $ \dflags -> - property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0) + property $ \src -> length (parse dflags "" (fromString src)) `shouldSatisfy` (>= 0) it "retains file layout" $ \dflags -> - property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src + 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 @@ -90,7 +98,7 @@ it "should recognize preprocessor directives" $ \dflags -> do shouldParseTo "\n#define foo bar" - [TkSpace, TkCpp] + [TkCpp] dflags shouldParseTo "x # y" @@ -137,7 +145,7 @@ dflags shouldParseTo - (unlines + (fromString $ unlines [ "do" , " foo <- getLine" , " putStrLn foo" @@ -148,5 +156,7 @@ ] dflags where - shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation - shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens + shouldParseTo :: ByteString -> [TokenType] -> DynFlags -> Expectation + shouldParseTo str tokens dflags = [ tkType tok + | tok <- parse dflags "" str + , not (BS.null (tkValue tok)) ] `shouldBe` tokens