packages feed

haddock-api 2.17.4 → 2.29.1

raw patch · 62 files changed

Files

+ CHANGES.md view
@@ -0,0 +1,1 @@+See [`haddock`'s changelog](https://hackage.haskell.org/package/haddock/changelog).
LICENSE view
@@ -1,23 +1,26 @@-Copyright 2002-2010, Simon Marlow.  All rights reserved.+Copyright (c) 2002-2010, Simon Marlow+All rights reserved.  Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+modification, are permitted provided that the following conditions are+met: -- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer. -- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the+   distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR-BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,-WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN-IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
haddock-api.cabal view
@@ -1,47 +1,54 @@+cabal-version:        3.0 name:                 haddock-api-version:              2.17.4+version:              2.29.1 synopsis:             A documentation-generation tool for Haskell libraries description:          Haddock is a documentation-generation tool for Haskell                       libraries-license:              BSD3+license:              BSD-2-Clause license-file:         LICENSE author:               Simon Marlow, David Waern-maintainer:           Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>+maintainer:           Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage:             http://www.haskell.org/haddock/ bug-reports:          https://github.com/haskell/haddock/issues copyright:            (c) Simon Marlow, David Waern category:             Documentation build-type:           Simple-cabal-version:        >= 1.10-stability:            experimental+tested-with:          GHC==9.6.* +extra-source-files:+  CHANGES.md+ data-dir:   resources data-files:+  html/quick-jump.min.js+  html/haddock-bundle.min.js+  html/quick-jump.css   html/solarized.css-  html/haddock-util.js   html/highlight.js   html/Classic.theme/haskell_icon.gif   html/Classic.theme/minus.gif   html/Classic.theme/plus.gif   html/Classic.theme/xhaddock.css-  html/Ocean.std-theme/hslogo-16.png-  html/Ocean.std-theme/minus.gif-  html/Ocean.std-theme/ocean.css-  html/Ocean.std-theme/plus.gif-  html/Ocean.std-theme/synopsis.png+  html/Ocean.theme/hslogo-16.png+  html/Ocean.theme/minus.gif+  html/Ocean.theme/ocean.css+  html/Ocean.theme/plus.gif+  html/Ocean.theme/synopsis.png+  html/Linuwial.std-theme/linuwial.css+  html/Linuwial.std-theme/synopsis.png   latex/haddock.sty  library   default-language: Haskell2010    -- this package typically supports only single major versions-  build-depends: base            == 4.9.*-               , Cabal           == 1.24.*-               , ghc             == 8.0.*-               , ghc-paths       == 0.1.*-               , haddock-library >= 1.4.2 && < 1.5-               , xhtml           == 3000.2.*+  build-depends: base            ^>= 4.16.0+               , ghc             ^>= 9.6+               , ghc-paths       ^>= 0.1.0.9+               , haddock-library ^>= 1.11+               , xhtml           ^>= 3000.2.2+               , parsec          ^>= 3.1.13.0    -- Versions for the dependencies below are transitively pinned by   -- the non-reinstallable `ghc` package and hence need no version@@ -51,14 +58,26 @@                , containers                , deepseq                , directory+               , exceptions                , filepath                , ghc-boot+               , mtl                , transformers    hs-source-dirs: src -  ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2+  ghc-options: -funbox-strict-fields -O2+               -Wall+               -Wcompat+               -Wcompat-unqualified-imports+               -Widentities+               -Wredundant-constraints+               -Wnoncanonical-monad-instances+               -Wmissing-home-modules+               -Wincomplete-uni-patterns+               -Wincomplete-record-updates +   exposed-modules:     Documentation.Haddock @@ -68,15 +87,20 @@     Haddock.Interface.Rename     Haddock.Interface.Create     Haddock.Interface.AttachInstances+    Haddock.Interface.Json     Haddock.Interface.LexParseRn     Haddock.Interface.ParseModuleHeader     Haddock.Interface.Specialize     Haddock.Parser     Haddock.Utils+    Haddock.Utils.Json+    Haddock.Utils.Json.Types+    Haddock.Utils.Json.Parser     Haddock.Backends.Xhtml     Haddock.Backends.Xhtml.Decl     Haddock.Backends.Xhtml.DocMarkup     Haddock.Backends.Xhtml.Layout+    Haddock.Backends.Xhtml.Meta     Haddock.Backends.Xhtml.Names     Haddock.Backends.Xhtml.Themes     Haddock.Backends.Xhtml.Types@@ -85,7 +109,6 @@     Haddock.Backends.HaddockDB     Haddock.Backends.Hoogle     Haddock.Backends.Hyperlinker-    Haddock.Backends.Hyperlinker.Ast     Haddock.Backends.Hyperlinker.Parser     Haddock.Backends.Hyperlinker.Renderer     Haddock.Backends.Hyperlinker.Types@@ -101,6 +124,9 @@     Haddock.Convert     Paths_haddock_api +  autogen-modules:+    Paths_haddock_api+ test-suite spec   type:             exitcode-stdio-1.0   default-language: Haskell2010@@ -112,14 +138,74 @@     , src    other-modules:+    Haddock+    Haddock.Backends.Hoogle+    Haddock.Backends.Hyperlinker+    Haddock.Backends.Hyperlinker.Renderer+    Haddock.Backends.Hyperlinker.Utils+    Haddock.Backends.LaTeX+    Haddock.Backends.Xhtml+    Haddock.Backends.Xhtml.Decl+    Haddock.Backends.Xhtml.DocMarkup+    Haddock.Backends.Xhtml.Layout+    Haddock.Backends.Xhtml.Meta+    Haddock.Backends.Xhtml.Names+    Haddock.Backends.Xhtml.Themes+    Haddock.Backends.Xhtml.Types+    Haddock.Backends.Xhtml.Utils+    Haddock.Convert+    Haddock.Doc+    Haddock.GhcUtils+    Haddock.Interface+    Haddock.Interface.AttachInstances+    Haddock.Interface.Create+    Haddock.Interface.Json+    Haddock.Interface.LexParseRn+    Haddock.Interface.ParseModuleHeader+    Haddock.Interface.Rename+    Haddock.Interface.Specialize+    Haddock.InterfaceFile+    Haddock.ModuleTree+    Haddock.Options+    Haddock.Parser+    Haddock.Syb+    Haddock.Types+    Haddock.Utils+    Haddock.Utils.Json+    Haddock.Utils.Json.Types+    Haddock.Utils.Json.Parser+    Haddock.Version+    Paths_haddock_api     Haddock.Backends.Hyperlinker.ParserSpec+    Haddock.Backends.Hyperlinker.Parser+    Haddock.Backends.Hyperlinker.Types -  build-depends:-      base-    , containers-    , ghc-    , hspec-    , QuickCheck == 2.*+  build-depends: ghc             ^>= 9.6+               , ghc-paths       ^>= 0.1.0.12+               , haddock-library ^>= 1.11+               , xhtml           ^>= 3000.2.2+               , hspec           ^>= 2.9+               , parsec          ^>= 3.1.13.0+               , QuickCheck      >= 2.11  && ^>= 2.14++  -- Versions for the dependencies below are transitively pinned by+  -- the non-reinstallable `ghc` package and hence need no version+  -- bounds+  build-depends: base+               , array+               , bytestring+               , containers+               , deepseq+               , directory+               , exceptions+               , filepath+               , ghc-boot+               , ghc-boot-th+               , mtl+               , transformers++  build-tool-depends:+    hspec-discover:hspec-discover ^>= 2.9  source-repository head   type:     git
resources/html/Classic.theme/xhaddock.css view
@@ -153,6 +153,7 @@ 	text-align: center; 	right: 0; 	padding: 2px 2px 1px;+	top: 1.25em; }  #style-menu li {@@ -285,6 +286,7 @@ 	padding: 0 8px 2px 5px; 	margin-right: -3px; 	background-color: #f0f0f0;+	-moz-user-select: none; }  div.subs {@@ -391,6 +393,20 @@ }  +.doc table {+  border-collapse: collapse;+  border-spacing: 0px;+}++.doc th,+.doc td {+  padding: 5px;+  border: 1px solid #ddd;+}++.doc th {+  background-color: #f0f0f0;+}  #footer {   background-color: #000099;
+ resources/html/Linuwial.std-theme/linuwial.css view
@@ -0,0 +1,881 @@+/* @group Fundamentals */++* { margin: 0; padding: 0 }++/* Is this portable? */+html {+  background-color: white;+  width: 100%;+  height: 100%;+}++body {+  background: #fefefe;+  color: #111;+  text-align: left;+  min-height: 100vh;+  position: relative;+  -webkit-text-size-adjust: 100%;+  -webkit-font-feature-settings: "kern" 1, "liga" 0;+  -moz-font-feature-settings: "kern" 1, "liga" 0;+  -o-font-feature-settings: "kern" 1, "liga" 0;+  font-feature-settings: "kern" 1, "liga" 0;+  letter-spacing: 0.0015rem;+}++#content a {+  overflow-wrap: break-word;+}++p {+  margin: 0.8em 0;+}++ul, ol {+  margin: 0.8em 0 0.8em 2em;+}++dl {+  margin: 0.8em 0;+}++dt {+  font-weight: bold;+}+dd {+  margin-left: 2em;+}++a { text-decoration: none; }+a[href]:link { color: #9E358F; }+a[href]:visited {color: #6F5F9C; }+a[href]:hover { text-decoration:underline; }++a[href].def:link, a[href].def:visited { color: rgba(69, 59, 97, 0.8); }+a[href].def:hover { color: rgb(78, 98, 114); }++/* @end */++/* @group Show and hide with JS */++body.js-enabled .hide-when-js-enabled {+  display: none;+}++/* @end */+++/* @group responsive */++#package-header .caption {+  margin: 0px 1em 0 2em;+}++@media only screen and (min-width: 1280px) {+  #content {+    width: 63vw;+    max-width: 1450px;+  }++  #table-of-contents {+    position: fixed;+    max-width: 10vw;+    top: 10.2em;+    left: 2em;+    bottom: 1em;+    overflow-y: auto;+  }++  #synopsis {+    display: block;+    position: fixed;+    float: left;+    top: 5em;+    bottom: 1em;+    right: 0;+    max-width: 65vw;+    overflow-y: auto;+    /* Ensure that synopsis covers everything (including MathJAX markup) */+    z-index: 1;+  }++  #synopsis .show {+    border: 1px solid #5E5184;+    padding: 0.7em;+    max-height: 65vh;+  }++}++@media only screen and (max-width: 1279px) {+  #content {+    width: 80vw;+  }++  #synopsis {+    display: block;+    padding: 0;+    position: relative;+    margin: 0;+    width: 100%;+  }+}++@media only screen and (max-width: 999px) {+  #content {+    width: 93vw;+  }+}+++/* menu for wider screens++  Display the package name at the left and the menu links at the right,+  inline with each other:+  The package name                                   Source . Contents . Index+*/+@media only screen and (min-width: 1000px) {+  #package-header {+      text-align: left;+      white-space: nowrap;+      height: 40px;+      padding: 4px 1.5em 0px 1.5em;+      overflow: visible;++      display: flex;+      justify-content: space-between;+      align-items: center;+  }++  #package-header .caption {+    display: inline-block;+    margin: 0;+  }++  #package-header ul.links {+    margin: 0;+    display: inline-table;+  }++  #package-header .caption + ul.links {+    margin-left: 1em;+  }+}++/* menu for smaller screens++Display the package name on top of the menu links and center both elements:+                  The package name+              Source . Contents . Index+*/+@media only screen and (max-width: 999px) {+  #package-header {+    text-align: center;+    padding: 6px 0 4px 0;+    overflow: hidden;+  }++  #package-header ul.links {+    display: block;+    text-align: center;+    margin: 0;++    /* Hide scrollbar but allow scrolling menu links horizontally */+    white-space: nowrap;+    overflow-x: auto;+    overflow-y: hidden;+    margin-bottom: -17px;+    height: 50px;+  }++  #package-header .caption {+    display: block;+    margin: 4px 0;+    text-align: center;+  }++  #package-header ul.links::-webkit-scrollbar {+    display: none;+  }++  #package-header ul.links li:first-of-type {+    padding-left: 1em;+  }++  #package-header ul.links li:last-of-type {+    /*+    The last link of the menu should offer the same distance to the right+    as the #package-header enforces at the left.+    */+    padding-right: 1em;+  }++  #package-header .caption + ul.links {+    padding-top: 9px;+  }++  #module-header table.info {+    float: none;+    top: 0;+    margin: 0 auto;+    overflow: hidden;+    max-width: 80vw;+  }+}++/* @end */+++/* @group Fonts & Sizes */++/* Basic technique & IE workarounds from YUI 3+   For reasons, see:+      http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css+ */++ body, button {+   font: 400 14px/1.4 'PT Sans',+     /* Fallback Font Stack */+     -apple-system,+	  BlinkMacSystemFont,+     'Segoe UI',+	  Roboto,+	  Oxygen-Sans,+	  Cantarell,+	  'Helvetica Neue',+     sans-serif;+   *font-size: medium; /* for IE */+   *font:x-small; /* for IE in quirks mode */+ }++h1 { font-size: 146.5%; /* 19pt */ }+h2 { font-size: 131%;   /* 17pt */ }+h3 { font-size: 116%;   /* 15pt */ }+h4 { font-size: 100%;   /* 13pt */ }+h5 { font-size: 100%;   /* 13pt */ }++table {+	font-size:inherit;+	font:100%;+}++pre, code, kbd, samp, tt, .src {+	font-family:monospace;+}++.links, .link {+  font-size: 85%; /* 11pt */+}++#module-header .caption {+  font-size: 182%; /* 24pt */+}++#module-header .caption sup {+  font-size: 80%;+  font-weight: normal;+}++#package-header #page-menu a:link, #package-header #page-menu a:visited { color: white; }+++.info {+  font-size: 90%;+}+++/* @end */++/* @group Common */++.caption, h1, h2, h3, h4, h5, h6, summary {+  font-weight: bold;+  color: #5E5184;+  margin: 1.5em 0 1em 0;+}+++* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {+  margin-top: 2em;+}++h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {+  margin-top: inherit;+}++ul li + li {+	margin-top: 0.2rem;+}++ul + p {+  margin-top: 0.93em;+}++p + ul {+  margin-top: 0.5em;+}++p {+  margin-top: 0.7rem;+}++ul, ol {+  margin: 0.8em 0 0.8em 2em;+}++ul.links {+  list-style: none;+  text-align: left;+  font-size: 0.95em;+}++#package-header ul.links, #package-header ul.links button {+  font-size: 1rem;+}++ul.links li {+  display: inline;+  white-space: nowrap;+  padding: 0;+}++ul.links > li + li:before {+  content: '\00B7';+}++ul.links li a {+  padding: 0.2em 0.5em;+}++.hide { display: none; }+.show { display: inherit; }+.clear { clear: both; }++.collapser:before, .expander:before, .noexpander:before {+  font-size: 1.2em;+  color: #9C5791;+  display: inline-block;+  padding-right: 7px;+}++.collapser:before {+  content: '▿';+}+.expander:before {+  content: '▹';+}+.noexpander:before {+  content: '▿';+  visibility: hidden;+}++.collapser, .expander {+  cursor: pointer;+}++.instance.collapser, .instance.expander {+  margin-left: 0px;+  background-position: left center;+  min-width: 9px;+  min-height: 9px;+}++summary {+  cursor: pointer;+  outline: none;+}++pre {+  padding: 0.5rem 1rem;+  margin: 1em 0 0 0;+  background-color: #f7f7f7;+  overflow: auto;+  border: 1px solid #ddd;+  border-radius: 0.3em;+}++pre + p {+  margin-top: 1em;+}++pre + pre {+  margin-top: 0.5em;+}++blockquote {+  border-left: 3px solid #c7a5d3;+  background-color: #eee4f1;+  margin: 0.5em;+  padding: 0.0005em 0.3em 0.5em 0.5em;+}++.src {+  background: #f2f2f2;+  padding: 0.2em 0.5em;+}++.keyword { font-weight: normal; }+.def { font-weight: bold; }++@media print {+  #footer { display: none; }+}++/* @end */++/* @group Page Structure */++#content {+  margin: 3em auto 6em auto;+  padding: 0;+}++#package-header {+  background: #5E5184;+  border-bottom: 5px solid rgba(69, 59, 97, 0.5);+  color: #ddd;+  position: relative;+  font-size: 1.2em;+  text-align: left;+  margin: 0 auto;+}++#package-header .caption {+  color: white;+  font-style: normal;+  font-size: 1rem;+  font-weight: bold;+}++#module-header .caption {+  font-weight: bold;+  border-bottom: 1px solid #ddd;+}++table.info {+  float: right;+  padding: 0.5em 1em;+  border: 1px solid #ddd;+  color: rgb(78,98,114);+  background-color: #fff;+  max-width: 60%;+  border-spacing: 0;+  position: relative;+  top: -0.78em;+  margin: 0 0 0 2em;+}++.info th {+  padding: 0 1em 0 0;+  text-align: right;+}++#style-menu li {+	display: block;+	border-style: none;+	list-style-type: none;+}++#footer {+  background: #ededed;+  border-top: 1px solid #aaa;+  padding: 0.5em 0;+  color: #222;+  text-align: center;+  width: 100%;+  height: 3em;+  margin-top: 3em;+  position: relative;+  clear: both;+}++/* @end */++/* @group Front Matter */++#synopsis .caption,+#contents-list .caption {+  font-size: 1rem;+}++#synopsis, #table-of-contents {+  font-size: 16px;+}++#contents-list {+  background: #f4f4f4;+  padding: 1em;+  margin: 0;+}++#contents-list .caption {+  text-align: left;+  margin: 0;+}++#contents-list ul {+  list-style: none;+  margin: 0;+  margin-top: 10px;+  font-size: 14px;+}++#contents-list ul ul {+  margin-left: 1.5em;+}++#description .caption {+  display: none;+}++#synopsis summary {+  display: block;+  float: right;+  width: 29px;+  color: rgba(255,255,255,0);+  height: 110px;+  margin: 0;+  font-size: 1px;+  padding: 0;+  background: url(synopsis.png) no-repeat 0px -8px;+}++#synopsis details[open] > summary {+  background: url(synopsis.png) no-repeat -75px -8px;+}++#synopsis details:not([open]) > ul {+  visibility: hidden;+}++#synopsis ul {+  height: 100%;+  overflow: auto;+  padding: 0.5em;+  margin: 0;+}++#synopsis ul ul {+  overflow: hidden;+}++#synopsis ul,+#synopsis ul li.src {+  background-color: rgb(250,247,224);+  white-space: nowrap;+  list-style: none;+  margin-left: 0;+}++#interface td.src {+  white-space: nowrap;+}++/* @end */++/* @group Main Content */++#interface div.top + div.top {+  margin-top: 1.5em;+}++#interface p + div.top,+#interface h1 + div.top,+#interface h2 + div.top,+#interface h3 + div.top,+#interface h4 + div.top,+#interface h5 + div.top {+	margin-top: 1em;+}+#interface .src .selflink,+#interface .src .link {+  float: right;+  color: #888;+  padding: 0 7px;+  -moz-user-select: none;+  font-weight: bold;+  line-height: 30px;+}+#interface .src .selflink {+  margin: 0 -0.5em 0 0.5em;+}++#interface span.fixity {+  color: #919191;+  border-left: 1px solid #919191;+  padding: 0.2em 0.5em 0.2em 0.5em;+  margin: 0 -1em 0 1em;+}++#interface span.rightedge {+  border-left: 1px solid #919191;+  padding: 0.2em 0 0.2em 0;+  margin: 0 0 0 1em;+}++#interface table { border-spacing: 2px; }+#interface td {+  vertical-align: top;+  padding-left: 0.5em;+}++#interface td.doc p {+  margin: 0;+}+#interface td.doc p + p {+  margin-top: 0.8em;+}++.doc table {+  border-collapse: collapse;+  border-spacing: 0px;+}++.doc th,+.doc td {+  padding: 5px;+  border: 1px solid #ddd;+}++.doc th {+  background-color: #f0f0f0;+}++.clearfix:after {+  clear: both;+  content: " ";+  display: block;+  height: 0;+  visibility: hidden;+}++.subs, .top > .doc, .subs > .doc {+  padding-left: 1em;+  border-left: 1px solid gainsboro;+  margin-bottom: 1em;+}++.top .subs {+  margin-bottom: 0.6em;+}++.subs.fields ul {+  list-style: none;+  display: table;+  margin: 0;+}++.subs.fields ul li {+  display: table-row;+}++.subs ul li dfn {+  display: table-cell;+  font-style: normal;+  font-weight: bold;+  margin: 1px 0;+  white-space: nowrap;+}++.subs ul li > .doc {+  display: table-cell;+  padding-left: 0.5em;+  margin-bottom: 0.5em;+}++.subs ul li > .doc p {+  margin: 0;+}++.subs .subs p.src {+  border: none;+  background-color: #f8f8f8;+}++.subs .subs .caption {+  margin-top: 1em ;+  margin-bottom: 0px;+}++.subs p.caption {+    margin-top: 0;+}++.subs .subs .caption + .src {+  margin: 0px;+  margin-top: 8px;+}++.subs .subs .src + .src {+  margin: 7px 0 0 0;+}++/* Render short-style data instances */+.inst ul {+  height: 100%;+  padding: 0.5em;+  margin: 0;+}++.inst, .inst li {+  list-style: none;+  margin-left: 1em;+}++/* Workaround for bug in Firefox (issue #384) */+.inst-left {+  float: left;+}++.top p.src {+  border-bottom: 3px solid #e5e5e5;+  line-height: 2rem;+  margin-bottom: 1em;+}++.warning {+  color: red;+}++.arguments {+  margin-top: -0.4em;+}+.arguments .caption {+  display: none;+}++.fields { padding-left: 1em; }++.fields .caption { display: none; }++.fields p { margin: 0 0; }++/* this seems bulky to me+.methods, .constructors {+  background: #f8f8f8;+  border: 1px solid #eee;+}+*/++/* @end */++/* @group Auxillary Pages */+++.extension-list {+    list-style-type: none;+    margin-left: 0;+}++#mini {+  margin: 0 auto;+  padding: 0 1em 1em;+}++#mini > * {+  font-size: 93%; /* 12pt */+}++#mini #module-list .caption,+#mini #module-header .caption {+  font-size: 125%; /* 15pt */+}++#mini #interface h1,+#mini #interface h2,+#mini #interface h3,+#mini #interface h4 {+  font-size: 109%; /* 13pt */+  margin: 1em 0 0;+}++#mini #interface .top,+#mini #interface .src {+  margin: 0;+}++#mini #module-list ul {+  list-style: none;+  margin: 0;+}++#alphabet ul {+	list-style: none;+	padding: 0;+	margin: 0.5em 0 0;+	text-align: center;+}++#alphabet li {+	display: inline;+	margin: 0 0.25em;+}++#alphabet a {+	font-weight: bold;+}++#index .caption,+#module-list .caption { font-size: 131%; /* 17pt */ }++#index table {+  margin-left: 2em;+}++#index .src {+  font-weight: bold;+}+#index .alt {+  font-size: 77%; /* 10pt */+  font-style: italic;+  padding-left: 2em;+}++#index td + td {+  padding-left: 1em;+}++#module-list ul {+  list-style: none;+  margin: 0 0 0 2em;+}++#module-list li {+  clear: right;+}++#module-list span.collapser,+#module-list span.expander {+  background-position: 0 0.3em;+}++#module-list .package {+  float: right;+}++:target {+  background: -webkit-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%);+  background: -moz-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%);+  background: -o-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%);+  background: -ms-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%);+  background: linear-gradient(to bottom, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%);+}++:target:hover {+  background: -webkit-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%);+  background: -moz-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%);+  background: -o-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%);+  background: -ms-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%);+  background: linear-gradient(to bottom, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%);+}++/* @end */++/* @group Dropdown menus */++#preferences-menu, #style-menu {+  width: 25em;+  overflow-y: auto;+}++/* @end */
+ resources/html/Linuwial.std-theme/synopsis.png view

binary file changed (absent → 11327 bytes)

− resources/html/Ocean.std-theme/hslogo-16.png

binary file changed (1684 → absent bytes)

− resources/html/Ocean.std-theme/minus.gif

binary file changed (56 → absent bytes)

− resources/html/Ocean.std-theme/ocean.css 
@@ -1,612 +0,0 @@-/* @group Fundamentals */--* { margin: 0; padding: 0 }--/* Is this portable? */-html {-  background-color: white;-  width: 100%;-  height: 100%;-}--body {-  background: white;-  color: black;-  text-align: left;-  min-height: 100%;-  position: relative;-}--p {-  margin: 0.8em 0;-}--ul, ol {-  margin: 0.8em 0 0.8em 2em;-}--dl {-  margin: 0.8em 0;-}--dt {-  font-weight: bold;-}-dd {-  margin-left: 2em;-}--a { text-decoration: none; }-a[href]:link { color: rgb(196,69,29); }-a[href]:visited { color: rgb(171,105,84); }-a[href]:hover { text-decoration:underline; }--a[href].def:link, a[href].def:visited { color: black; }-a[href].def:hover { color: rgb(78, 98, 114); }--/* @end */--/* @group Fonts & Sizes */--/* Basic technique & IE workarounds from YUI 3-   For reasons, see:-      http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css- */--body {-	font:13px/1.4 sans-serif;-	*font-size:small; /* for IE */-	*font:x-small; /* for IE in quirks mode */-}--h1 { font-size: 146.5%; /* 19pt */ }-h2 { font-size: 131%;   /* 17pt */ }-h3 { font-size: 116%;   /* 15pt */ }-h4 { font-size: 100%;   /* 13pt */ }-h5 { font-size: 100%;   /* 13pt */ }--select, input, button, textarea {-	font:99% sans-serif;-}--table {-	font-size:inherit;-	font:100%;-}--pre, code, kbd, samp, tt, .src {-	font-family:monospace;-	*font-size:108%;-	line-height: 124%;-}--.links, .link {-  font-size: 85%; /* 11pt */-}--#module-header .caption {-  font-size: 182%; /* 24pt */-}--.info  {-  font-size: 85%; /* 11pt */-}--#table-of-contents, #synopsis  {-  /* font-size: 85%; /* 11pt */-}---/* @end */--/* @group Common */--.caption, h1, h2, h3, h4, h5, h6 {-  font-weight: bold;-  color: rgb(78,98,114);-  margin: 0.8em 0 0.4em;-}--* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {-  margin-top: 2em;-}--h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {-  margin-top: inherit;-}--ul.links {-  list-style: none;-  text-align: left;-  float: right;-  display: inline-table;-  margin: 0 0 0 1em;-}--ul.links li {-  display: inline;-  border-left: 1px solid #d5d5d5;-  white-space: nowrap;-  padding: 0;-}--ul.links li a {-  padding: 0.2em 0.5em;-}--.hide { display: none; }-.show { display: inherit; }-.clear { clear: both; }--.collapser {-  background-image: url(minus.gif);-  background-repeat: no-repeat;-}-.expander {-  background-image: url(plus.gif);-  background-repeat: no-repeat;-}-.collapser, .expander {-  padding-left: 14px;-  margin-left: -14px;-  cursor: pointer;-}-p.caption.collapser,-p.caption.expander {-  background-position: 0 0.4em;-}--.instance.collapser, .instance.expander {-  margin-left: 0px;-  background-position: left center;-  min-width: 9px;-  min-height: 9px;-}---pre {-  padding: 0.25em;-  margin: 0.8em 0;-  background: rgb(229,237,244);-  overflow: auto;-  border-bottom: 0.25em solid white;-  /* white border adds some space below the box to compensate-     for visual extra space that paragraphs have between baseline-     and the bounding box */-}--.src {-  background: #f0f0f0;-  padding: 0.2em 0.5em;-}--.keyword { font-weight: normal; }-.def { font-weight: bold; }--@media print {-  #footer { display: none; }-}--/* @end */--/* @group Page Structure */--#content {-  margin: 0 auto;-  padding: 0 2em 6em;-}--#package-header {-  background: rgb(41,56,69);-  border-top: 5px solid rgb(78,98,114);-  color: #ddd;-  padding: 0.2em;-  position: relative;-  text-align: left;-}--#package-header .caption {-  background: url(hslogo-16.png) no-repeat 0em;-  color: white;-  margin: 0 2em;-  font-weight: normal;-  font-style: normal;-  padding-left: 2em;-}--#package-header a:link, #package-header a:visited { color: white; }-#package-header a:hover { background: rgb(78,98,114); }--#module-header .caption {-  color: rgb(78,98,114);-  font-weight: bold;-  border-bottom: 1px solid #ddd;-}--table.info {-  float: right;-  padding: 0.5em 1em;-  border: 1px solid #ddd;-  color: rgb(78,98,114);-  background-color: #fff;-  max-width: 40%;-  border-spacing: 0;-  position: relative;-  top: -0.5em;-  margin: 0 0 0 2em;-}--.info th {-	padding: 0 1em 0 0;-}--div#style-menu-holder {-  position: relative;-  z-index: 2;-  display: inline;-}--#style-menu {-  position: absolute;-  z-index: 1;-  overflow: visible;-  background: #374c5e;-  margin: 0;-  text-align: center;-  right: 0;-  padding: 0;-  top: 1.25em;-}--#style-menu li {-	display: list-item;-	border-style: none;-	margin: 0;-	padding: 0;-	color: #000;-	list-style-type: none;-}--#style-menu li + li {-	border-top: 1px solid #919191;-}--#style-menu a {-  width: 6em;-  padding: 3px;-  display: block;-}--#footer {-  background: #ddd;-  border-top: 1px solid #aaa;-  padding: 0.5em 0;-  color: #666;-  text-align: center;-  position: absolute;-  bottom: 0;-  width: 100%;-  height: 3em;-}--/* @end */--/* @group Front Matter */--#table-of-contents {-  float: right;-  clear: right;-  background: #faf9dc;-  border: 1px solid #d8d7ad;-  padding: 0.5em 1em;-  max-width: 20em;-  margin: 0.5em 0 1em 1em;-}--#table-of-contents .caption {-  text-align: center;-  margin: 0;-}--#table-of-contents ul {-  list-style: none;-  margin: 0;-}--#table-of-contents ul ul {-  margin-left: 2em;-}--#description .caption {-  display: none;-}--#synopsis {-  display: none;-}--.no-frame #synopsis {-  display: block;-  position: fixed;-  right: 0;-  height: 80%;-  top: 10%;-  padding: 0;-  max-width: 75%;-  /* Ensure that synopsis covers everything (including MathJAX markup) */-  z-index: 1;-}--#synopsis .caption {-  float: left;-  width: 29px;-  color: rgba(255,255,255,0);-  height: 110px;-  margin: 0;-  font-size: 1px;-  padding: 0;-}--#synopsis p.caption.collapser {-  background: url(synopsis.png) no-repeat -64px -8px;-}--#synopsis p.caption.expander {-  background: url(synopsis.png) no-repeat 0px -8px;-}--#synopsis ul {-  height: 100%;-  overflow: auto;-  padding: 0.5em;-  margin: 0;-}--#synopsis ul ul {-  overflow: hidden;-}--#synopsis ul,-#synopsis ul li.src {-  background-color: #faf9dc;-  white-space: nowrap;-  list-style: none;-  margin-left: 0;-}--/* @end */--/* @group Main Content */--#interface div.top { margin: 2em 0; }-#interface h1 + div.top,-#interface h2 + div.top,-#interface h3 + div.top,-#interface h4 + div.top,-#interface h5 + div.top {- 	margin-top: 1em;-}-#interface .src .selflink,-#interface .src .link {-  float: right;-  color: #919191;-  background: #f0f0f0;-  padding: 0 0.5em 0.2em;-  margin: 0 -0.5em 0 0;-}-#interface .src .selflink {-  border-left: 1px solid #919191;-  margin: 0 -0.5em 0 0.5em;-}--#interface span.fixity {-  color: #919191;-  border-left: 1px solid #919191;-  padding: 0.2em 0.5em 0.2em 0.5em;-  margin: 0 -1em 0 1em;-}--#interface span.rightedge {-  border-left: 1px solid #919191;-  padding: 0.2em 0 0.2em 0;-  margin: 0 0 0 1em;-}--#interface table { border-spacing: 2px; }-#interface td {-  vertical-align: top;-  padding-left: 0.5em;-}-#interface td.src {-  white-space: nowrap;-}-#interface td.doc p {-  margin: 0;-}-#interface td.doc p + p {-  margin-top: 0.8em;-}--.clearfix:after {-  clear: both;-  content: " ";-  display: block;-  height: 0;-  visibility: hidden;-}--.subs ul {-  list-style: none;-  display: table;-  margin: 0;-}--.subs ul li {-  display: table-row;-}--.subs ul li dfn {-  display: table-cell;-  font-style: normal;-  font-weight: bold;-  margin: 1px 0;-  white-space: nowrap;-}--.subs ul li > .doc {-  display: table-cell;-  padding-left: 0.5em;-  margin-bottom: 0.5em;-}--.subs ul li > .doc p {-  margin: 0;-}--/* Render short-style data instances */-.inst ul {-  height: 100%;-  padding: 0.5em;-  margin: 0;-}--.inst, .inst li {-  list-style: none;-  margin-left: 1em;-}--/* Workaround for bug in Firefox (issue #384) */-.inst-left {-  float: left;-}--.top p.src {-  border-top: 1px solid #ccc;-}--.subs, .doc {-  /* use this selector for one level of indent */-  padding-left: 2em;-}--.warning {-  color: red;-}--.arguments {-  margin-top: -0.4em;-}-.arguments .caption {-  display: none;-}--.fields { padding-left: 1em; }--.fields .caption { display: none; }--.fields p { margin: 0 0; }--/* this seems bulky to me-.methods, .constructors {-  background: #f8f8f8;-  border: 1px solid #eee;-}-*/--/* @end */--/* @group Auxillary Pages */---.extension-list {-    list-style-type: none;-    margin-left: 0;-}--#mini {-  margin: 0 auto;-  padding: 0 1em 1em;-}--#mini > * {-  font-size: 93%; /* 12pt */-}--#mini #module-list .caption,-#mini #module-header .caption {-  font-size: 125%; /* 15pt */-}--#mini #interface h1,-#mini #interface h2,-#mini #interface h3,-#mini #interface h4 {-  font-size: 109%; /* 13pt */-  margin: 1em 0 0;-}--#mini #interface .top,-#mini #interface .src {-  margin: 0;-}--#mini #module-list ul {-  list-style: none;-  margin: 0;-}--#alphabet ul {-	list-style: none;-	padding: 0;-	margin: 0.5em 0 0;-	text-align: center;-}--#alphabet li {-	display: inline;-	margin: 0 0.25em;-}--#alphabet a {-	font-weight: bold;-}--#index .caption,-#module-list .caption { font-size: 131%; /* 17pt */ }--#index table {-  margin-left: 2em;-}--#index .src {-  font-weight: bold;-}-#index .alt {-  font-size: 77%; /* 10pt */-  font-style: italic;-  padding-left: 2em;-}--#index td + td {-  padding-left: 1em;-}--#module-list ul {-  list-style: none;-  margin: 0 0 0 2em;-}--#module-list li {-  clear: right;-}--#module-list span.collapser,-#module-list span.expander {-  background-position: 0 0.3em;-}--#module-list .package {-  float: right;-}--/* @end */
− resources/html/Ocean.std-theme/plus.gif

binary file changed (59 → absent bytes)

− resources/html/Ocean.std-theme/synopsis.png

binary file changed (11327 → absent bytes)

+ resources/html/Ocean.theme/hslogo-16.png view

binary file changed (absent → 1684 bytes)

+ resources/html/Ocean.theme/minus.gif view

binary file changed (absent → 56 bytes)

+ resources/html/Ocean.theme/ocean.css view
@@ -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 */
+ resources/html/Ocean.theme/plus.gif view

binary file changed (absent → 59 bytes)

+ resources/html/Ocean.theme/synopsis.png view

binary file changed (absent → 11327 bytes)

+ resources/html/haddock-bundle.min.js view
@@ -0,0 +1,2 @@+!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e<l.length;e++)c(l[e]);return c}({1:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0}),n.setCookie=function(e,t){document.cookie=e+"="+encodeURIComponent(t)+";path=/;"},n.clearCookie=function(e){document.cookie=e+"=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"},n.getCookie=function(e){for(var t=e+"=",n=document.cookie.split(";"),o=0;o<n.length;o++){for(var r=n[o];" "==r.charAt(0);)r=r.substring(1,r.length);if(0==r.indexOf(t))return decodeURIComponent(r.substring(t.length,r.length))}return null}},{}],2:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i,s,a=e("preact"),l=a.h,c=a.Component;(s=i||(i={}))[s.Closed=0]="Closed",s[s.Open=1]="Open";var u={defaultInstanceState:i.Open,rememberToggles:!0},d=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return l("li",null,l("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(c);function h(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),a.render(l(d,{onClick:e,title:"Instances"}),t,n)}var p=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.componentWillMount=function(){var t=this;document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){t.state.isVisible&&"Escape"===e.key&&t.hide()})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||this.setState({isVisible:!0})},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){return l("div",{id:"preferences",class:t.isVisible?"":"hidden"},l("div",{id:"preferences-menu",class:"dropdown-menu",onMouseDown:function(e){e.stopPropagation()}},l(b,null)))},t}(c);function f(){var e=JSON.stringify(u);try{localStorage.setItem("global",e)}catch(e){}}var v=!1;function g(){if(!v){v=!0;var e=localStorage.getItem("global");if(e)try{var t=JSON.parse(e);u.defaultInstanceState=t.defaultInstanceState,u.rememberToggles=t.rememberToggles}catch(e){if(!(e instanceof SyntaxError||e instanceof TypeError))throw e;localStorage.removeItem("global")}}}function m(t){return function(e){u.defaultInstanceState=t,A(),f(),E(),O()}}function y(e){var t=e.target.checked;u.rememberToggles=t,f(),E(),O()}function _(e){var t=document.getElementById("default-collapse-instances");null!==t&&(t.checked?m(i.Closed)(e):m(i.Open)(e))}function b(){return g(),l("div",null,l("div",null,l("button",{type:"button",onClick:j},"Expand All Instances"),l("button",{type:"button",onClick:P},"Collapse All Instances")),l("div",null,l("input",{type:"checkbox",id:"default-collapse-instances",name:"default-instance-state",checked:u.defaultInstanceState===i.Closed,onClick:_}),l("span",null,"Collapse All Instances By Default")),l("div",null,l("input",{type:"checkbox",id:"remember-toggles",name:"remember-toggles",checked:u.rememberToggles,onClick:y}),l("label",{for:"remember-toggles"},"Remember Manually Collapsed/Expanded Instances")))}var k={};function S(e){var t=k[e];if(null==t)throw new Error("could not find <details> 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;o<r.length;o++){var i=r[o];i.classList.contains("details-toggle-control")&&(i.classList.add(n?"collapser":"expander"),i.classList.remove(n?"expander":"collapser"))}}function C(e){var t=e.getAttribute("data-details-id");if(!t)throw new Error("element with class "+e+" has no 'data-details-id' attribute!");return t}function L(e){var t=S(C(e)).element;t.open=!t.open}var M="local-details-config:";function I(){return M+document.location.pathname}function E(){for(var e=[],t=0;t<localStorage.length;++t){var n=localStorage.key(t);null!==n&&n.startsWith(M)&&e.push(n)}e.forEach(function(e){localStorage.removeItem(e)})}function O(){if(u.rememberToggles){var e=Array.prototype.slice.call(document.getElementsByClassName("instances details-toggle details-toggle-control")),n=[];e.forEach(function(e){var t=C(e);document.getElementById(t).open!=x()&&n.push(t)});var t=JSON.stringify(n);try{localStorage.setItem(I(),t)}catch(e){}}}function A(){switch(u.defaultInstanceState){case i.Closed:N(!0);break;case i.Open:N(!1)}}function T(e){L(e.currentTarget),O()}function N(o){var e=document.getElementsByClassName("subs instances");[].forEach.call(e,function(e){var t=o?"collapser":"expander",n=e.getElementsByClassName("instances "+t)[0];n&&L(n)})}function P(){N(!0),O()}function j(){N(!1),O()}n.init=function(e){!function(){for(var e=0,t=Array.prototype.slice.call(document.getElementsByTagName("details"));e<t.length;e++){var n=t[e];"string"==typeof n.id&&0<n.id.length&&(k[n.id]={element:n,toggles:[]},n.addEventListener("toggle",w))}}(),Array.prototype.slice.call(document.getElementsByClassName("details-toggle")).forEach(function(e){var t=S(C(e));t.toggles.push(e),e.addEventListener("click",T),e.classList.contains("details-toggle-control")&&e.classList.add(t.element.open?"collapser":"expander")}),function(){if(g(),A(),u.rememberToggles){var e=localStorage.getItem(I());if(e)try{JSON.parse(e).forEach(function(e){S(e).element.open=!x()})}catch(e){if(!(e instanceof SyntaxError||e instanceof TypeError))throw e;localStorage.removeItem(I())}}}(),a.render(l(p,{showHideTrigger:e||h}),document.body)}},{preact:7}],3:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0});var o,r=e("./style-menu"),i=e("./details-helper"),s=e("./quick-jump");o=function(){document.body.classList.add("js-enabled"),r.init(),i.init();var e=document.getElementById("head"),t=".";null!==e&&(t=e.getAttribute("data-base-url")||"."),s.init(t)},"interactive"===document.readyState?o():document.addEventListener("readystatechange",function(){"interactive"===document.readyState&&o()})},{"./details-helper":2,"./quick-jump":4,"./style-menu":5}],4:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("fuse.js"),s=e("preact"),a=s.h,l=s.Component;var c=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);function u(e,t){return t.length<=e?t:t.slice(0,e)}var d=function(t){function e(){var e=null!==t&&t.apply(this,arguments)||this;return e.linkIndex=0,e.focusPlease=!1,e.navigatedByKeyboard=!1,e}return r(e,t),e.prototype.componentWillMount=function(){var e,t,n,o,r=this;this.setState({searchString:"",isVisible:!1,expanded:{},activeLinkIndex:-1,moduleResults:[]}),e=this.props.baseUrl+"/doc-index.json",t=function(e){r.setState({fuse:new i(e,{threshold:.25,caseSensitive:!0,includeScore:!0,tokenize:!0,keys:[{name:"name",weight:.7},{name:"module",weight:.3}]}),moduleResults:[]})},n=function(e){console&&console.error("could not load 'doc-index.json' for searching",e),r.setState({failedLoading:!0})},(o=new XMLHttpRequest).onreadystatechange=function(){if(o.readyState===XMLHttpRequest.DONE)if(200===o.status){if(t)try{t(JSON.parse(o.responseText))}catch(e){n(o)}}else n&&n(o)},o.open("GET",e,!0),o.send(),document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){r.state.isVisible&&("Escape"===e.key?r.hide():"ArrowUp"===e.key||"k"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(-1)):"ArrowDown"===e.key||"j"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(1)):"Enter"===e.key&&0<=r.state.activeLinkIndex&&r.followActiveLink()),"s"===e.key&&"input"!==e.target.tagName.toLowerCase()&&(e.preventDefault(),r.show())})},e.prototype.hide=function(){this.setState({isVisible:!1,searchString:""})},e.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},e.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},e.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})},e.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},e.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t=this.state.fuse.search(e),o={};t.forEach(function(e){var t=e.item.module;(o[t]||(o[t]=[])).push(e)});var r=[],n=function(e){var t=o[e],n=0;t.forEach(function(e){n+=1/e.score}),r.push({module:e,totalScore:1/n,items:t})};for(var i in o)n(i);r.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:r})},e.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<t&&(this.searchResults.scrollTop-=t-e.top+80)}this.focusPlease&&this.input&&this.input.focus(),this.navigatedByKeyboard=!1,this.focusPlease=!1},e.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},e.prototype.render=function(e,t){var r=this;if(t.failedLoading){var n="file:"==window.location.protocol;return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-results"},a("p",{class:"error"},"Failed to load file 'doc-index.json' containing definitions in this package."),n?a("p",{class:"error"},"To use quick jump, load this page with HTTP (from a local static file web server) instead of using the ",a("code",null,"file://")," protocol. (For security reasons, it is not possible to fetch auxiliary files using JS in a HTML page opened with ",a("code",null,"file://"),".)"):[]))}this.linkIndex=0;var o=function(e){e.stopPropagation()},i=u(10,t.moduleResults).map(function(e){return r.renderResultsInModule(e)});return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-form",onMouseDown:o},a("input",{placeholder:"Search in package by name",ref:function(e){r.input=e},onFocus:this.show.bind(this),onClick:this.show.bind(this),onInput:this.updateResults.bind(this)})),a("div",{id:"search-results",ref:function(e){r.searchResults=e},onMouseDown:o,onMouseOver:function(e){for(var t=e.target;t&&"function"==typeof t.getAttribute;){var n=t.getAttribute("data-link-index");if("string"==typeof n){var o=parseInt(n,10);r.setState({activeLinkIndex:o});break}t=t.parentNode}}},""===t.searchString?[a(f,null),a(p,null)]:0==i.length?a(v,{searchString:t.searchString}):a("ul",null,i)))},e.prototype.renderResultsInModule=function(e){var n=this,t=e.items,o=e.module,r=this.state.expanded[o]||t.length<=10,i=r?t:u(8,t);return a("li",{class:"search-module"},a("h4",null,o),a("ul",null,i.map(function(e){return t=e.item,a("li",{class:"search-result"},n.navigationLink(n.props.baseUrl+"/"+t.link,{},a(h,{html:t.display_html})));var t}),r?[]:a("li",{class:"more-results"},this.actionLink(function(){var e=Object.assign({},n.state.expanded);e[o]=!0,n.setState({expanded:e})},{},"show "+(t.length-i.length)+" more results from this module"))))},e.prototype.navigationLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=Object.assign({href:e,onClick:this.hide.bind(this)},t);return this.menuLink.apply(this,[i,function(){window.location.href=e,n.hide()}].concat(o))},e.prototype.actionLink=function(t,e){for(var n=[],o=2;o<arguments.length;o++)n[o-2]=arguments[o];var r=Object.assign({href:"#",onClick:function(e){e.preventDefault(),t()}},e);return this.menuLink.apply(this,[r,t].concat(n))},e.prototype.menuLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=this.linkIndex;i===this.state.activeLinkIndex&&(e.class=(e.class?e.class+" ":"")+"active-link",e.ref=function(e){e&&(n.activeLink=e)},this.activeLinkAction=t);var s=Object.assign({"data-link-index":i},e);return this.linkIndex+=1,a.apply(void 0,["a",s].concat(o))},e}(l),h=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.shouldComponentUpdate=function(e){return this.props.html!==e.html},t.prototype.render=function(e){return a("div",{dangerouslySetInnerHTML:{__html:e.html}})},t}(l);function p(){return a("table",{class:"keyboard-shortcuts"},a("tr",null,a("th",null,"Key"),a("th",null,"Shortcut")),a("tr",null,a("td",null,a("span",{class:"key"},"s")),a("td",null,"Open this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"esc")),a("td",null,"Close this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"↓"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"j")),a("td",null,"Move down in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↑"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"k")),a("td",null,"Move up in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↵")),a("td",null,"Go to active search result")))}function f(){return a("p",null,"You can find any exported type, constructor, class, function or pattern defined in this package by (approximate) name.")}function v(e){var t=[a("p",null,"Your search for '",e.searchString,"' produced the following list of results: ",a("code",null,"[]"),"."),a("p",null,a("code",null,"Nothing")," matches your query for '",e.searchString,"'."),a("p",null,a("code",null,"Left \"no matches for '",e.searchString,"'\" :: Either String (NonEmpty SearchResult)"))];return t[(e.searchString||"a").charCodeAt(0)%t.length]}function g(e,t){var n,o=document.getElementById("quick-jump-button");o&&s.render(a(d,{baseUrl:e||".",showHideTrigger:t||(n=o,function(e){var t=document.querySelector("#page-menu");s.render(a(c,{onClick:e,title:"Quick Jump"}),t,n)})}),document.body)}n.init=g,window.quickNav={init:g}},{"fuse.js":6,preact:7}],5:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("./cookies"),s=e("preact"),a=s.h,l=s.Component;function c(){return Array.prototype.slice.call(document.getElementsByTagName("link")).filter(function(e){return-1!=e.rel.indexOf("style")&&e.title})}function u(e){for(var t=c(),n=null,o=0;o<t.length;o++){var r=t[o];r.disabled=!0,r.title==e&&(n=r)}n?(n.disabled=!1,i.setCookie("haddock-style",e)):(t[0].disabled=!1,i.clearCookie("haddock-style"))}var d=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);var h=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.componentWillMount=function(){var t=this;document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){t.state.isVisible&&"Escape"===e.key&&t.hide()})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||this.setState({isVisible:!0})},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){var n=this;return a("div",{id:"style",class:t.isVisible?"":"hidden"},a("div",{id:"style-menu",class:"dropdown-menu",onMouseDown:function(e){e.stopPropagation()}},e.styles.map(function(t){return a("button",{type:"button",onClick:function(e){n.hide(),u(t)}},t)})))},t}(l);n.init=function(e){var t,n=c().map(function(e){return e.title});(t=i.getCookie("haddock-style"))&&u(t),s.render(a(h,{showHideTrigger:e||function(e){return function(e,t){if(1<e.length){var n=document.querySelector("#page-menu"),o=document.createElement("li");n.appendChild(o),s.render(a(d,{onClick:t,title:"Styles"}),n,o)}}(n,e)},styles:n}),document.body)}},{"./cookies":1,preact:7}],6:[function(e,t,n){var o,r;o=this,r=function(){return function(n){var o={};function r(e){if(o[e])return o[e].exports;var t=o[e]={i:e,l:!1,exports:{}};return n[e].call(t.exports,t,t.exports,r),t.l=!0,t.exports}return r.m=n,r.c=o,r.i=function(e){return e},r.d=function(e,t,n){r.o(e,t)||Object.defineProperty(e,t,{configurable:!1,enumerable:!0,get:n})},r.n=function(e){var t=e&&e.__esModule?function(){return e.default}:function(){return e};return r.d(t,"a",t),t},r.o=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},r.p="",r(r.s=8)}([function(e,t,n){"use strict";e.exports=function(e){return Array.isArray?Array.isArray(e):"[object Array]"===Object.prototype.toString.call(e)}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var u=n(5),d=n(7),_=n(4),r=function(){function y(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.isCaseSensitive,d=void 0!==u&&u,h=t.tokenSeparator,p=void 0===h?/ +/g:h,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,m=void 0===g?1:g;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,y),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:d,tokenSeparator:p,findAllMatches:v,minMatchCharLength:m},this.pattern=this.options.isCaseSensitive?e:e.toLowerCase(),this.pattern.length<=c&&(this.patternAlphabet=_(this.pattern))}return o(y,[{key:"search",value:function(e){if(this.options.isCaseSensitive||(e=e.toLowerCase()),this.pattern===e)return{isMatch:!0,score:0,matchedIndices:[[0,e.length-1]]};var t=this.options,n=t.maxPatternLength,o=t.tokenSeparator;if(this.pattern.length>n)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<c;l+=1)e(a[l],s,o);else s&&e(a,s,o);else o.push(a.toString())}else o.push(t);return o}(e,t,[])}},function(e,t,n){"use strict";e.exports=function(){for(var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:[],t=1<arguments.length&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i<s;i+=1){var a=e[i];a&&-1===o?o=i:a||-1===o||(t<=(r=i-1)-o+1&&n.push([o,r]),o=-1)}return e[i-1]&&t<=i-o&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o<n;o+=1)t[e.charAt(o)]=0;for(var r=0;r<n;r+=1)t[e.charAt(r)]|=1<<n-r-1;return t}},function(e,t,n){"use strict";var u=/[\-\[\]\/\{\}\(\)\*\+\?\.\\\^\$\|]/g;e.exports=function(e,t){var n=2<arguments.length&&void 0!==arguments[2]?arguments[2]:/ +/g,o=new RegExp(t.replace(u,"\\$&").replace(n,"|")),r=e.match(o),i=!!r,s=[];if(i)for(var a=0,l=r.length;a<l;a+=1){var c=r[a];s.push([e.indexOf(c),c.length-1])}return{score:i?.5:1,isMatch:i,matchedIndices:s}}},function(e,t,n){"use strict";e.exports=function(e,t){var n=t.errors,o=void 0===n?0:n,r=t.currentLocation,i=void 0===r?0:r,s=t.expectedLocation,a=void 0===s?0:s,l=t.distance,c=void 0===l?100:l,u=o/e.length,d=Math.abs(a-i);return c?u+d/c:d?1:u}},function(e,t,n){"use strict";var V=n(6),D=n(3);e.exports=function(e,t,n,o){for(var r=o.location,i=void 0===r?0:r,s=o.distance,a=void 0===s?100:s,l=o.threshold,c=void 0===l?.6:l,u=o.findAllMatches,d=void 0!==u&&u,h=o.minMatchCharLength,p=void 0===h?1:h,f=i,v=e.length,g=c,m=e.indexOf(t,f),y=t.length,_=[],b=0;b<v;b+=1)_[b]=0;if(-1!==m){var k=V(t,{errors:0,currentLocation:m,expectedLocation:f,distance:a});if(g=Math.min(k,g),-1!==(m=e.lastIndexOf(t,f+y))){var S=V(t,{errors:0,currentLocation:m,expectedLocation:f,distance:a});g=Math.min(S,g)}}m=-1;for(var x=[],w=1,C=y+v,L=1<<y-1,M=0;M<y;M+=1){for(var I=0,E=C;I<E;){V(t,{errors:M,currentLocation:f+E,expectedLocation:f,distance:a})<=g?I=E:C=E,E=Math.floor((C-I)/2+I)}C=E;var O=Math.max(1,f-E+1),A=d?v:Math.min(f+E,v)+y,T=Array(A+2);T[A+1]=(1<<M)-1;for(var N=A;O<=N;N-=1){var P=N-1,j=n[e.charAt(P)];if(j&&(_[P]=1),T[N]=(T[N+1]<<1|1)&j,0!==M&&(T[N]|=(x[N+1]|x[N])<<1|1|x[N+1]),T[N]&L&&(w=V(t,{errors:M,currentLocation:P,expectedLocation:f,distance:a}))<=g){if(g=w,(m=P)<=f)break;O=Math.max(1,2*f-m)}}if(g<V(t,{errors:M+1,currentLocation:f,expectedLocation:f,distance:a}))break;x=T}return{isMatch:0<=m,score:0===w?.001:w,matchedIndices:D(_,p)}}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var i=n(1),R=n(2),V=n(0),r=function(){function U(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.caseSensitive,d=void 0!==u&&u,h=t.tokenSeparator,p=void 0===h?/ +/g:h,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,m=void 0===g?1:g,y=t.id,_=void 0===y?null:y,b=t.keys,k=void 0===b?[]:b,S=t.shouldSort,x=void 0===S||S,w=t.getFn,C=void 0===w?R:w,L=t.sortFn,M=void 0===L?function(e,t){return e.score-t.score}:L,I=t.tokenize,E=void 0!==I&&I,O=t.matchAllTokens,A=void 0!==O&&O,T=t.includeMatches,N=void 0!==T&&T,P=t.includeScore,j=void 0!==P&&P,V=t.verbose,D=void 0!==V&&V;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,U),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:d,tokenSeparator:p,findAllMatches:v,minMatchCharLength:m,id:_,keys:k,includeMatches:N,includeScore:j,shouldSort:x,getFn:C,sortFn:M,verbose:D,tokenize:E,matchAllTokens:A},this.setCollection(e)}return o(U,[{key:"setCollection",value:function(e){return this.list=e}},{key:"search",value:function(e){this._log('---------\nSearch pattern: "'+e+'"');var t=this._prepareSearchers(e),n=t.tokenSearchers,o=t.fullSearcher,r=this._search(n,o),i=r.weights,s=r.results;return this._computeScore(i,s),this.options.shouldSort&&this._sort(s),this._format(s)}},{key:"_prepareSearchers",value:function(){var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o<r;o+=1)t.push(new i(n[o],this.options));return{tokenSearchers:t,fullSearcher:new i(e,this.options)}}},{key:"_search",value:function(){var e=0<arguments.length&&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;i<s;i+=1)this._analyze({key:"",value:n[i],record:i,index:i},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t});return{weights:null,results:r}}for(var a={},l=0,c=n.length;l<c;l+=1)for(var u=n[l],d=0,h=this.options.keys.length;d<h;d+=1){var p=this.options.keys[d];if("string"!=typeof p){if(a[p.name]={weight:1-p.weight||1},p.weight<=0||1<p.weight)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,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;S+=1){var x=c[S];this._log('\nPattern: "'+x.pattern+'"');for(var w=!1,C=0;C<b.length;C+=1){var L=b[C],M=x.search(L),I={};M.isMatch?(I[L]=M.score,w=g=!0,k.push(M.score)):(I[L]=1,this.options.matchAllTokens||k.push(1)),this._log('Token: "'+L+'", score: '+I[L])}w&&(y+=1)}m=k[0];for(var E=k.length,O=1;O<E;O+=1)m+=k[O];m/=E,this._log("Token score average:",m)}var A=_.score;-1<m&&(A=(A+m)/2),this._log("Score average:",A);var T=!this.options.tokenize||!this.options.matchAllTokens||y>=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<j;P+=1)this._analyze({key:n,arrayIndex:P,value:i[P],record:s,index:a},{resultMap:p,results:v,tokenSearchers:c,fullSearcher:d})}}},{key:"_computeScore",value:function(e,t){this._log("\n\nComputing score:\n");for(var n=0,o=t.length;n<o;n+=1){for(var r=t[n].output,i=r.length,s=1,a=1,l=0;l<i;l+=1){var c=e?e[r[l].key].weight:1,u=(1===c?r[l].score:r[l].score||.001)*c;1!==c?a=Math.min(a,u):s*=r[l].nScore=u}t[n].score=1===a?s:a,this._log(t[n])}}},{key:"_sort",value:function(e){this._log("\n\nSorting...."),e.sort(this.options.sortFn)}},{key:"_format",value:function(e){var t=[];this.options.verbose&&this._log("\n\nOutput:\n\n",JSON.stringify(e));var n=[];this.options.includeMatches&&n.push(function(e,t){var n=e.output;t.matches=[];for(var o=0,r=n.length;o<r;o+=1){var i=n[o];if(0!==i.matchedIndices.length){var s={indices:i.matchedIndices,value:i.value};i.key&&(s.key=i.key),i.hasOwnProperty("arrayIndex")&&-1<i.arrayIndex&&(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;o<r;o+=1){var i=e[o];if(this.options.id&&(i.item=this.options.getFn(i.item,this.options.id)[0]),n.length){for(var s={item:i.item},a=0,l=n.length;a<l;a+=1)n[a](i,s);t.push(s)}else t.push(i.item)}return t}},{key:"_log",value:function(){var e;this.options.verbose&&(e=console).log.apply(e,arguments)}}]),U}();e.exports=r}])},"object"==typeof n&&"object"==typeof t?t.exports=r():"function"==typeof define&&define.amd?define("Fuse",[],r):"object"==typeof n?n.Fuse=r():o.Fuse=r()},{}],7:[function(e,y,t){!function(){"use strict";function n(e,t){var n,o,r,i,s=d;for(i=arguments.length;2<i--;)u.push(arguments[i]);for(t&&null!=t.children&&(u.length||u.push(t.children),delete t.children);u.length;)if((o=u.pop())&&void 0!==o.pop)for(i=o.length;i--;)u.push(o[i]);else"boolean"==typeof o&&(o=null),(r="function"!=typeof e)&&(null==o?o="":"number"==typeof o?o=String(o):"string"!=typeof o&&(r=!1)),r&&n?s[s.length-1]+=o:s===d?s=[o]:s.push(o),n=r;var a=new c;return a.nodeName=e,a.children=s,a.attributes=null==t?void 0:t,a.key=null==t?void 0:t.key,void 0!==D.vnode&&D.vnode(a),a}function L(e,t){for(var n in t)e[n]=t[n];return e}function i(e){!e.__d&&(e.__d=!0)&&1==p.push(e)&&(D.debounceRendering||r)(t)}function t(){var e,t=p;for(p=[];e=t.pop();)e.__d&&j(e)}function C(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function M(e){var t=L({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var o in n)void 0===t[o]&&(t[o]=n[o]);return t}function I(e){var t=e.parentNode;t&&t.removeChild(e)}function v(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===h.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,l,s):e.removeEventListener(t,l,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e){try{e[t]=null==o?"":o}catch(e){}null!=o&&!1!==o||"spellcheck"==t||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 l(e){return this.__l[e.type](D.event&&D.event(e)||e)}function E(){for(var e;e=U.pop();)D.afterMount&&D.afterMount(e),e.componentDidMount&&e.componentDidMount()}function O(e,t,n,o,r,i){R++||(g=null!=r&&void 0!==r.ownerSVGElement,m=null!=e&&!("__preactattr_"in e));var s=A(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(m=!1,i||E()),s}function A(e,t,n,o,r){var i=e,s=g;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),T(e,!0))),i.__preactattr_=!0,i;var a,l,c=t.nodeName;if("function"==typeof c)return function(e,t,n,o){var r=e&&e._component,i=r,s=e,a=r&&e._componentConstructor===t.nodeName,l=a,c=M(t);for(;r&&!l&&(r=r.__u);)l=r.constructor===t.nodeName;r&&l&&(!o||r._component)?(P(r,c,3,n,o),e=r.base):(i&&!a&&(V(i),e=s=null),r=N(t.nodeName,c,n),e&&!r.__b&&(r.__b=e,s=null),P(r,c,1,n,o),e=r.base,s&&e!==s&&(s._component=null,T(s,!1)));return e}(e,t,n,o);if(g="svg"===c||"foreignObject"!==c&&g,c=String(c),(!e||!C(e,c))&&(a=c,(l=g?document.createElementNS("http://www.w3.org/2000/svg",a):document.createElement(a)).__n=a,i=l,e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),T(e,!0)}var u=i.firstChild,d=i.__preactattr_,h=t.children;if(null==d){d=i.__preactattr_={};for(var p=i.attributes,f=p.length;f--;)d[p[f].name]=p[f].value}return!m&&h&&1===h.length&&"string"==typeof h[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=h[0]&&(u.nodeValue=h[0]):(h&&h.length||null!=u)&&function(e,t,n,o,r){var i,s,a,l,c,u=e.childNodes,d=[],h={},p=0,f=0,v=u.length,g=0,m=t?t.length:0;if(0!==v)for(var y=0;y<v;y++){var _=u[y],b=_.__preactattr_,k=m&&b?_._component?_._component.__k:b.key:null;null!=k?(p++,h[k]=_):(b||(void 0!==_.splitText?!r||_.nodeValue.trim():r))&&(d[g++]=_)}if(0!==m)for(var y=0;y<m;y++){l=t[y],c=null;var k=l.key;if(null!=k)p&&void 0!==h[k]&&(c=h[k],h[k]=void 0,p--);else if(f<g)for(i=f;i<g;i++)if(void 0!==d[i]&&(S=s=d[i],w=r,"string"==typeof(x=l)||"number"==typeof x?void 0!==S.splitText:"string"==typeof x.nodeName?!S._componentConstructor&&C(S,x.nodeName):w||S._componentConstructor===x.nodeName)){c=s,d[i]=void 0,i===g-1&&g--,i===f&&f++;break}c=A(c,l,n,o),a=u[y],c&&c!==e&&c!==a&&(null==a?e.appendChild(c):c===a.nextSibling?I(a):e.insertBefore(c,a))}var S,x,w;if(p)for(var y in h)void 0!==h[y]&&T(h[y],!1);for(;f<=g;)void 0!==(c=d[g--])&&T(c,!1)}(i,h,n,o,m||null!=d.dangerouslySetInnerHTML),function(e,t,n){var o;for(o in n)t&&null!=t[o]||null==n[o]||v(e,o,n[o],n[o]=void 0,g);for(o in t)"children"===o||"innerHTML"===o||o in n&&t[o]===("value"===o||"checked"===o?e[o]:n[o])||v(e,o,n[o],n[o]=t[o],g)}(i,t.attributes,d),g=s,i}function T(e,t){var n=e._component;n?V(n):(null!=e.__preactattr_&&e.__preactattr_.ref&&e.__preactattr_.ref(null),!1!==t&&null!=e.__preactattr_||I(e),o(e))}function o(e){for(e=e.lastChild;e;){var t=e.previousSibling;T(e,!0),e=t}}function N(e,t,n){var o,r=f.length;for(e.prototype&&e.prototype.render?(o=new e(t,n),a.call(o,t,n)):((o=new a(t,n)).constructor=e,o.render=s);r--;)if(f[r].constructor===e)return o.__b=f[r].__b,f.splice(r,1),o;return o}function s(e,t,n){return this.constructor(e,n)}function P(e,t,n,o,r){e.__x||(e.__x=!0,e.__r=t.ref,e.__k=t.key,delete t.ref,delete t.key,void 0===e.constructor.getDerivedStateFromProps&&(!e.base||r?e.componentWillMount&&e.componentWillMount():e.componentWillReceiveProps&&e.componentWillReceiveProps(t,o)),o&&o!==e.context&&(e.__c||(e.__c=e.context),e.context=o),e.__p||(e.__p=e.props),e.props=t,e.__x=!1,0!==n&&(1!==n&&!1===D.syncComponentUpdates&&e.base?i(e):j(e,1,r)),e.__r&&e.__r(e))}function j(e,t,n,o){if(!e.__x){var r,i,s,a=e.props,l=e.state,c=e.context,u=e.__p||a,d=e.__s||l,h=e.__c||c,p=e.base,f=e.__b,v=p||f,g=e._component,m=!1,y=h;if(e.constructor.getDerivedStateFromProps&&(l=L(L({},l),e.constructor.getDerivedStateFromProps(a,l)),e.state=l),p&&(e.props=u,e.state=d,e.context=h,2!==t&&e.shouldComponentUpdate&&!1===e.shouldComponentUpdate(a,l,c)?m=!0:e.componentWillUpdate&&e.componentWillUpdate(a,l,c),e.props=a,e.state=l,e.context=c),e.__p=e.__s=e.__c=e.__b=null,e.__d=!1,!m){r=e.render(a,l,c),e.getChildContext&&(c=L(L({},c),e.getChildContext())),p&&e.getSnapshotBeforeUpdate&&(y=e.getSnapshotBeforeUpdate(u,d));var _,b,k=r&&r.nodeName;if("function"==typeof k){var S=M(r);(i=g)&&i.constructor===k&&S.key==i.__k?P(i,S,1,c,!1):(_=i,e._component=i=N(k,S,c),i.__b=i.__b||f,i.__u=e,P(i,S,0,c,!1),j(i,1,n,!0)),b=i.base}else s=v,(_=g)&&(s=e._component=null),(v||1===t)&&(s&&(s._component=null),b=O(s,r,c,n||!p,v&&v.parentNode,!0));if(v&&b!==v&&i!==g){var x=v.parentNode;x&&b!==x&&(x.replaceChild(b,v),_||(v._component=null,T(v,!1)))}if(_&&V(_),(e.base=b)&&!o){for(var w=e,C=e;C=C.__u;)(w=C).base=b;b._component=w,b._componentConstructor=w.constructor}}for(!p||n?U.unshift(e):m||(e.componentDidUpdate&&e.componentDidUpdate(u,d,y),D.afterUpdate&&D.afterUpdate(e));e.__h.length;)e.__h.pop().call(e);R||o||E()}}function V(e){D.beforeUnmount&&D.beforeUnmount(e);var t=e.base;e.__x=!0,e.componentWillUnmount&&e.componentWillUnmount(),e.base=null;var n=e._component;n?V(n):t&&(t.__preactattr_&&t.__preactattr_.ref&&t.__preactattr_.ref(null),I(e.__b=t),f.push(e),o(t)),e.__r&&e.__r(null)}function a(e,t){this.__d=!0,this.context=t,this.props=e,this.state=this.state||{},this.__h=[]}var c=function(){},D={},u=[],d=[],r="function"==typeof Promise?Promise.resolve().then.bind(Promise.resolve()):setTimeout,h=/acit|ex(?:s|g|n|p|$)|rph|ows|mnc|ntw|ine[ch]|zoo|^ord/i,p=[],U=[],R=0,g=!1,m=!1,f=[];L(a.prototype,{setState:function(e,t){this.__s||(this.__s=this.state),this.state=L(L({},this.state),"function"==typeof e?e(this.state,this.props):e),t&&this.__h.push(t),i(this)},forceUpdate:function(e){e&&this.__h.push(e),j(this,2)},render:function(){}});var e={h:n,createElement:n,cloneElement:function(e,t){return n(e.nodeName,L(L({},e.attributes),t),2<arguments.length?[].slice.call(arguments,2):e.children)},Component:a,render:function(e,t,n){return O(n,e,{},!1,t,!1)},rerender:t,options:D};void 0!==y?y.exports=e:self.preact=e}()},{}]},{},[3]);+//# sourceMappingURL=haddock-bundle.min.js.map
− resources/html/haddock-util.js 
@@ -1,316 +0,0 @@-// Haddock JavaScript utilities--var rspace = /\s\s+/g,-	  rtrim = /^\s+|\s+$/g;--function spaced(s) { return (" " + s + " ").replace(rspace, " "); }-function trim(s)   { return s.replace(rtrim, ""); }--function hasClass(elem, value) {-  var className = spaced(elem.className || "");-  return className.indexOf( " " + value + " " ) >= 0;-}--function addClass(elem, value) {-  var className = spaced(elem.className || "");-  if ( className.indexOf( " " + value + " " ) < 0 ) {-    elem.className = trim(className + " " + value);-  }-}--function removeClass(elem, value) {-  var className = spaced(elem.className || "");-  className = className.replace(" " + value + " ", " ");-  elem.className = trim(className);-}--function toggleClass(elem, valueOn, valueOff, bool) {-  if (bool == null) { bool = ! hasClass(elem, valueOn); }-  if (bool) {-    removeClass(elem, valueOff);-    addClass(elem, valueOn);-  }-  else {-    removeClass(elem, valueOn);-    addClass(elem, valueOff);-  }-  return bool;-}---function makeClassToggle(valueOn, valueOff)-{-  return function(elem, bool) {-    return toggleClass(elem, valueOn, valueOff, bool);-  }-}--toggleShow = makeClassToggle("show", "hide");-toggleCollapser = makeClassToggle("collapser", "expander");--function toggleSection(id)-{-  var b = toggleShow(document.getElementById("section." + id));-  toggleCollapser(document.getElementById("control." + id), b);-  rememberCollapsed(id, b);-  return b;-}--var collapsed = {};-function rememberCollapsed(id, b)-{-  if(b)-    delete collapsed[id]-  else-    collapsed[id] = null;--  var sections = [];-  for(var i in collapsed)-  {-    if(collapsed.hasOwnProperty(i))-      sections.push(i);-  }-  // cookie specific to this page; don't use setCookie which sets path=/-  document.cookie = "collapsed=" + escape(sections.join('+'));-}--function restoreCollapsed()-{-  var cookie = getCookie("collapsed");-  if(!cookie)-    return;--  var ids = cookie.split('+');-  for(var i in ids)-  {-    if(document.getElementById("section." + ids[i]))-      toggleSection(ids[i]);-  }-}--function setCookie(name, value) {-  document.cookie = name + "=" + escape(value) + ";path=/;";-}--function clearCookie(name) {-  document.cookie = name + "=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;";-}--function getCookie(name) {-  var nameEQ = name + "=";-  var ca = document.cookie.split(';');-  for(var i=0;i < ca.length;i++) {-    var c = ca[i];-    while (c.charAt(0)==' ') c = c.substring(1,c.length);-    if (c.indexOf(nameEQ) == 0) {-      return unescape(c.substring(nameEQ.length,c.length));-    }-  }-  return null;-}----var max_results = 75; // 50 is not enough to search for map in the base libraries-var shown_range = null;-var last_search = null;--function quick_search()-{-    perform_search(false);-}--function full_search()-{-    perform_search(true);-}---function perform_search(full)-{-    var text = document.getElementById("searchbox").value.toLowerCase();-    if (text == last_search && !full) return;-    last_search = text;--    var table = document.getElementById("indexlist");-    var status = document.getElementById("searchmsg");-    var children = table.firstChild.childNodes;--    // first figure out the first node with the prefix-    var first = bisect(-1);-    var last = (first == -1 ? -1 : bisect(1));--    if (first == -1)-    {-        table.className = "";-        status.innerHTML = "No results found, displaying all";-    }-    else if (first == 0 && last == children.length - 1)-    {-        table.className = "";-        status.innerHTML = "";-    }-    else if (last - first >= max_results && !full)-    {-        table.className = "";-        status.innerHTML = "More than " + max_results + ", press Search to display";-    }-    else-    {-        // decide what you need to clear/show-        if (shown_range)-            setclass(shown_range[0], shown_range[1], "indexrow");-        setclass(first, last, "indexshow");-        shown_range = [first, last];-        table.className = "indexsearch";-        status.innerHTML = "";-    }---    function setclass(first, last, status)-    {-        for (var i = first; i <= last; i++)-        {-            children[i].className = status;-        }-    }---    // do a binary search, treating 0 as ...-    // return either -1 (no 0's found) or location of most far match-    function bisect(dir)-    {-        var first = 0, finish = children.length - 1;-        var mid, success = false;--        while (finish - first > 3)-        {-            mid = Math.floor((finish + first) / 2);--            var i = checkitem(mid);-            if (i == 0) i = dir;-            if (i == -1)-                finish = mid;-            else-                first = mid;-        }-        var a = (dir == 1 ? first : finish);-        var b = (dir == 1 ? finish : first);-        for (var i = b; i != a - dir; i -= dir)-        {-            if (checkitem(i) == 0) return i;-        }-        return -1;-    }---    // from an index, decide what the result is-    // 0 = match, -1 is lower, 1 is higher-    function checkitem(i)-    {-        var s = getitem(i).toLowerCase().substr(0, text.length);-        if (s == text) return 0;-        else return (s > text ? -1 : 1);-    }---    // from an index, get its string-    // this abstracts over alternates-    function getitem(i)-    {-        for ( ; i >= 0; i--)-        {-            var s = children[i].firstChild.firstChild.data;-            if (s.indexOf(' ') == -1)-                return s;-        }-        return ""; // should never be reached-    }-}--function setSynopsis(filename) {-    if (parent.window.synopsis && parent.window.synopsis.location) {-        if (parent.window.synopsis.location.replace) {-            // In Firefox this avoids adding the change to the history.-            parent.window.synopsis.location.replace(filename);-        } else {-            parent.window.synopsis.location = filename;-        }-    }-}--function addMenuItem(html) {-  var menu = document.getElementById("page-menu");-  if (menu) {-    var btn = menu.firstChild.cloneNode(false);-    btn.innerHTML = html;-    menu.appendChild(btn);-  }-}--function styles() {-  var i, a, es = document.getElementsByTagName("link"), rs = [];-  for (i = 0; a = es[i]; i++) {-    if(a.rel.indexOf("style") != -1 && a.title) {-      rs.push(a);-    }-  }-  return rs;-}--function addStyleMenu() {-  var as = styles();-  var i, a, btns = "";-  for(i=0; a = as[i]; i++) {-    btns += "<li><a href='#' onclick=\"setActiveStyleSheet('"-      + a.title + "'); return false;\">"-      + a.title + "</a></li>"-  }-  if (as.length > 1) {-    var h = "<div id='style-menu-holder'>"-      + "<a href='#' onclick='styleMenu(); return false;'>Style &#9662;</a>"-      + "<ul id='style-menu' class='hide'>" + btns + "</ul>"-      + "</div>";-    addMenuItem(h);-  }-}--function setActiveStyleSheet(title) {-  var as = styles();-  var i, a, found;-  for(i=0; a = as[i]; i++) {-    a.disabled = true;-          // need to do this always, some browsers are edge triggered-    if(a.title == title) {-      found = a;-    }-  }-  if (found) {-    found.disabled = false;-    setCookie("haddock-style", title);-  }-  else {-    as[0].disabled = false;-    clearCookie("haddock-style");-  }-  styleMenu(false);-}--function resetStyle() {-  var s = getCookie("haddock-style");-  if (s) setActiveStyleSheet(s);-}---function styleMenu(show) {-  var m = document.getElementById('style-menu');-  if (m) toggleShow(m, show);-}---function pageLoad() {-  addStyleMenu();-  resetStyle();-  restoreCollapsed();-}-
+ resources/html/quick-jump.css view
@@ -0,0 +1,221 @@+/* @group Fundamentals */++.hidden {+  display: none;+}++/* @end */++/* @group Search box layout */++#search {+  position: fixed;+  top: 3.2em;+  bottom: 0;+  left: calc(50% - 22em);+  width: 44em;+  z-index: 1000;+  overflow-y: auto;+}++@media only screen and (max-width: 999px) {+  #search {+    top: 5.7em;+  }+}++#search-form, #search-results {+  box-shadow: 2px 2px 6px rgb(199, 204, 208);+  pointer-events: all;+}++#search-form input {+  font-size: 1.25em; line-height: 2.3em; height: 2.4em;+  display: block;+  box-sizing: border-box;+  width: 100%;+  margin: 0;+  padding: 0 0.75em;+  border: 0.05em solid rgb(151, 179, 202);+}++#search input:focus {+  outline: none;+}++#search p.error {+  color: rgb(107, 24, 24);+  font-weight: bold;+}++#search-results {+  box-sizing: border-box;+  border: 0.05em solid #b2d5fb;+  background: #e8f3ff;+  max-height: 80%;+  overflow: scroll;+}++#search-form input + #search-results {+  border-top: none;+  top: 3em;+  max-height: calc(100% - 3em);+}++/* @end */++/* @group search results */++#search-results > ul {+  margin: 0;+  list-style: none;+}++#search-results > ul > li,+#search-results > p,+#search-results > table {+  padding: 0.5em 1em;+  margin: 0;+}++#search-results > ul > li {+  border-bottom: 1px solid #b2d5fb;+}++#search-results > ul > li > ul {+  list-style: none;+}++.search-module h4 {+  margin: 0;+}++.search-module > ul {+  margin: 0.5em 0 0.5em 2em;+}++.search-module > ul > li > a[href] {+  display: block;+  color: inherit;+  padding: 0.25em 0.5em;+}++.search-module > ul > li > a[href].active-link {+  background: #faf9dc;+}++.search-module a[href]:hover {+  text-decoration: none;+}++.search-result a a {+  pointer-events: none;+}++.search-result ul.subs {+  display: inline-block;+  margin: 0; padding: 0;+}++.search-result ul.subs li {+  display: none;+}++.search-result ul.subs::after {+  display: inline-block;+  content: "...";+  color: rgb(78,98,114);+  margin: 0 0.25em;+}++.more-results {+  color: rgb(99, 141, 173);+  position: relative;+}++.more-results::before {+  content: "+";+  display: inline-block;+  color: #b2d5fb;+  font-weight: bold;+  font-size: 1.25em; line-height: inherit;+  position: absolute;+  left: -1em;+}++/* @end */++/* @group Keyboard shortcuts table */++.keyboard-shortcuts {+  line-height: 1.6em;+}++.keyboard-shortcuts th {+  color: rgb(78,98,114);+}++.keyboard-shortcuts td:first-child,+.keyboard-shortcuts th:first-child {+  text-align: right;+  padding-right: 0.6em;+}++.key {+  display: inline-block;+  font-size: 0.9em;+  min-width: 0.8em; line-height: 1.2em;+  text-align: center;+  background: #b2d5fb;+  border: 1px solid #74a3d6;+  padding: 0 0.2em;+  margin: 0 0.1em;+}++/* @end */++/* @group Dropdown menus */++/* Based on #search styling above. */++.dropdown-menu {+  position: fixed;+  /* Not robust to window size changes. */+  top: 3.2em;+  right: 0;+  /* To display on top of synopsis menu on right side. */+  z-index: 1000;+  border: 0.05em solid #b2d5fb;+  background: #e8f3ff;+}++@media only screen and (max-width: 999px) {+  .dropdown-menu {+    top: 5.7em;+  }+}++.dropdown-menu * {+  margin: 0.1em;+}++.dropdown-menu button {+  border: 1px #5E5184 solid;+  border-radius: 3px;+  background: #5E5184;+  padding: 3px;+  color: #f4f4f4;+  min-width: 6em;+}++.dropdown-menu button:hover {+  color: #5E5184;+  background: #f4f4f4;+}++.dropdown-menu button:active {+  color: #f4f4f4;+  background: #5E5184;+}++/* @end */
+ resources/html/quick-jump.min.js view
@@ -0,0 +1,2 @@+!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e<l.length;e++)c(l[e]);return c}({1:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("fuse.js"),s=e("preact"),a=s.h,l=s.Component;var c=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);function u(e,t){return t.length<=e?t:t.slice(0,e)}var h=function(t){function e(){var e=null!==t&&t.apply(this,arguments)||this;return e.linkIndex=0,e.focusPlease=!1,e.navigatedByKeyboard=!1,e}return r(e,t),e.prototype.componentWillMount=function(){var e,t,n,o,r=this;this.setState({searchString:"",isVisible:!1,expanded:{},activeLinkIndex:-1,moduleResults:[]}),e=this.props.baseUrl+"/doc-index.json",t=function(e){r.setState({fuse:new i(e,{threshold:.25,caseSensitive:!0,includeScore:!0,tokenize:!0,keys:[{name:"name",weight:.7},{name:"module",weight:.3}]}),moduleResults:[]})},n=function(e){console&&console.error("could not load 'doc-index.json' for searching",e),r.setState({failedLoading:!0})},(o=new XMLHttpRequest).onreadystatechange=function(){if(o.readyState===XMLHttpRequest.DONE)if(200===o.status){if(t)try{t(JSON.parse(o.responseText))}catch(e){n(o)}}else n&&n(o)},o.open("GET",e,!0),o.send(),document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){r.state.isVisible&&("Escape"===e.key?r.hide():"ArrowUp"===e.key||"k"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(-1)):"ArrowDown"===e.key||"j"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(1)):"Enter"===e.key&&0<=r.state.activeLinkIndex&&r.followActiveLink()),"s"===e.key&&"input"!==e.target.tagName.toLowerCase()&&(e.preventDefault(),r.show())})},e.prototype.hide=function(){this.setState({isVisible:!1,searchString:""})},e.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},e.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},e.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})},e.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},e.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t=this.state.fuse.search(e),o={};t.forEach(function(e){var t=e.item.module;(o[t]||(o[t]=[])).push(e)});var r=[],n=function(e){var t=o[e],n=0;t.forEach(function(e){n+=1/e.score}),r.push({module:e,totalScore:1/n,items:t})};for(var i in o)n(i);r.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:r})},e.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<t&&(this.searchResults.scrollTop-=t-e.top+80)}this.focusPlease&&this.input&&this.input.focus(),this.navigatedByKeyboard=!1,this.focusPlease=!1},e.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},e.prototype.render=function(e,t){var r=this;if(t.failedLoading){var n="file:"==window.location.protocol;return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-results"},a("p",{class:"error"},"Failed to load file 'doc-index.json' containing definitions in this package."),n?a("p",{class:"error"},"To use quick jump, load this page with HTTP (from a local static file web server) instead of using the ",a("code",null,"file://")," protocol. (For security reasons, it is not possible to fetch auxiliary files using JS in a HTML page opened with ",a("code",null,"file://"),".)"):[]))}this.linkIndex=0;var o=function(e){e.stopPropagation()},i=u(10,t.moduleResults).map(function(e){return r.renderResultsInModule(e)});return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-form",onMouseDown:o},a("input",{placeholder:"Search in package by name",ref:function(e){r.input=e},onFocus:this.show.bind(this),onClick:this.show.bind(this),onInput:this.updateResults.bind(this)})),a("div",{id:"search-results",ref:function(e){r.searchResults=e},onMouseDown:o,onMouseOver:function(e){for(var t=e.target;t&&"function"==typeof t.getAttribute;){var n=t.getAttribute("data-link-index");if("string"==typeof n){var o=parseInt(n,10);r.setState({activeLinkIndex:o});break}t=t.parentNode}}},""===t.searchString?[a(f,null),a(d,null)]:0==i.length?a(v,{searchString:t.searchString}):a("ul",null,i)))},e.prototype.renderResultsInModule=function(e){var n=this,t=e.items,o=e.module,r=this.state.expanded[o]||t.length<=10,i=r?t:u(8,t);return a("li",{class:"search-module"},a("h4",null,o),a("ul",null,i.map(function(e){return t=e.item,a("li",{class:"search-result"},n.navigationLink(n.props.baseUrl+"/"+t.link,{},a(p,{html:t.display_html})));var t}),r?[]:a("li",{class:"more-results"},this.actionLink(function(){var e=Object.assign({},n.state.expanded);e[o]=!0,n.setState({expanded:e})},{},"show "+(t.length-i.length)+" more results from this module"))))},e.prototype.navigationLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=Object.assign({href:e,onClick:this.hide.bind(this)},t);return this.menuLink.apply(this,[i,function(){window.location.href=e,n.hide()}].concat(o))},e.prototype.actionLink=function(t,e){for(var n=[],o=2;o<arguments.length;o++)n[o-2]=arguments[o];var r=Object.assign({href:"#",onClick:function(e){e.preventDefault(),t()}},e);return this.menuLink.apply(this,[r,t].concat(n))},e.prototype.menuLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=this.linkIndex;i===this.state.activeLinkIndex&&(e.class=(e.class?e.class+" ":"")+"active-link",e.ref=function(e){e&&(n.activeLink=e)},this.activeLinkAction=t);var s=Object.assign({"data-link-index":i},e);return this.linkIndex+=1,a.apply(void 0,["a",s].concat(o))},e}(l),p=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.shouldComponentUpdate=function(e){return this.props.html!==e.html},t.prototype.render=function(e){return a("div",{dangerouslySetInnerHTML:{__html:e.html}})},t}(l);function d(){return a("table",{class:"keyboard-shortcuts"},a("tr",null,a("th",null,"Key"),a("th",null,"Shortcut")),a("tr",null,a("td",null,a("span",{class:"key"},"s")),a("td",null,"Open this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"esc")),a("td",null,"Close this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"↓"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"j")),a("td",null,"Move down in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↑"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"k")),a("td",null,"Move up in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↵")),a("td",null,"Go to active search result")))}function f(){return a("p",null,"You can find any exported type, constructor, class, function or pattern defined in this package by (approximate) name.")}function v(e){var t=[a("p",null,"Your search for '",e.searchString,"' produced the following list of results: ",a("code",null,"[]"),"."),a("p",null,a("code",null,"Nothing")," matches your query for '",e.searchString,"'."),a("p",null,a("code",null,"Left \"no matches for '",e.searchString,"'\" :: Either String (NonEmpty SearchResult)"))];return t[(e.searchString||"a").charCodeAt(0)%t.length]}function g(e,t){var n,o=document.getElementById("quick-jump-button");o&&s.render(a(h,{baseUrl:e||".",showHideTrigger:t||(n=o,function(e){var t=document.querySelector("#page-menu");s.render(a(c,{onClick:e,title:"Quick Jump"}),t,n)})}),document.body)}n.init=g,window.quickNav={init:g}},{"fuse.js":2,preact:3}],2:[function(e,t,n){var o,r;o=this,r=function(){return function(n){var o={};function r(e){if(o[e])return o[e].exports;var t=o[e]={i:e,l:!1,exports:{}};return n[e].call(t.exports,t,t.exports,r),t.l=!0,t.exports}return r.m=n,r.c=o,r.i=function(e){return e},r.d=function(e,t,n){r.o(e,t)||Object.defineProperty(e,t,{configurable:!1,enumerable:!0,get:n})},r.n=function(e){var t=e&&e.__esModule?function(){return e.default}:function(){return e};return r.d(t,"a",t),t},r.o=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},r.p="",r(r.s=8)}([function(e,t,n){"use strict";e.exports=function(e){return Array.isArray?Array.isArray(e):"[object Array]"===Object.prototype.toString.call(e)}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var u=n(5),h=n(7),y=n(4),r=function(){function m(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.isCaseSensitive,h=void 0!==u&&u,p=t.tokenSeparator,d=void 0===p?/ +/g:p,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,_=void 0===g?1:g;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,m),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:h,tokenSeparator:d,findAllMatches:v,minMatchCharLength:_},this.pattern=this.options.isCaseSensitive?e:e.toLowerCase(),this.pattern.length<=c&&(this.patternAlphabet=y(this.pattern))}return o(m,[{key:"search",value:function(e){if(this.options.isCaseSensitive||(e=e.toLowerCase()),this.pattern===e)return{isMatch:!0,score:0,matchedIndices:[[0,e.length-1]]};var t=this.options,n=t.maxPatternLength,o=t.tokenSeparator;if(this.pattern.length>n)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<c;l+=1)e(a[l],s,o);else s&&e(a,s,o);else o.push(a.toString())}else o.push(t);return o}(e,t,[])}},function(e,t,n){"use strict";e.exports=function(){for(var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:[],t=1<arguments.length&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i<s;i+=1){var a=e[i];a&&-1===o?o=i:a||-1===o||(t<=(r=i-1)-o+1&&n.push([o,r]),o=-1)}return e[i-1]&&t<=i-o&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o<n;o+=1)t[e.charAt(o)]=0;for(var r=0;r<n;r+=1)t[e.charAt(r)]|=1<<n-r-1;return t}},function(e,t,n){"use strict";var u=/[\-\[\]\/\{\}\(\)\*\+\?\.\\\^\$\|]/g;e.exports=function(e,t){var n=2<arguments.length&&void 0!==arguments[2]?arguments[2]:/ +/g,o=new RegExp(t.replace(u,"\\$&").replace(n,"|")),r=e.match(o),i=!!r,s=[];if(i)for(var a=0,l=r.length;a<l;a+=1){var c=r[a];s.push([e.indexOf(c),c.length-1])}return{score:i?.5:1,isMatch:i,matchedIndices:s}}},function(e,t,n){"use strict";e.exports=function(e,t){var n=t.errors,o=void 0===n?0:n,r=t.currentLocation,i=void 0===r?0:r,s=t.expectedLocation,a=void 0===s?0:s,l=t.distance,c=void 0===l?100:l,u=o/e.length,h=Math.abs(a-i);return c?u+h/c:h?1:u}},function(e,t,n){"use strict";var U=n(6),R=n(3);e.exports=function(e,t,n,o){for(var r=o.location,i=void 0===r?0:r,s=o.distance,a=void 0===s?100:s,l=o.threshold,c=void 0===l?.6:l,u=o.findAllMatches,h=void 0!==u&&u,p=o.minMatchCharLength,d=void 0===p?1:p,f=i,v=e.length,g=c,_=e.indexOf(t,f),m=t.length,y=[],k=0;k<v;k+=1)y[k]=0;if(-1!==_){var b=U(t,{errors:0,currentLocation:_,expectedLocation:f,distance:a});if(g=Math.min(b,g),-1!==(_=e.lastIndexOf(t,f+m))){var x=U(t,{errors:0,currentLocation:_,expectedLocation:f,distance:a});g=Math.min(x,g)}}_=-1;for(var S=[],w=1,L=m+v,C=1<<m-1,M=0;M<m;M+=1){for(var A=0,I=L;A<I;){U(t,{errors:M,currentLocation:f+I,expectedLocation:f,distance:a})<=g?A=I:L=I,I=Math.floor((L-A)/2+A)}L=I;var N=Math.max(1,f-I+1),T=h?v:Math.min(f+I,v)+m,O=Array(T+2);O[T+1]=(1<<M)-1;for(var P=T;N<=P;P-=1){var j=P-1,E=n[e.charAt(j)];if(E&&(y[j]=1),O[P]=(O[P+1]<<1|1)&E,0!==M&&(O[P]|=(S[P+1]|S[P])<<1|1|S[P+1]),O[P]&C&&(w=U(t,{errors:M,currentLocation:j,expectedLocation:f,distance:a}))<=g){if(g=w,(_=j)<=f)break;N=Math.max(1,2*f-_)}}if(g<U(t,{errors:M+1,currentLocation:f,expectedLocation:f,distance:a}))break;S=O}return{isMatch:0<=_,score:0===w?.001:w,matchedIndices:R(y,d)}}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var i=n(1),F=n(2),U=n(0),r=function(){function D(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.caseSensitive,h=void 0!==u&&u,p=t.tokenSeparator,d=void 0===p?/ +/g:p,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,_=void 0===g?1:g,m=t.id,y=void 0===m?null:m,k=t.keys,b=void 0===k?[]:k,x=t.shouldSort,S=void 0===x||x,w=t.getFn,L=void 0===w?F:w,C=t.sortFn,M=void 0===C?function(e,t){return e.score-t.score}:C,A=t.tokenize,I=void 0!==A&&A,N=t.matchAllTokens,T=void 0!==N&&N,O=t.includeMatches,P=void 0!==O&&O,j=t.includeScore,E=void 0!==j&&j,U=t.verbose,R=void 0!==U&&U;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,D),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:h,tokenSeparator:d,findAllMatches:v,minMatchCharLength:_,id:y,keys:b,includeMatches:P,includeScore:E,shouldSort:S,getFn:L,sortFn:M,verbose:R,tokenize:I,matchAllTokens:T},this.setCollection(e)}return o(D,[{key:"setCollection",value:function(e){return this.list=e}},{key:"search",value:function(e){this._log('---------\nSearch pattern: "'+e+'"');var t=this._prepareSearchers(e),n=t.tokenSearchers,o=t.fullSearcher,r=this._search(n,o),i=r.weights,s=r.results;return this._computeScore(i,s),this.options.shouldSort&&this._sort(s),this._format(s)}},{key:"_prepareSearchers",value:function(){var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o<r;o+=1)t.push(new i(n[o],this.options));return{tokenSearchers:t,fullSearcher:new i(e,this.options)}}},{key:"_search",value:function(){var e=0<arguments.length&&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;i<s;i+=1)this._analyze({key:"",value:n[i],record:i,index:i},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t});return{weights:null,results:r}}for(var a={},l=0,c=n.length;l<c;l+=1)for(var u=n[l],h=0,p=this.options.keys.length;h<p;h+=1){var d=this.options.keys[h];if("string"!=typeof d){if(a[d.name]={weight:1-d.weight||1},d.weight<=0||1<d.weight)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,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;x+=1){var S=c[x];this._log('\nPattern: "'+S.pattern+'"');for(var w=!1,L=0;L<k.length;L+=1){var C=k[L],M=S.search(C),A={};M.isMatch?(A[C]=M.score,w=g=!0,b.push(M.score)):(A[C]=1,this.options.matchAllTokens||b.push(1)),this._log('Token: "'+C+'", score: '+A[C])}w&&(m+=1)}_=b[0];for(var I=b.length,N=1;N<I;N+=1)_+=b[N];_/=I,this._log("Token score average:",_)}var T=y.score;-1<_&&(T=(T+_)/2),this._log("Score average:",T);var O=!this.options.tokenize||!this.options.matchAllTokens||m>=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<E;j+=1)this._analyze({key:n,arrayIndex:j,value:i[j],record:s,index:a},{resultMap:d,results:v,tokenSearchers:c,fullSearcher:h})}}},{key:"_computeScore",value:function(e,t){this._log("\n\nComputing score:\n");for(var n=0,o=t.length;n<o;n+=1){for(var r=t[n].output,i=r.length,s=1,a=1,l=0;l<i;l+=1){var c=e?e[r[l].key].weight:1,u=(1===c?r[l].score:r[l].score||.001)*c;1!==c?a=Math.min(a,u):s*=r[l].nScore=u}t[n].score=1===a?s:a,this._log(t[n])}}},{key:"_sort",value:function(e){this._log("\n\nSorting...."),e.sort(this.options.sortFn)}},{key:"_format",value:function(e){var t=[];this.options.verbose&&this._log("\n\nOutput:\n\n",JSON.stringify(e));var n=[];this.options.includeMatches&&n.push(function(e,t){var n=e.output;t.matches=[];for(var o=0,r=n.length;o<r;o+=1){var i=n[o];if(0!==i.matchedIndices.length){var s={indices:i.matchedIndices,value:i.value};i.key&&(s.key=i.key),i.hasOwnProperty("arrayIndex")&&-1<i.arrayIndex&&(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;o<r;o+=1){var i=e[o];if(this.options.id&&(i.item=this.options.getFn(i.item,this.options.id)[0]),n.length){for(var s={item:i.item},a=0,l=n.length;a<l;a+=1)n[a](i,s);t.push(s)}else t.push(i.item)}return t}},{key:"_log",value:function(){var e;this.options.verbose&&(e=console).log.apply(e,arguments)}}]),D}();e.exports=r}])},"object"==typeof n&&"object"==typeof t?t.exports=r():"function"==typeof define&&define.amd?define("Fuse",[],r):"object"==typeof n?n.Fuse=r():o.Fuse=r()},{}],3:[function(e,m,t){!function(){"use strict";function n(e,t){var n,o,r,i,s=h;for(i=arguments.length;2<i--;)u.push(arguments[i]);for(t&&null!=t.children&&(u.length||u.push(t.children),delete t.children);u.length;)if((o=u.pop())&&void 0!==o.pop)for(i=o.length;i--;)u.push(o[i]);else"boolean"==typeof o&&(o=null),(r="function"!=typeof e)&&(null==o?o="":"number"==typeof o?o=String(o):"string"!=typeof o&&(r=!1)),r&&n?s[s.length-1]+=o:s===h?s=[o]:s.push(o),n=r;var a=new c;return a.nodeName=e,a.children=s,a.attributes=null==t?void 0:t,a.key=null==t?void 0:t.key,void 0!==R.vnode&&R.vnode(a),a}function C(e,t){for(var n in t)e[n]=t[n];return e}function i(e){!e.__d&&(e.__d=!0)&&1==d.push(e)&&(R.debounceRendering||r)(t)}function t(){var e,t=d;for(d=[];e=t.pop();)e.__d&&E(e)}function L(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function M(e){var t=C({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var o in n)void 0===t[o]&&(t[o]=n[o]);return t}function A(e){var t=e.parentNode;t&&t.removeChild(e)}function v(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===p.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,l,s):e.removeEventListener(t,l,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e){try{e[t]=null==o?"":o}catch(e){}null!=o&&!1!==o||"spellcheck"==t||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 l(e){return this.__l[e.type](R.event&&R.event(e)||e)}function I(){for(var e;e=D.pop();)R.afterMount&&R.afterMount(e),e.componentDidMount&&e.componentDidMount()}function N(e,t,n,o,r,i){F++||(g=null!=r&&void 0!==r.ownerSVGElement,_=null!=e&&!("__preactattr_"in e));var s=T(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--F||(_=!1,i||I()),s}function T(e,t,n,o,r){var i=e,s=g;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),O(e,!0))),i.__preactattr_=!0,i;var a,l,c=t.nodeName;if("function"==typeof c)return function(e,t,n,o){var r=e&&e._component,i=r,s=e,a=r&&e._componentConstructor===t.nodeName,l=a,c=M(t);for(;r&&!l&&(r=r.__u);)l=r.constructor===t.nodeName;r&&l&&(!o||r._component)?(j(r,c,3,n,o),e=r.base):(i&&!a&&(U(i),e=s=null),r=P(t.nodeName,c,n),e&&!r.__b&&(r.__b=e,s=null),j(r,c,1,n,o),e=r.base,s&&e!==s&&(s._component=null,O(s,!1)));return e}(e,t,n,o);if(g="svg"===c||"foreignObject"!==c&&g,c=String(c),(!e||!L(e,c))&&(a=c,(l=g?document.createElementNS("http://www.w3.org/2000/svg",a):document.createElement(a)).__n=a,i=l,e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),O(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!_&&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)&&function(e,t,n,o,r){var i,s,a,l,c,u=e.childNodes,h=[],p={},d=0,f=0,v=u.length,g=0,_=t?t.length:0;if(0!==v)for(var m=0;m<v;m++){var y=u[m],k=y.__preactattr_,b=_&&k?y._component?y._component.__k:k.key:null;null!=b?(d++,p[b]=y):(k||(void 0!==y.splitText?!r||y.nodeValue.trim():r))&&(h[g++]=y)}if(0!==_)for(var m=0;m<_;m++){l=t[m],c=null;var b=l.key;if(null!=b)d&&void 0!==p[b]&&(c=p[b],p[b]=void 0,d--);else if(f<g)for(i=f;i<g;i++)if(void 0!==h[i]&&(x=s=h[i],w=r,"string"==typeof(S=l)||"number"==typeof S?void 0!==x.splitText:"string"==typeof S.nodeName?!x._componentConstructor&&L(x,S.nodeName):w||x._componentConstructor===S.nodeName)){c=s,h[i]=void 0,i===g-1&&g--,i===f&&f++;break}c=T(c,l,n,o),a=u[m],c&&c!==e&&c!==a&&(null==a?e.appendChild(c):c===a.nextSibling?A(a):e.insertBefore(c,a))}var x,S,w;if(d)for(var m in p)void 0!==p[m]&&O(p[m],!1);for(;f<=g;)void 0!==(c=h[g--])&&O(c,!1)}(i,p,n,o,_||null!=h.dangerouslySetInnerHTML),function(e,t,n){var o;for(o in n)t&&null!=t[o]||null==n[o]||v(e,o,n[o],n[o]=void 0,g);for(o in t)"children"===o||"innerHTML"===o||o in n&&t[o]===("value"===o||"checked"===o?e[o]:n[o])||v(e,o,n[o],n[o]=t[o],g)}(i,t.attributes,h),g=s,i}function O(e,t){var n=e._component;n?U(n):(null!=e.__preactattr_&&e.__preactattr_.ref&&e.__preactattr_.ref(null),!1!==t&&null!=e.__preactattr_||A(e),o(e))}function o(e){for(e=e.lastChild;e;){var t=e.previousSibling;O(e,!0),e=t}}function P(e,t,n){var o,r=f.length;for(e.prototype&&e.prototype.render?(o=new e(t,n),a.call(o,t,n)):((o=new a(t,n)).constructor=e,o.render=s);r--;)if(f[r].constructor===e)return o.__b=f[r].__b,f.splice(r,1),o;return o}function s(e,t,n){return this.constructor(e,n)}function j(e,t,n,o,r){e.__x||(e.__x=!0,e.__r=t.ref,e.__k=t.key,delete t.ref,delete t.key,void 0===e.constructor.getDerivedStateFromProps&&(!e.base||r?e.componentWillMount&&e.componentWillMount():e.componentWillReceiveProps&&e.componentWillReceiveProps(t,o)),o&&o!==e.context&&(e.__c||(e.__c=e.context),e.context=o),e.__p||(e.__p=e.props),e.props=t,e.__x=!1,0!==n&&(1!==n&&!1===R.syncComponentUpdates&&e.base?i(e):E(e,1,r)),e.__r&&e.__r(e))}function E(e,t,n,o){if(!e.__x){var r,i,s,a=e.props,l=e.state,c=e.context,u=e.__p||a,h=e.__s||l,p=e.__c||c,d=e.base,f=e.__b,v=d||f,g=e._component,_=!1,m=p;if(e.constructor.getDerivedStateFromProps&&(l=C(C({},l),e.constructor.getDerivedStateFromProps(a,l)),e.state=l),d&&(e.props=u,e.state=h,e.context=p,2!==t&&e.shouldComponentUpdate&&!1===e.shouldComponentUpdate(a,l,c)?_=!0:e.componentWillUpdate&&e.componentWillUpdate(a,l,c),e.props=a,e.state=l,e.context=c),e.__p=e.__s=e.__c=e.__b=null,e.__d=!1,!_){r=e.render(a,l,c),e.getChildContext&&(c=C(C({},c),e.getChildContext())),d&&e.getSnapshotBeforeUpdate&&(m=e.getSnapshotBeforeUpdate(u,h));var y,k,b=r&&r.nodeName;if("function"==typeof b){var x=M(r);(i=g)&&i.constructor===b&&x.key==i.__k?j(i,x,1,c,!1):(y=i,e._component=i=P(b,x,c),i.__b=i.__b||f,i.__u=e,j(i,x,0,c,!1),E(i,1,n,!0)),k=i.base}else s=v,(y=g)&&(s=e._component=null),(v||1===t)&&(s&&(s._component=null),k=N(s,r,c,n||!d,v&&v.parentNode,!0));if(v&&k!==v&&i!==g){var S=v.parentNode;S&&k!==S&&(S.replaceChild(k,v),y||(v._component=null,O(v,!1)))}if(y&&U(y),(e.base=k)&&!o){for(var w=e,L=e;L=L.__u;)(w=L).base=k;k._component=w,k._componentConstructor=w.constructor}}for(!d||n?D.unshift(e):_||(e.componentDidUpdate&&e.componentDidUpdate(u,h,m),R.afterUpdate&&R.afterUpdate(e));e.__h.length;)e.__h.pop().call(e);F||o||I()}}function U(e){R.beforeUnmount&&R.beforeUnmount(e);var t=e.base;e.__x=!0,e.componentWillUnmount&&e.componentWillUnmount(),e.base=null;var n=e._component;n?U(n):t&&(t.__preactattr_&&t.__preactattr_.ref&&t.__preactattr_.ref(null),A(e.__b=t),f.push(e),o(t)),e.__r&&e.__r(null)}function a(e,t){this.__d=!0,this.context=t,this.props=e,this.state=this.state||{},this.__h=[]}var c=function(){},R={},u=[],h=[],r="function"==typeof Promise?Promise.resolve().then.bind(Promise.resolve()):setTimeout,p=/acit|ex(?:s|g|n|p|$)|rph|ows|mnc|ntw|ine[ch]|zoo|^ord/i,d=[],D=[],F=0,g=!1,_=!1,f=[];C(a.prototype,{setState:function(e,t){this.__s||(this.__s=this.state),this.state=C(C({},this.state),"function"==typeof e?e(this.state,this.props):e),t&&this.__h.push(t),i(this)},forceUpdate:function(e){e&&this.__h.push(e),E(this,2)},render:function(){}});var e={h:n,createElement:n,cloneElement:function(e,t){return n(e.nodeName,C(C({},e.attributes),t),2<arguments.length?[].slice.call(arguments,2):e.children)},Component:a,render:function(e,t,n){return N(n,e,{},!1,t,!1)},rerender:t,options:R};void 0!==m?m.exports=e:self.preact=e}()},{}]},{},[1]);+//# sourceMappingURL=quick-jump.min.js.map
resources/html/solarized.css view
@@ -53,3 +53,45 @@ a:hover, a.hover-highlight { 	background-color: #eee8d5; }++span.annot{+    position:relative;+    color:#000;+    text-decoration:none+  }++span.annot:hover{z-index:25; background-color:#ff0}++span.annot span.annottext{+  display: none;+  border-radius: 5px 5px;++  -moz-border-radius: 5px;+  -webkit-border-radius: 5px;++  box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1);+  -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);+  -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);++  position: absolute;+  left: 1em; top: 2em;+  z-index: 99;+  margin-left: 5;+  background: #FFFFAA;+  border: 2px solid #FFAD33;+  padding: 0.8em 1em;+}++span.annot:hover span.annottext{+  display:block;+}++/* This bridges the gap so you can mouse into the tooltip without it disappearing */+span.annot span.annottext:before{+  content: "";+  position: absolute;+  left: -1em; top: -1em;+  background: #FFFFFF00;+  z-index:-1;+  padding: 2em 2em;+}
src/Documentation/Haddock.hs view
@@ -8,7 +8,7 @@ -- Stability   :  experimental -- Portability :  portable ----- The Haddock API: A rudimentory, highly experimental API exposing some of+-- The Haddock API: A rudimentary, highly experimental API exposing some of -- the internals of Haddock. Don't expect it to be stable. ----------------------------------------------------------------------------- module Documentation.Haddock (@@ -39,7 +39,8 @@   DocH(..),   Example(..),   Hyperlink(..),-  DocMarkup(..),+  DocMarkup,+  DocMarkupH(..),   Documentation(..),   ArgMap,   AliasMap,@@ -51,9 +52,7 @@   -- * Interface files   InterfaceFile(..),   readInterfaceFile,-  nameCacheFromGhc,   freshNameCache,-  NameCacheAccessor,    -- * Flags and options   Flag(..),@@ -69,12 +68,11 @@   withGhc ) where -+import Documentation.Haddock.Markup (markup) import Haddock.InterfaceFile import Haddock.Interface import Haddock.Types import Haddock.Options-import Haddock.Utils import Haddock
src/Haddock.hs view
@@ -1,6 +1,12 @@-{-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# OPTIONS_GHC -Wwarn           #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock@@ -25,54 +31,59 @@   withGhc ) where -import Data.Version import Haddock.Backends.Xhtml+import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker import Haddock.Interface+import Haddock.Interface.Json import Haddock.Parser import Haddock.Types import Haddock.Version import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils+import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) +import Control.DeepSeq (force) import Control.Monad hiding (forM_)-import Control.Applicative-import Data.Foldable (forM_)-import Data.List (isPrefixOf)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Bifunctor (second)+import Data.Foldable (forM_, foldl')+import Data.Traversable (for)+import Data.List (find, isPrefixOf, nub) import Control.Exception import Data.Maybe import Data.IORef-import Data.Map (Map)-import qualified Data.Map as Map+import Data.Map.Strict (Map)+import Data.Version (makeVersion)+import qualified Data.Map.Strict as Map import System.IO import System.Exit--#if defined(mingw32_HOST_OS)-import Foreign-import Foreign.C-import Data.Int-#endif+import System.FilePath  #ifdef IN_GHC_TREE-import System.FilePath+import System.Environment (getExecutablePath) #else import qualified GHC.Paths as GhcPaths import Paths_haddock_api (getDataDir)-import System.Directory (doesDirectoryExist) #endif+import System.Directory (doesDirectoryExist, getTemporaryDirectory) +import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity)-import Config-import DynFlags hiding (projectVersion, verbosity)-import StaticFlags (discardStaticFlags)-import Packages-import Panic (handleGhcException)-import Module-import FastString+import GHC.Settings.Config+import GHC.Driver.Config.Logger (initLogFlags)+import GHC.Driver.Env+import GHC.Driver.Session hiding (projectVersion, verbosity)+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Types.Name.Cache+import GHC.Unit+import GHC.Utils.Panic (handleGhcException)+import GHC.Data.FastString  -------------------------------------------------------------------------------- -- * Exception handling@@ -147,101 +158,181 @@   -- or which exits with an error or help message.   (flags, files) <- parseHaddockOpts args   shortcutFlags flags-  qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}+  qual <- rightOrThrowE (qualification flags)+  sinceQual <- rightOrThrowE (sinceQualification flags) -  -- inject dynamic-too into flags before we proceed-  flags' <- ghc flags $ do+  -- Inject dynamic-too into ghc options if the ghc we are using was built with+  -- dynamic linking+  flags'' <- ghc flags $ do         df <- getDynFlags         case lookup "GHC Dynamic" (compilerInfo df) of           Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags           _ -> return flags +  -- Inject `-j` into ghc options, if given to Haddock+  flags' <- pure $ case optParCount flags'' of+    Nothing       -> flags''+    Just Nothing  -> Flag_OptGhc "-j" : flags''+    Just (Just n) -> Flag_OptGhc ("-j" ++ show n) : flags''++  -- Whether or not to bypass the interface version check+  let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags++  -- Create a temporary directory and redirect GHC output there (unless user+  -- requested otherwise).+  --+  -- Output dir needs to be set before calling 'depanal' since 'depanal' uses it+  -- to compute output file names that are stored in the 'DynFlags' of the+  -- resulting 'ModSummary's.+  let withDir | Flag_NoTmpCompDir `elem` flags = id+              | otherwise = withTempOutputDir++  -- Output warnings about potential misuse of some flags   unless (Flag_NoWarnings `elem` flags) $ do     hypSrcWarnings flags-    forM_ (warnings args) $ \warning -> do-      hPutStrLn stderr warning--  ghc flags' $ do+    mapM_ (hPutStrLn stderr) (optGhcWarnings args)+    when noChecks $+      hPutStrLn stderr noCheckWarning +  ghc flags' $ withDir $ do     dflags <- getDynFlags+    logger <- getLogger+    !unit_state <- hsc_units <$> getSession +    -- If any --show-interface was used, show the given interfaces+    forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do+      name_cache <- freshNameCache+      mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks+      forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do+        putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)++    -- If we were given source files to generate documentation from, do it     if not (null files) then do       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files+      let packageInfo = PackageInfo { piPackageName =+                                        fromMaybe (PackageName mempty) (optPackageName flags)+                                    , piPackageVersion =+                                        fromMaybe (makeVersion []) (optPackageVersion flags)+                                    }        -- Dump an "interface file" (.haddock file), if requested.       forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do         writeInterfaceFile path InterfaceFile {             ifInstalledIfaces = map toInstalledIface ifaces+          , ifPackageInfo     = packageInfo           , ifLinkEnv         = homeLinks           }        -- Render the interfaces.-      liftIO $ renderStep dflags flags qual packages ifaces+      liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces +    -- If we were not given any input files, error if documentation was+    -- requested     else do       when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $         throwE "No input file(s)."        -- Get packages supplied with --read-interface.-      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)+      name_cache <- liftIO $ freshNameCache+      packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks        -- Render even though there are no input files (usually contents/index).-      liftIO $ renderStep dflags flags qual packages []+      liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] +-- | Run the GHC action using a temporary output directory+withTempOutputDir :: Ghc a -> Ghc a+withTempOutputDir action = do+  tmp <- liftIO getTemporaryDirectory+  x   <- liftIO getProcessID+  let dir = tmp </> ".haddock-" ++ show x+  modifySessionDynFlags (setOutputDir dir)+  withTempDir dir action+ -- | Create warnings about potential misuse of -optghc-warnings :: [String] -> [String]-warnings = map format . filter (isPrefixOf "-optghc")+optGhcWarnings :: [String] -> [String]+optGhcWarnings = map format . filter (isPrefixOf "-optghc")   where     format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] +-- | Create a warning about bypassing the interface version check+noCheckWarning :: String+noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " +++                 "Haddock to crash when reading Haddock interface files."  withGhc :: [Flag] -> Ghc a -> IO a withGhc flags action = do-  libDir <- fmap snd (getGhcDirs flags)+  libDir <- fmap (fromMaybe (error "No GhcDir found") . snd) (getGhcDirs flags)    -- Catches all GHC source errors, then prints and re-throws them.   let handleSrcErrors action' = flip handleSourceError action' $ \err -> do         printException err         liftIO exitFailure+      needHieFiles = Flag_HyperlinkedSource `elem` flags -  withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)+  withGhc' libDir needHieFiles (ghcFlags flags) (\_ -> handleSrcErrors action)   readPackagesAndProcessModules :: [Flag] -> [String]-                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)+                              -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do-    -- Get packages supplied with --read-interface.-    packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)+    -- Whether or not we bypass the interface file version check+    let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags -    -- Create the interfaces -- this is the core part of Haddock.-    let ifaceFiles = map snd packages+    -- Read package dependency interface files supplied with --read-interface+    name_cache <- hsc_NC <$> getSession+    packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks++    -- Create the interfaces for the given modules -- this is the core part of Haddock+    let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages     (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles      return (packages, ifaces, homeLinks)  -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()-renderStep dflags flags qual pkgs interfaces = do-  updateHTMLXRefs pkgs+renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption+           -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO ()+renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do+  updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->+                          ( case baseUrl flags of+                              Nothing  -> fst docPath+                              Just url -> url </> packageName (ifUnitId ifaceFile)+                          , ifaceFile)) pkgs)   let-    ifaceFiles = map snd pkgs-    installedIfaces = concatMap ifInstalledIfaces ifaceFiles+    installedIfaces =+      map+        (\(_, showModules, ifaceFilePath, ifaceFile)+          -> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile))+        pkgs     extSrcMap = Map.fromList $ do-      ((_, Just path), ifile) <- pkgs+      ((_, Just path), _, _, ifile) <- pkgs       iface <- ifInstalledIfaces ifile       return (instMod iface, path)-  render dflags flags qual interfaces installedIfaces extSrcMap-+  render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap+  where+    -- get package name from unit-id+    packageName :: Unit -> String+    packageName unit =+      case lookupUnit unit_state unit of+        Nothing  -> show unit+        Just pkg -> unitPackageNameString pkg  -- | Render the interfaces with whatever backend is specified in the flags.-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()-render dflags flags qual ifaces installedIfaces extSrcMap = do+render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]+       -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO ()+render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do    let+    packageInfo = PackageInfo { piPackageName    = fromMaybe (PackageName mempty)+                                                 $ optPackageName flags+                              , piPackageVersion = fromMaybe (makeVersion [])+                                                 $ optPackageVersion flags+                              }+     title                = fromMaybe "" (optTitle flags)     unicode              = Flag_UseUnicode `elem` flags     pretty               = Flag_PrettyHtml `elem` flags     opt_wiki_urls        = wikiUrls          flags+    opt_base_url         = baseUrl           flags     opt_contents_url     = optContentsUrl    flags     opt_index_url        = optIndexUrl       flags     odir                 = outputDir         flags@@ -251,113 +342,190 @@     dflags'       | unicode          = gopt_set dflags Opt_PrintUnicodeSyntax       | otherwise        = dflags+    logger               = setLogFlags log' (initLogFlags dflags')      visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] -    -- /All/ visible interfaces including external package modules.-    allIfaces        = map toInstalledIface ifaces ++ installedIfaces-    allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]+    -- /All/ interfaces including external package modules, grouped by+    -- interface file (package).+    allPackages      :: [PackageInterfaces]+    allPackages      = [PackageInterfaces+                         { piPackageInfo = packageInfo+                         , piVisibility  = Visible+                         , piInstalledInterfaces  = map toInstalledIface ifaces+                         }]+                    ++ map snd packages -    pkgMod           = ifaceMod (head ifaces)-    pkgKey           = moduleUnitId pkgMod-    pkgStr           = Just (unitIdString pkgKey)-    pkgNameVer       = modulePackageInfo dflags flags pkgMod+    -- /All/ visible interfaces including external package modules, grouped by+    -- interface file (package).+    allVisiblePackages :: [PackageInterfaces]+    allVisiblePackages = [ pinfo { piInstalledInterfaces =+                                     filter (\i -> OptHide `notElem` instOptions i)+                                            piInstalledInterfaces+                                 }+                         | pinfo@PackageInterfaces+                             { piVisibility = Visible+                             , piInstalledInterfaces+                             } <- allPackages+                         ] +    -- /All/ installed interfaces.+    allInstalledIfaces :: [InstalledInterface]+    allInstalledIfaces = concatMap (piInstalledInterfaces . snd) packages++    pkgMod           = fmap ifaceMod (listToMaybe ifaces)+    pkgKey           = fmap moduleUnit pkgMod+    pkgStr           = fmap unitString pkgKey+    pkgNameVer       = modulePackageInfo unit_state flags pkgMod+    pkgName          = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)+    sincePkg         = case sinceQual of+                         External -> pkgName+                         Always -> Nothing+     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags      srcModule'       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat       | otherwise = srcModule -    srcMap = mkSrcMap $ Map.union+    srcMap = Map.union       (Map.map SrcExternal extSrcMap)       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) -    pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap+    pkgSrcMap = Map.mapKeys moduleUnit extSrcMap     pkgSrcMap'-      | Flag_HyperlinkedSource `elem` flags =-          Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap-      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap+      | Flag_HyperlinkedSource `elem` flags+      , Just k <- pkgKey+      = Map.insert k hypSrcModuleNameUrlFormat pkgSrcMap+      | Just srcNameUrl <- srcEntity+      , Just k <- pkgKey+      = Map.insert k srcNameUrl pkgSrcMap       | otherwise = pkgSrcMap      -- TODO: Get these from the interface files as with srcMap     pkgSrcLMap'-      | Flag_HyperlinkedSource `elem` flags =-          Map.singleton pkgKey hypSrcModuleLineUrlFormat-      | Just path <- srcLEntity = Map.singleton pkgKey path+      | Flag_HyperlinkedSource `elem` flags+      , Just k <- pkgKey+      = Map.singleton k hypSrcModuleLineUrlFormat+      | Just path <- srcLEntity+      , Just k <- pkgKey+      = Map.singleton k path       | otherwise = Map.empty      sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') +    installedMap :: Map Module InstalledInterface+    installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- allInstalledIfaces ]++    -- The user gives use base-4.9.0.0, but the InstalledInterface+    -- records the *wired in* identity base.  So untranslate it+    -- so that we can service the request.+    unwire :: Module -> Module+    unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }++  reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do+    let warn' = hPutStrLn stderr . ("Warning: " ++)+    case readP_to_S parseHoleyModule mod_str of+      [(m, "")]+        | Just iface <- Map.lookup m installedMap+        -> return [iface]+        | otherwise+        -> warn' ("Cannot find reexported module '" ++ mod_str ++ "'") >> return []+      _ -> warn' ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return [])+   libDir   <- getHaddockLibDir flags-  prologue <- getPrologue dflags' flags+  !prologue <- force <$> getPrologue dflags' flags   themes   <- getThemes libDir flags >>= either bye return +  let withQuickjump = Flag_QuickJumpIndex `elem` flags+      withBaseURL = isJust+                  . find (\flag -> case flag of+                           Flag_BaseURL base_url ->+                             base_url /= "." && base_url /= "./"+                           _ -> False+                         )+                  $ flags+   when (Flag_GenIndex `elem` flags) $ do-    ppHtmlIndex odir title pkgStr-                themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls-                allVisibleIfaces pretty-    copyHtmlBits odir libDir themes+    withTiming logger "ppHtmlIndex" (const ()) $ do+      _ <- {-# SCC ppHtmlIndex #-}+           ppHtmlIndex odir title pkgStr+                  themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls+                  withQuickjump+                  (concatMap piInstalledInterfaces allVisiblePackages) pretty+      return () +    unless withBaseURL $+      copyHtmlBits odir libDir themes withQuickjump+   when (Flag_GenContents `elem` flags) $ do-    ppHtmlContents dflags' odir title pkgStr-                   themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls-                   allVisibleIfaces True prologue pretty-                   (makeContentsQual qual)-    copyHtmlBits odir libDir themes+    withTiming logger "ppHtmlContents" (const ()) $ do+      _ <- {-# SCC ppHtmlContents #-}+           ppHtmlContents unit_state odir title pkgStr+                     themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls+                     withQuickjump+                     allVisiblePackages True prologue pretty+                     sincePkg (makeContentsQual qual)+      return ()+    copyHtmlBits odir libDir themes withQuickjump +  when withQuickjump $ void $+            ppJsonIndex odir sourceUrls' opt_wiki_urls+                        unicode Nothing qual+                        ifaces+                        ( nub+                        . map fst+                        . filter ((== Visible) . piVisibility . snd)+                        $ packages)+   when (Flag_Html `elem` flags) $ do-    ppHtml dflags' title pkgStr visibleIfaces odir-                prologue-                themes opt_mathjax sourceUrls' opt_wiki_urls-                opt_contents_url opt_index_url unicode qual-                pretty-    copyHtmlBits odir libDir themes+    withTiming logger "ppHtml" (const ()) $ do+      _ <- {-# SCC ppHtml #-}+           ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir+                  prologue+                  themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url+                  opt_contents_url opt_index_url unicode sincePkg packageInfo+                  qual pretty withQuickjump+      return ()+    unless withBaseURL $ do+      copyHtmlBits odir libDir themes withQuickjump+      writeHaddockMeta odir withQuickjump    -- TODO: we throw away Meta for both Hoogle and LaTeX right now,   -- might want to fix that if/when these two get some work on them   when (Flag_Hoogle `elem` flags) $ do     case pkgNameVer of-      Nothing -> putStrLn . unlines $+      (Just (PackageName pkgNameFS), mpkgVer) ->+          let+            pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title+                       | otherwise = unpackFS pkgNameFS++            pkgVer =+              fromMaybe (makeVersion []) mpkgVer+          in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)+               visibleIfaces odir+      _ -> putStrLn . unlines $           [ "haddock: Unable to find a package providing module "-            ++ moduleNameString (moduleName pkgMod) ++ ", skipping Hoogle."+            ++ maybe "<no-mod>" (moduleNameString . moduleName) pkgMod+            ++ ", skipping Hoogle."           , ""           , "         Perhaps try specifying the desired package explicitly"             ++ " using the --package-name"           , "         and --package-version arguments."           ]-      Just (PackageName pkgNameFS, pkgVer) ->-          let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title-                         | otherwise = unpackFS pkgNameFS-          in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)-               visibleIfaces odir    when (Flag_LaTeX `elem` flags) $ do-    ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style-                  libDir+    withTiming logger "ppLatex" (const ()) $ do+      _ <- {-# SCC ppLatex #-}+           ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style+                   libDir+      return ()    when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do-    ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces---- | From GHC 7.10, this function has a potential to crash with a--- nasty message such as @expectJust getPackageDetails@ because--- package name and versions can no longer reliably be extracted in--- all cases: if the package is not installed yet then this info is no--- longer available. The @--package-name@ and @--package-version@--- Haddock flags allow the user to specify this information and it is--- returned here if present: if it is not present, the error will--- occur. Nasty but that's how it is for now. Potential TODO.-modulePackageInfo :: DynFlags-                  -> [Flag] -- ^ Haddock flags are checked as they may-                            -- contain the package name or version-                            -- provided by the user which we-                            -- prioritise-                  -> Module -> Maybe (PackageName, Data.Version.Version)-modulePackageInfo dflags flags modu =-    cmdline <|> pkgDb-  where-    cmdline = (,) <$> optPackageName flags <*> optPackageVersion flags-    pkgDb = (\pkg -> (packageName pkg, packageVersion pkg)) <$> lookupPackage dflags (moduleUnitId modu)+    withTiming logger "ppHyperlinkedSource" (const ()) $ do+      _ <- {-# SCC ppHyperlinkedSource #-}+           ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces+      return ()   -------------------------------------------------------------------------------@@ -365,22 +533,22 @@ -------------------------------------------------------------------------------  -readInterfaceFiles :: MonadIO m-                   => NameCacheAccessor m-                   -> [(DocPaths, FilePath)]-                   -> m [(DocPaths, InterfaceFile)]-readInterfaceFiles name_cache_accessor pairs = do-  catMaybes `liftM` mapM tryReadIface pairs+readInterfaceFiles :: NameCache+                   -> [(DocPaths, Visibility, FilePath)]+                   -> Bool+                   -> IO [(DocPaths, Visibility, FilePath, InterfaceFile)]+readInterfaceFiles name_cache_accessor pairs bypass_version_check = do+  catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs   where     -- try to read an interface, warn if we can't-    tryReadIface (paths, file) =-      readInterfaceFile name_cache_accessor file >>= \case-        Left err -> liftIO $ do+    tryReadIface (paths, vis, file) =+      readInterfaceFile name_cache_accessor file bypass_version_check >>= \case+        Left err -> do           putStrLn ("Warning: Cannot read " ++ file ++ ":")           putStrLn ("   " ++ err)           putStrLn "Skipping this interface."           return Nothing-        Right f -> return $ Just (paths, f)+        Right f -> return (Just (paths, vis, file, f))   -------------------------------------------------------------------------------@@ -390,84 +558,147 @@  -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action.-withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a-withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do-  dynflags  <- getSessionDynFlags-  dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {-    hscTarget = HscNothing,-    ghcMode   = CompManager,-    ghcLink   = NoLink-    }-  let dynflags'' = gopt_unset dynflags' Opt_SplitObjs-  defaultCleanupHandler dynflags'' $ do-      -- ignore the following return-value, which is a list of packages-      -- that may need to be re-linked: Haddock doesn't do any-      -- dynamic or static linking at all!-      _ <- setSessionDynFlags dynflags''-      ghcActs dynflags''+withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a+withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do+    logger <- getLogger+    dynflags' <- parseGhcFlags logger =<< getSessionDynFlags++    -- We disable pattern match warnings because than can be very+    -- expensive to check+    let dynflags'' = unsetPatternMatchWarnings $ updOptLevel 0 dynflags'++    -- ignore the following return-value, which is a list of packages+    -- that may need to be re-linked: Haddock doesn't do any+    -- dynamic or static linking at all!+    _ <- setSessionDynFlags dynflags''+    ghcActs dynflags''   where-    parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags-    parseGhcFlags dynflags = do+    -- ignore sublists of flags that start with "+RTS" and end in "-RTS"+    --+    -- See https://github.com/haskell/haddock/issues/666+    filterRtsFlags :: [String] -> [String]+    filterRtsFlags flgs = foldr go (const []) flgs True+      where go "-RTS" func _ = func True+            go "+RTS" func _ = func False+            go _      func False = func False+            go arg    func True = arg : func True++    parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+    parseGhcFlags logger dynflags = do       -- TODO: handle warnings? -      -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot-      -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if-      -- we pass any, Haddock will fail. Since StaticFlags are global to the-      -- GHC invocation, there's also no way to reparse/save them to set them-      -- again properly.-      ---      -- This is a bit of a hack until we get rid of the rest of the remaining-      -- StaticFlags. See GHC issue #8276.-      let flags' = discardStaticFlags flags-      (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')+      let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]+                     | otherwise = [Opt_Haddock]+          dynflags' = (foldl' gopt_set dynflags extra_opts)+                        { backend = noBackend+                        , ghcMode = CompManager+                        , ghcLink = NoLink+                        }+          flags' = filterRtsFlags flags++      (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags')       if not (null rest)         then throwE ("Couldn't parse GHC options: " ++ unwords flags')-        else return dynflags'+        else return dynflags'' +unsetPatternMatchWarnings :: DynFlags -> DynFlags+unsetPatternMatchWarnings dflags =+  foldl' wopt_unset dflags pattern_match_warnings+  where+    pattern_match_warnings =+      [ Opt_WarnIncompletePatterns+      , Opt_WarnIncompleteUniPatterns+      , Opt_WarnIncompletePatternsRecUpd+      , Opt_WarnOverlappingPatterns+      ]+ ------------------------------------------------------------------------------- -- * Misc -------------------------------------------------------------------------------  -getHaddockLibDir :: [Flag] -> IO String+getHaddockLibDir :: [Flag] -> IO FilePath getHaddockLibDir flags =   case [str | Flag_Lib str <- flags] of     [] -> do #ifdef IN_GHC_TREE-      getInTreeDir++      -- When in the GHC tree, we should be able to locate the "lib" folder+      -- based on the location of the current executable.+      base_dir <- getBaseDir      -- Provided by GHC+      let res_dirs = [ d | Just d <- [base_dir] ] +++ #else-      d <- getDataDir -- provided by Cabal-      doesDirectoryExist d >>= \exists -> case exists of-        True -> return d-        False -> do-          -- If directory does not exist then we are probably invoking from-          -- ./dist/build/haddock/haddock so we use ./resources as a fallback.-          doesDirectoryExist "resources" >>= \exists_ -> case exists_ of-            True -> return "resources"-            False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")++      -- When Haddock was installed by @cabal@, the resources (which are listed+      -- under @data-files@ in the Cabal file) will have been copied to a+      -- special directory.+      data_dir <- getDataDir      -- Provided by Cabal+      let res_dirs = [ data_dir ] +++ #endif-    fs -> return (last fs) +      -- When Haddock is built locally (eg. regular @cabal new-build@), the data+      -- directory does not exist and we are probably invoking from either+      -- @./haddock-api@ or @./@+                     [ "resources"+                     , "haddock-api/resources"+                     ] -getGhcDirs :: [Flag] -> IO (String, String)+      res_dir <- check res_dirs+      case res_dir of+        Just p -> return p+        _      -> die "Haddock's resource directory does not exist!\n"++    fs -> return (last fs)+  where+    -- Pick the first path that corresponds to a directory that exists+    check :: [FilePath] -> IO (Maybe FilePath)+    check [] = pure Nothing+    check (path : other_paths) = do+      exists <- doesDirectoryExist path+      if exists then pure (Just path) else check other_paths++-- | Find the @lib@ directory for GHC and the path to @ghc@+getGhcDirs :: [Flag] -> IO (Maybe FilePath, Maybe FilePath) getGhcDirs flags = do-  case [ dir | Flag_GhcLibDir dir <- flags ] of-    [] -> do+ #ifdef IN_GHC_TREE-      libDir <- getInTreeDir-      return (ghcPath, libDir)+  base_dir <- getBaseDir+  let ghc_path = Nothing #else-      return (ghcPath, GhcPaths.libdir)+  let base_dir = Just GhcPaths.libdir+      ghc_path = Just GhcPaths.ghc #endif-    xs -> return (ghcPath, last xs)-  where++  -- If the user explicitly specifies a lib dir, use that+  let ghc_dir = case [ dir | Flag_GhcLibDir dir <- flags ] of+                  [] -> base_dir+                  xs -> Just (last xs)++  pure (ghc_path, ghc_dir)++ #ifdef IN_GHC_TREE-    ghcPath = "not available"-#else-    ghcPath = GhcPaths.ghc-#endif +-- | See 'getBaseDir' in "SysTools.BaseDir"+getBaseDir :: IO (Maybe FilePath)+getBaseDir = do +  -- Getting executable path can fail. Turn that into 'Nothing'+  exec_path_opt <- catch (Just <$> getExecutablePath)+                         (\(_ :: SomeException) -> pure Nothing)++  -- Check that the path we are about to return actually exists+  case exec_path_opt of+    Nothing -> pure Nothing+    Just exec_path -> do+      let base_dir = takeDirectory (takeDirectory exec_path) </> "lib"+      exists <- doesDirectoryExist base_dir+      pure (if exists then Just base_dir else Nothing)++#endif+ shortcutFlags :: [Flag] -> IO () shortcutFlags flags = do   usage <- getUsage@@ -480,19 +711,19 @@   when (Flag_GhcVersion       `elem` flags) (bye (cProjectVersion ++ "\n"))    when (Flag_PrintGhcPath `elem` flags) $ do-    dir <- fmap fst (getGhcDirs flags)-    bye $ dir ++ "\n"+    path <- fmap fst (getGhcDirs flags)+    bye $ fromMaybe "not available" path ++ "\n"    when (Flag_PrintGhcLibDir `elem` flags) $ do     dir <- fmap snd (getGhcDirs flags)-    bye $ dir ++ "\n"+    bye $ fromMaybe "not available" dir ++ "\n"    when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $     throwE "Unicode can only be enabled for HTML output."    when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)         && Flag_Html `elem` flags) $-    throwE "-h cannot be used with --gen-index or --gen-contents"+    throwE "-h/--html cannot be used with --gen-index or --gen-contents"    when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)         && Flag_Hoogle `elem` flags) $@@ -510,38 +741,42 @@ -- | Generate some warnings about potential misuse of @--hyperlinked-source@. hypSrcWarnings :: [Flag] -> IO () hypSrcWarnings flags = do-     when (hypSrc && any isSourceUrlFlag flags) $         hPutStrLn stderr $ concat             [ "Warning: "             , "--source-* options are ignored when "             , "--hyperlinked-source is enabled."             ]-     when (not hypSrc && any isSourceCssFlag flags) $         hPutStrLn stderr $ concat             [ "Warning: "             , "source CSS file is specified but "             , "--hyperlinked-source is disabled."             ]-   where+    hypSrc :: Bool     hypSrc = Flag_HyperlinkedSource `elem` flags++    isSourceUrlFlag :: Flag -> Bool     isSourceUrlFlag (Flag_SourceBaseURL _) = True     isSourceUrlFlag (Flag_SourceModuleURL _) = True     isSourceUrlFlag (Flag_SourceEntityURL _) = True     isSourceUrlFlag (Flag_SourceLEntityURL _) = True     isSourceUrlFlag _ = False++    isSourceCssFlag :: Flag -> Bool     isSourceCssFlag (Flag_SourceCss _) = True     isSourceCssFlag _ = False  -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()+updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO () updateHTMLXRefs packages = do-  writeIORef html_xrefs_ref (Map.fromList mapping)-  writeIORef html_xrefs_ref' (Map.fromList mapping')+  let !modMap     = force $ Map.fromList mapping+      !modNameMap = force $ Map.fromList mapping'+  writeIORef html_xrefs_ref  modMap+  writeIORef html_xrefs_ref' modNameMap   where-    mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages+    mapping = [ (instMod iface, html) | (html, ifaces) <- packages               , iface <- ifInstalledIfaces ifaces ]     mapping' = [ (moduleName m, html) | (m, html) <- mapping ] @@ -550,36 +785,15 @@ getPrologue dflags flags =   case [filename | Flag_Prologue filename <- flags ] of     [] -> return Nothing-    [filename] -> withFile filename ReadMode $ \h -> do+    [filename] -> do+      h <- openFile filename ReadMode       hSetEncoding h utf8-      str <- hGetContents h-      return . Just $! parseParas dflags str+      str <- hGetContents h -- semi-closes the handle+      return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str     _ -> throwE "multiple -p/--prologue options"  -#ifdef IN_GHC_TREE--getInTreeDir :: IO String-getInTreeDir = getExecDir >>= \case-  Nothing -> error "No GhcDir found"-  Just d -> return (d </> ".." </> "lib")---getExecDir :: IO (Maybe String)-#if defined(mingw32_HOST_OS)-getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.-  where-    try_size size = allocaArray (fromIntegral size) $ \buf -> do-        ret <- c_GetModuleFileName nullPtr buf size-        case ret of-          0 -> return Nothing-          _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf-            | otherwise  -> try_size (size * 2)--foreign import stdcall unsafe "windows.h GetModuleFileNameW"-  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32-#else-getExecDir = return Nothing-#endif+rightOrThrowE :: Either String b -> IO b+rightOrThrowE (Left msg) = throwE msg+rightOrThrowE (Right x) = pure x -#endif
src/Haddock/Backends/HaddockDB.hs view
@@ -104,16 +104,21 @@ 					 hsep (map ppHsAType b)) context)  ppHsType :: HsType -> Doc-ppHsType (HsForAllType Nothing context htype) =+ppHsType (HsForAllType _ Nothing context htype) =      hsep [ ppHsContext context, text "=>", ppHsType htype]-ppHsType (HsForAllType (Just tvs) [] htype) =-     hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])-ppHsType (HsForAllType (Just tvs) context htype) =-     hsep (text "forall" : map ppHsName tvs ++ text "." :+ppHsType (HsForAllType fvf (Just tvs) [] htype) =+     hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf :+       [ppHsType htype])+ppHsType (HsForAllType fvf (Just tvs) context htype) =+     hsep (text "forall" : map ppHsName tvs ++ pprHsForAllSeparator fvf : 	   ppHsContext context : text "=>" : [ppHsType htype]) ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "-&gt;", ppHsType b] ppHsType (HsTyIP n t)  = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] ppHsType t = ppHsBType t++ppHsForAllSeparator :: ForallVisFlag -> Doc+ppHsForAllSeparator ForallVis   = text "-&gt;"+ppHsForAllSeparator ForallInvis = text "."  ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )   = brackets $ ppHsType b
src/Haddock/Backends/Hoogle.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Backends.Hoogle@@ -12,27 +15,34 @@ -- http://www.haskell.org/hoogle/ ----------------------------------------------------------------------------- module Haddock.Backends.Hoogle (+    -- * Main entry point to Hoogle output generation     ppHoogle++    -- * Utilities for generating Hoogle output during interface creation+  , ppExportD+  , outWith   ) where -import BasicTypes (OverlapFlag(..), OverlapMode(..))-import InstEnv (ClsInst(..))+import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out)  import GHC-import Outputable-import NameSet+import GHC.Driver.Ppr+import GHC.Plugins (TopLevelFlag(..))+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Unit.State  import Data.Char-import Data.List+import Data.Foldable (toList)+import Data.List (intercalate, isPrefixOf) import Data.Maybe import Data.Version  import System.Directory import System.FilePath-import System.IO  prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock"@@ -42,57 +52,59 @@  ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do-    let filename = package ++ ".txt"+    let -- Since Hoogle is line based, we want to avoid breaking long lines.+        dflags' = dflags{ pprCols = maxBound }+        filename = package ++ ".txt"         contents = prefix ++-                   docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue +++                   docWith dflags' (drop 2 $ dropWhile (/= ':') synopsis) prologue ++                    ["@package " ++ package] ++                    ["@version " ++ showVersion version-                   | not (null (versionBranch version)) ] ++-                   concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]+                   | not (null (versionBranch version))+                   ] +++                   concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]     createDirectoryIfMissing True odir-    h <- openFile (odir </> filename) WriteMode-    hSetEncoding h utf8-    hPutStr h (unlines contents)-    hClose h+    writeUtf8File (odir </> filename) (unlines contents)  ppModule :: DynFlags -> Interface -> [String] ppModule dflags iface =   "" : ppDocumentation dflags (ifaceDoc iface) ++   ["module " ++ moduleString (ifaceMod iface)] ++-  concatMap (ppExport dflags) (ifaceExportItems iface) ++-  concatMap (ppInstance dflags) (ifaceInstances iface)+  concatMap ppExportItem (ifaceRnExportItems $ iface) +++  map (fromMaybe "" . haddockClsInstPprHoogle) (ifaceInstances iface) +-- | If the export item is an 'ExportDecl', get the attached Hoogle textual+-- database entries for that export declaration.+ppExportItem :: ExportItem DocNameI -> [String]+ppExportItem (ExportDecl RnExportD { rnExpDHoogle = o }) = o+ppExportItem _                                           = []  --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a-dropHsDocTy = f+dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn+dropHsDocTy = drop_sig_ty     where-        g (L src x) = L src (f x)-        f (HsForAllTy a e) = HsForAllTy a (g e)-        f (HsQualTy a e) = HsQualTy a (g e)-        f (HsBangTy a b) = HsBangTy a (g b)-        f (HsAppTy a b) = HsAppTy (g a) (g b)-        f (HsFunTy a b) = HsFunTy (g a) (g b)-        f (HsListTy a) = HsListTy (g a)-        f (HsPArrTy a) = HsPArrTy (g a)-        f (HsTupleTy a b) = HsTupleTy a (map g b)-        f (HsOpTy a b c) = HsOpTy (g a) b (g c)-        f (HsParTy a) = HsParTy (g a)-        f (HsKindSig a b) = HsKindSig (g a) b-        f (HsDocTy a _) = f $ unL a-        f x = x--outHsType :: OutputableBndr a => DynFlags -> HsType a -> String-outHsType dflags = out dflags . dropHsDocTy+        drop_sig_ty (HsSig x a b)  = HsSig x a (drop_lty b)+        drop_sig_ty x@XHsSigType{} = x +        drop_lty (L src x) = L src (drop_ty x) -dropComment :: String -> String-dropComment (' ':'-':'-':' ':_) = []-dropComment (x:xs) = x : dropComment xs-dropComment [] = []+        drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)+        drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)+        drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)+        drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)+        drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)+        drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)+        drop_ty (HsListTy x a) = HsListTy x (drop_lty a)+        drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)+        drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c)+        drop_ty (HsParTy x a) = HsParTy x (drop_lty a)+        drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b+        drop_ty (HsDocTy _ a _) = drop_ty $ unL a+        drop_ty x = x +outHsSigType :: DynFlags -> HsSigType GhcRn -> String+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy  outWith :: Outputable a => (SDoc -> String) -> a -> [Char] outWith p = f . unwords . map (dropWhile isSpace) . lines . p . ppr@@ -102,60 +114,73 @@         f [] = []  out :: Outputable a => DynFlags -> a -> String-out dflags = outWith $ showSDocUnqual dflags+out dflags = outWith $ showSDoc dflags  operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x  commaSeparate :: Outputable a => DynFlags -> [a] -> String-commaSeparate dflags = showSDocUnqual dflags . interpp'SP+commaSeparate dflags = showSDoc dflags . interpp'SP  --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem Name -> [String]-ppExport dflags ExportDecl { expItemDecl    = L _ decl-                           , expItemMbDoc   = (dc, _)-                           , expItemSubDocs = subdocs-                           , expItemFixities = fixities-                           } = ppDocumentation dflags dc ++ f decl-    where-        f (TyClD d@DataDecl{})  = ppData dflags d subdocs-        f (TyClD d@SynDecl{})   = ppSynonym dflags d-        f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs-        f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]-        f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]-        f (SigD sig) = ppSig dflags sig ++ ppFixities-        f _ = []+ppExportD :: DynFlags -> ExportD GhcRn -> [String]+ppExportD dflags+    ExportD+      { expDDecl     = L _ decl+      , expDPats     = bundledPats+      , expDMbDoc    = mbDoc+      , expDSubDocs  = subdocs+      , expDFixities = fixities+      }+  = let+      -- Since Hoogle is line based, we want to avoid breaking long lines.+      dflags' = dflags{ pprCols = maxBound }+    in+      concat+        [ ppDocumentation dflags' dc ++ f d+        | (d, (dc, _)) <- (decl, mbDoc) : bundledPats+        ] ++ ppFixities+  where+    f :: HsDecl GhcRn -> [String]+    f (TyClD _ d@DataDecl{})  = ppData dflags d subdocs+    f (TyClD _ d@SynDecl{})   = ppSynonym dflags d+    f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs+    f (TyClD _ (FamDecl _ d)) = ppFam dflags d+    f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]+    f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]+    f (SigD _ sig) = ppSig dflags sig+    f _ = [] -        ppFixities = concatMap (ppFixity dflags) fixities-ppExport _ _ = []+    ppFixities :: [String]+    ppFixities = concatMap (ppFixity dflags) fixities -ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]-ppSigWithDoc dflags (TypeSig names sig) subdocs-    = concatMap mkDocSig names-    where-        mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n)-                     ++ [pp_sig dflags names (hsSigWcType sig)] -        getDoc :: Located Name -> [Documentation Name]-        getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)--ppSigWithDoc _ _ _ = []+ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String]+ppSigWithDoc dflags sig subdocs = case sig of+    TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names+    PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names+    _ -> []+  where+    mkDocSig leader typ n = mkSubdocN dflags n subdocs+                                      [leader ++ pp_sig dflags [n] typ] -ppSig :: DynFlags -> Sig Name -> [String]+ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x  = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String+pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ)  =-    operator prettyNames ++ " :: " ++ outHsType dflags typ+    operator prettyNames ++ " :: " ++ outHsSigType dflags typ     where       prettyNames = intercalate ", " $ map (out dflags) names  -- note: does not yet output documentation for class methods-ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]-ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) :  ppMethods+ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]+ppClass dflags decl@(ClassDecl {}) subdocs =+  (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}+    ++ ppTyFams) :  ppMethods     where          ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl@@ -165,97 +190,97 @@          ppTyFams             | null $ tcdATs decl = ""-            | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat-                [ map ppr (tcdATs decl)-                , map (ppr . tyFamEqnToSyn . unLoc) (tcdATDefs decl)+            | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat+                [ map pprTyFam (tcdATs decl)+                , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)                 ] +        pprTyFam :: LFamilyDecl GhcRn -> SDoc+        pprTyFam (L _ at) = vcat' $ map text $+            mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at)+         whereWrapper elems = vcat'             [ text "where" <+> lbrace-            , nest 4 . vcat . map (<> semi) $ elems+            , nest 4 . vcat . map (Outputable.<> semi) $ elems             , rbrace             ]--        tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name-        tyFamEqnToSyn tfe = SynDecl-            { tcdLName = tfe_tycon tfe-            , tcdTyVars = tfe_pats tfe-            , tcdRhs = tfe_rhs tfe-            , tcdFVs = emptyNameSet-            }---ppInstance :: DynFlags -> ClsInst -> [String]-ppInstance dflags x =-  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]+ppClass _ _non_cls_decl _ = []+ppFam :: DynFlags -> FamilyDecl GhcRn -> [String]+ppFam dflags decl@(FamilyDecl { fdInfo = info })+  = [out dflags decl']   where-    -- As per #168, we don't want safety information about the class-    -- in Hoogle output. The easiest way to achieve this is to set the-    -- safety information to a state where the Outputable instance-    -- produces no output which means no overlap and unsafe (or [safe]-    -- is generated).-    cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap mempty-                                    , isSafeOverlap = False } }+    decl' = case info of+              -- We don't need to print out a closed type family's equations+              -- for Hoogle, so pretend it doesn't have any.+              ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }+              _                  -> decl -ppSynonym :: DynFlags -> TyClDecl Name -> [String]+ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]-ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs-    = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :-      concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)+ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]+ppData dflags decl@DataDecl { tcdLName = name, tcdTyVars = tvs, tcdFixity = fixity, tcdDataDefn = defn } subdocs+    = out dflags (ppDataDefnHeader (pp_vanilla_decl_head name tvs fixity) defn) :+      concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)     where--        -- GHC gives out "data Bar =", we want to delete the equals-        -- also writes data : a b, when we want data (:) a b-        showData d = unwords $ map f $ if last xs == "=" then init xs else xs-            where-                xs = words $ out dflags d-                nam = out dflags $ tyClDeclLName d-                f w = if w == nam then operator nam else w ppData _ _ _ = panic "ppData"  -- | for constructors, and named-fields...-lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of   Just (d, _) -> ppDocumentation dflags d   _ -> [] -ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]-ppCtor dflags dat subdocs con@ConDeclH98 {}+ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }   -- AZ:TODO get rid of the concatMap-   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'     where-        f (PrefixCon args) = [typeSig name $ args ++ [resType]]-        f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]-        f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat-                          [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++-                           [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]+        f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]+        f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]+        f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat+                          [(concatMap (lookupCon dflags subdocs . noLocA . foExt . unLoc) (cd_fld_names r)) +++                           [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]                           | r <- map unLoc recs] -        funs = foldr1 (\x y -> reL $ HsFunTy x y)-        apps = foldl1 (\x y -> reL $ HsAppTy x y)+        funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)+        apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) -        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)+        typeSig nm flds = operator nm ++ " :: " +++                          outHsSigType dflags (unL $ mkEmptySigType $ funs flds)          -- We print the constructors as comma-separated list. See GHC         -- docs for con_names on why it is a list to begin with.-        name = commaSeparate dflags . map unL $ getConNames con--        resType = apps $ map (reL . HsTyVar . reL) $-                        (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat]+        name = commaSeparate dflags . toList $ unL <$> getConNames con -ppCtor dflags _dat subdocs con@ConDeclGADT {}-   = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f-    where-        f = [typeSig name (hsib_body $ con_type con)]+        tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n+        tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty+        tyVarArg _ = panic "ppCtor" -        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)-        name = out dflags $ map unL $ getConNames con+        resType = apps $ map reL $+                        (HsTyVar noAnn NotPromoted (reL (tcdName dat))) :+                        map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) +ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names+                                        , con_bndrs = L _ outer_bndrs+                                        , con_mb_cxt = mcxt+                                        , con_g_args = args+                                        , con_res_ty = res_ty })+   = concatMap (lookupCon dflags subdocs) names ++ [typeSig]+    where+        typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty+        name = out dflags $ unL <$> names+        con_sig_ty = HsSig noExtField outer_bndrs theta_ty where+          theta_ty = case mcxt of+            Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })+            Nothing -> tau_ty+          tau_ty = foldr mkFunTy res_ty $+            case args of PrefixConGADT pos_args -> map hsScaledThing pos_args+                         RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds+          mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)  ppFixity :: DynFlags -> (Name, Fixity) -> [String]-ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)]+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]   ---------------------------------------------------------------------@@ -278,7 +303,14 @@     lines header ++ ["" | header /= "" && isJust d] ++     maybe [] (showTags . markup (markupTag dflags)) d +mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s +mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s+ where+   getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)+ data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String            deriving Show @@ -304,8 +336,8 @@   markupString               = str,   markupAppend               = (++),   markupIdentifier           = box (TagInline "a") . str . out dflags,-  markupIdentifierUnchecked  = box (TagInline "a") . str . out dflags . snd,-  markupModule               = box (TagInline "a") . str,+  markupIdentifierUnchecked  = box (TagInline "a") . str . showWrapped (out dflags . snd),+  markupModule               = \(ModLink m label) -> box (TagInline "a") (fromMaybe (str m) label),   markupWarning              = box (TagInline "i"),   markupEmphasis             = box (TagInline "i"),   markupBold                 = box (TagInline "b"),@@ -314,14 +346,15 @@   markupMathInline           = const $ str "<math>",   markupMathDisplay          = const $ str "<math>",   markupUnorderedList        = box (TagL 'u'),-  markupOrderedList          = box (TagL 'o'),+  markupOrderedList          = box (TagL 'o') . map snd,   markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),   markupCodeBlock            = box TagPre,-  markupHyperlink            = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),+  markupHyperlink            = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),   markupAName                = const $ str "",   markupProperty             = box TagPre . str,   markupExample              = box TagPre . str . unlines . map exampleToString,-  markupHeader               = \(Header l h) -> box (TagInline $ "h" ++ show l) h+  markupHeader               = \(Header l h) -> box (TagInline $ "h" ++ show l) h,+  markupTable                = \(Table _ _) -> str "TODO: table"   }
src/Haddock/Backends/Hyperlinker.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} module Haddock.Backends.Hyperlinker     ( ppHyperlinkedSource     , module Haddock.Backends.Hyperlinker.Types@@ -6,50 +8,98 @@   import Haddock.Types+import Haddock.Utils (writeUtf8File, out, verbose, Verbosity)+import Haddock.InterfaceFile import Haddock.Backends.Hyperlinker.Renderer+import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils--import Text.XHtml hiding ((</>))+import Haddock.Backends.Xhtml.Utils ( renderToString )  import Data.Maybe import System.Directory import System.FilePath +import GHC.Iface.Ext.Types  ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )+import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )+import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile )+import Data.Map as M+import GHC.Data.FastString     ( mkFastString )+import GHC.Unit.Module         ( Module, moduleName ) + -- | Generate hyperlinked source for given interfaces. -- -- Note that list of interfaces should also contain interfaces normally hidden -- when generating documentation. Otherwise this could lead to dead links in -- produced source.-ppHyperlinkedSource :: FilePath -- ^ Output directory+ppHyperlinkedSource :: Verbosity+                    -> FilePath -- ^ Output directory                     -> FilePath -- ^ Resource directory                     -> Maybe FilePath -- ^ Custom CSS file path                     -> Bool -- ^ Flag indicating whether to pretty-print HTML-                    -> SrcMap -- ^ Paths to sources+                    -> M.Map Module SrcPath -- ^ Paths to sources                     -> [Interface] -- ^ Interfaces for which we create source                     -> IO ()-ppHyperlinkedSource outdir libdir mstyle pretty srcs ifaces = do+ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do     createDirectoryIfMissing True srcdir     let cssFile = fromMaybe (defaultCssFile libdir) mstyle     copyFile cssFile $ srcdir </> srcCssFile     copyFile (libdir </> "html" </> highlightScript) $         srcdir </> highlightScript-    mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces+    mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces   where     srcdir = outdir </> hypSrcDir+    srcs = (srcs', M.mapKeys moduleName srcs')  -- | Generate hyperlinked source for particular interface.-ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface-                          -> IO ()-ppHyperlinkedModuleSource srcdir pretty srcs iface =-    case ifaceTokenizedSrc iface of-        Just tokens -> writeFile path . html . render' $ tokens-        Nothing -> return ()+ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO ()+ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of+    Just hfp -> do+        -- Parse the GHC-produced HIE file+        nc <- freshNameCache+        HieFile { hie_hs_file = file+                , hie_asts = HieASTs asts+                , hie_types = types+                , hie_hs_src = rawSrc+                } <- hie_file_result+                 <$> (readHieFile nc hfp)++        -- Get the AST and tokens corresponding to the source file we want+        let fileFs = mkFastString file+            mast | M.size asts == 1 = snd <$> M.lookupMin asts+                 | otherwise        = M.lookup (HiePath (mkFastString file)) asts+            tokens' = parse df file rawSrc+            ast = fromMaybe (emptyHieAst fileFs) mast+            fullAst = recoverFullIfaceTypes df types ast++        -- Warn if we didn't find an AST, but there were still ASTs+        if M.null asts+          then pure ()+          else out verbosity verbose $ unwords [ "couldn't find ast for"+                                               , file, show (M.keys asts) ]++        -- The C preprocessor can double the backslashes on tokens (see #19236),+        -- which means the source spans will not be comparable and we will not+        -- be able to associate the HieAST with the correct tokens.+        --+        -- We work around this by setting the source span of the tokens to the file+        -- name from the HieAST+        let tokens = fmap (\tk -> tk {tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'++        -- Produce and write out the hyperlinked sources+        writeUtf8File path . renderToString pretty . render' fullAst $ tokens+    Nothing -> return ()   where+    df = ifaceDynFlags iface     render' = render (Just srcCssFile) (Just highlightScript) srcs-    html = if pretty then renderHtml else showHtml     path = srcdir </> hypSrcModuleFile (ifaceMod iface)++    emptyHieAst fileFs = Node+      { nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0)+      , nodeChildren = []+      , sourcedNodeInfo = SourcedNodeInfo mempty+      }  -- | Name of CSS file in output directory. srcCssFile :: FilePath
− src/Haddock/Backends/Hyperlinker/Ast.hs 
@@ -1,185 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}---module Haddock.Backends.Hyperlinker.Ast (enrich) where---import Haddock.Syb-import Haddock.Backends.Hyperlinker.Types--import qualified GHC--import Control.Applicative-import Data.Data-import Data.Maybe----- | Add more detailed information to token stream using GHC API.-enrich :: GHC.RenamedSource -> [Token] -> [RichToken]-enrich src =-    map $ \token -> RichToken-        { rtkToken = token-        , rtkDetails = enrichToken token detailsMap-        }-  where-    detailsMap = concatMap ($ src)-        [ variables-        , types-        , decls-        , binds-        , imports-        ]---- | A map containing association between source locations and "details" of--- this location.------ For the time being, it is just a list of pairs. However, looking up things--- in such structure has linear complexity. We cannot use any hashmap-like--- stuff because source locations are not ordered. In the future, this should--- be replaced with interval tree data structure.-type DetailsMap = [(GHC.SrcSpan, TokenDetails)]--lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)--enrichToken :: Token -> DetailsMap -> Maybe TokenDetails-enrichToken (Token typ _ spn) dm-    | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm-enrichToken _ _ = Nothing---- | Obtain details map for variables ("normally" used identifiers).-variables :: GHC.RenamedSource -> DetailsMap-variables =-    everything (<|>) (var `combine` rec)-  where-    var term = case cast term of-        (Just (GHC.L sspan (GHC.HsVar name))) ->-            pure (sspan, RtkVar (GHC.unLoc name))-        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->-            pure (sspan, RtkVar name)-        _ -> empty-    rec term = case cast term of-        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->-            pure (sspan, RtkVar name)-        _ -> empty---- | Obtain details map for types.-types :: GHC.RenamedSource -> DetailsMap-types =-    everything (<|>) ty-  where-    ty term = case cast term of-        (Just (GHC.L sspan (GHC.HsTyVar name))) ->-            pure (sspan, RtkType (GHC.unLoc name))-        _ -> empty---- | Obtain details map for identifier bindings.------ That includes both identifiers bound by pattern matching or declared using--- ordinary assignment (in top-level declarations, let-expressions and where--- clauses).-binds :: GHC.RenamedSource -> DetailsMap-binds =-    everything (<|>) (fun `combine` pat `combine` tvar)-  where-    fun term = case cast term of-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->-            pure (sspan, RtkBind name)-        _ -> empty-    pat term = case cast term of-        (Just (GHC.L sspan (GHC.VarPat name))) ->-            pure (sspan, RtkBind (GHC.unLoc name))-        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->-            [(sspan, RtkVar name)] ++ everything (<|>) rec recs-        (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->-            pure (sspan, RtkBind name)-        _ -> empty-    rec term = case cast term of-        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->-            pure (sspan, RtkVar name)-        _ -> empty-    tvar term = case cast term of-        (Just (GHC.L sspan (GHC.UserTyVar name))) ->-            pure (sspan, RtkBind (GHC.unLoc name))-        (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->-            pure (sspan, RtkBind name)-        _ -> empty---- | Obtain details map for top-level declarations.-decls :: GHC.RenamedSource -> DetailsMap-decls (group, _, _, _) = concatMap ($ group)-    [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds-    , everything (<|>) fun . GHC.hs_valds-    , everything (<|>) (con `combine` ins)-    ]-  where-    typ (GHC.L _ t) = case t of-        GHC.DataDecl { tcdLName = name } -> pure . decl $ name-        GHC.SynDecl name _ _ _ -> pure . decl $ name-        GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam-        GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs-    fun term = case cast term of-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))-            | GHC.isExternalName name -> pure (sspan, RtkDecl name)-        _ -> empty-    con term = case cast term of-        (Just cdcl) ->-            map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl-        Nothing -> empty-    ins term = case cast term of-        (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst-        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->-            pure . tyref $ GHC.tfe_tycon eqn-        _ -> empty-    fld term = case cast term of-        Just (field :: GHC.ConDeclField GHC.Name)-          -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field-        Nothing -> empty-    sig (GHC.L _ (GHC.TypeSig names _)) = map decl names-    sig _ = []-    decl (GHC.L sspan name) = (sspan, RtkDecl name)-    tyref (GHC.L sspan name) = (sspan, RtkType name)---- | Obtain details map for import declarations.------ This map also includes type and variable details for items in export and--- import lists.-imports :: GHC.RenamedSource -> DetailsMap-imports src@(_, imps, _, _) =-    everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps-  where-    ie term = case cast term of-        (Just (GHC.IEVar v)) -> pure $ var v-        (Just (GHC.IEThingAbs t)) -> pure $ typ t-        (Just (GHC.IEThingAll t)) -> pure $ typ t-        (Just (GHC.IEThingWith t _ vs _fls)) ->-          [typ t] ++ map var vs-        _ -> empty-    typ (GHC.L sspan name) = (sspan, RtkType name)-    var (GHC.L sspan name) = (sspan, RtkVar name)-    imp idecl | not . GHC.ideclImplicit $ idecl =-        let (GHC.L sspan name) = GHC.ideclName idecl-        in Just (sspan, RtkModule name)-    imp _ = Nothing---- | Check whether token stream span matches GHC source span.------ Currently, it is implemented as checking whether "our" span is contained--- in GHC span. The reason for that is because GHC span are generally wider--- and may spread across couple tokens. For example, @(>>=)@ consists of three--- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable--- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@--- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span--- associated with @quux@ contains all five elements.-matches :: Span -> GHC.SrcSpan -> Bool-matches tspan (GHC.RealSrcSpan aspan)-    | saspan <= stspan && etspan <= easpan = True-  where-    stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)-    etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)-    saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)-    easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)-matches _ _ = False
src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -1,214 +1,406 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where +import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import Control.Applicative ( Alternative(..) )+import Data.List           ( isPrefixOf, isSuffixOf ) -import Data.Char-import Data.List-import Data.Maybe+import qualified Data.ByteString as BS -import Haddock.Backends.Hyperlinker.Types+import GHC.Platform+import GHC.Types.SourceText+import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic+import GHC.Utils.Error     ( pprLocMsgEnvelopeDefault )+import GHC.Data.FastString ( mkFastString )+import GHC.Parser.Errors.Ppr ()+import qualified GHC.Types.Error as E+import GHC.Parser.Lexer    as Lexer+                           ( P(..), ParseResult(..), PState(..), Token(..)+                           , initParserState, lexer, mkParserOpts, getPsErrorMessages)+import GHC.Data.Bag         ( bagToList )+import GHC.Utils.Outputable ( text, ($$) )+import GHC.Utils.Panic      ( panic )+import GHC.Driver.Ppr       ( showSDoc )+import GHC.Types.SrcLoc+import GHC.Data.StringBuffer ( StringBuffer, atEnd ) +import Haddock.Backends.Hyperlinker.Types as T+import Haddock.GhcUtils  -- | Turn source code string into a stream of more descriptive tokens. ----- Result should retain original file layout (including comments, whitespace,--- etc.), i.e. the following "law" should hold:------ @concat . map 'tkValue' . 'parse' = id@-parse :: String -> [Token]-parse = tokenize . tag . chunk---- | Split raw source string to more meaningful chunks.------ This is the initial stage of tokenization process. Each chunk is either--- a comment (including comment delimiters), a whitespace string, preprocessor--- macro (and all its content until the end of a line) or valid Haskell lexeme.-chunk :: String -> [String]-chunk [] = []-chunk str@(c:_)-    | isSpace c =-        let (space, mcpp, rest) = spanSpaceOrCpp str-        in [space] ++ maybeToList mcpp ++ chunk rest-chunk str-    | "--" `isPrefixOf` str = chunk' $ spanToNewline str-    | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str-    | otherwise = case lex' str of-        (tok:_) -> chunk' tok-        [] -> [str]+-- Result should retain original file layout (including comments,+-- whitespace, and CPP).+parse+  :: DynFlags      -- ^ Flags for this module+  -> FilePath      -- ^ Path to the source of this module+  -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module+  -> [T.Token]+parse dflags fpath bs = case unP (go False []) initState of+    POk _ toks -> reverse toks+    PFailed pst ->+      let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in+      panic $ showSDoc dflags $+        text "Hyperlinker parse error:" $$ pprLocMsgEnvelopeDefault err   where-    chunk' (c, rest) = c:(chunk rest) --- | A bit better lexer then the default, i.e. handles DataKinds quotes-lex' :: ReadS String-lex' ('\'' : '\'' : rest)              = [("''", rest)]-lex' str@('\'' : '\\' : _ : '\'' : _)  = lex str-lex' str@('\'' : _ : '\'' : _)         = lex str-lex' ('\'' : rest)                     = [("'", rest)]-lex' str                               = lex str+    initState = initParserState pflags buf start+    buf = stringBufferFromByteString bs+    start = mkRealSrcLoc (mkFastString fpath) 1 1+    arch_os = platformArchOS (targetPlatform dflags)+    pflags = mkParserOpts   (extensionFlags dflags)+                            (initDiagOpts dflags)+                            (supportedLanguagesAndExtensions arch_os)+                            (safeImportsOn dflags)+                            False -- lex Haddocks as comment tokens+                            True  -- produce comment tokens+                            False -- produce position pragmas tokens --- | Split input to "first line" string and the rest of it.------ Ideally, this should be done simply with @'break' (== '\n')@. However,--- Haskell also allows line-unbreaking (or whatever it is called) so things--- are not as simple and this function deals with that.-spanToNewline :: String -> (String, String)-spanToNewline [] = ([], [])-spanToNewline ('\\':'\n':str) =-    let (str', rest) = spanToNewline str-    in ('\\':'\n':str', rest)-spanToNewline str@('\n':_) = ("", str)-spanToNewline (c:str) =-    let (str', rest) = spanToNewline str-    in (c:str', rest)+    go :: Bool        -- ^ are we currently in a pragma?+       -> [T.Token]   -- ^ tokens accumulated so far (in reverse)+       -> P [T.Token]+    go inPrag toks = do+      (b, _) <- getInput+      if not (atEnd b)+        then do+          mtok <- runMaybeT (parseCppLine <|> parsePlainTok inPrag)+          (newToks, inPrag') <- case mtok of+            Nothing -> unknownLine+            Just a -> pure a+          go inPrag' (newToks ++ toks)+        else+          pure toks --- | Split input to whitespace string, (optional) preprocessor directive and--- the rest of it.------ Again, using something like @'span' 'isSpace'@ would be nice to chunk input--- to whitespace. The problem is with /#/ symbol - if it is placed at the very--- beginning of a line, it should be recognized as preprocessor macro. In any--- other case, it is ordinary Haskell symbol and can be used to declare--- operators. Hence, while dealing with whitespace we also check whether there--- happens to be /#/ symbol just after a newline character - if that is the--- case, we begin treating the whole line as preprocessor macro.-spanSpaceOrCpp :: String -> (String, Maybe String, String)-spanSpaceOrCpp ('\n':'#':str) =-    let (str', rest) = spanToNewline str-    in ("\n", Just $ '#':str', rest)-spanSpaceOrCpp (c:str')-    | isSpace c =-        let (space, mcpp, rest) = spanSpaceOrCpp str'-        in (c:space, mcpp, rest)-spanSpaceOrCpp str = ("", Nothing, str)+    -- | Like 'Lexer.lexer', but slower, with a better API, and filtering out empty tokens+    wrappedLexer :: P (RealLocated Lexer.Token)+    wrappedLexer = Lexer.lexer False andThen+      where andThen (L (RealSrcSpan s _) t)+              | srcSpanStartLine s /= srcSpanEndLine s ||+                srcSpanStartCol s /= srcSpanEndCol s+              = pure (L s t)+            andThen (L (RealSrcSpan s _) ITeof) = pure (L s ITeof)+            andThen _ = wrappedLexer --- | Split input to comment content (including delimiters) and the rest.------ Again, some more logic than simple 'span' is required because of Haskell--- comment nesting policy.-chunkComment :: Int -> String -> (String, String)-chunkComment _ [] = ("", "")-chunkComment depth ('{':'-':str) =-    let (c, rest) = chunkComment (depth + 1) str-    in ("{-" ++ c, rest)-chunkComment depth ('-':'}':str)-    | depth == 1 = ("-}", str)-    | otherwise =-        let (c, rest) = chunkComment (depth - 1) str-        in ("-}" ++ c, rest)-chunkComment depth (e:str) =-    let (c, rest) = chunkComment depth str-    in (e:c, rest)+    -- | Try to parse a CPP line (can fail)+    parseCppLine :: MaybeT P ([T.Token], Bool)+    parseCppLine = MaybeT $ do+      (b, l) <- getInput+      case tryCppLine l b of+        Just (cppBStr, l', b')+             -> let cppTok = T.Token { tkType = TkCpp+                                     , tkValue = cppBStr+                                     , tkSpan = mkRealSrcSpan l l' }+                in setInput (b', l') *> pure (Just ([cppTok], False))+        _    -> return Nothing --- | Assign source location for each chunk in given stream.-tag :: [String] -> [(Span, String)]-tag =-    reverse . snd . foldl aux (Position 1 1, [])-  where-    aux (pos, cs) str =-        let pos' = foldl move pos str-        in (pos', (Span pos pos', str):cs)-    move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }-    move pos _ = pos { posCol = posCol pos + 1 }+    -- | Try to parse a regular old token (can fail)+    parsePlainTok :: Bool -> MaybeT P ([T.Token], Bool)  -- return list is only ever 0-2 elements+    parsePlainTok inPrag = do+      (bInit, lInit) <- lift getInput+      L sp tok <- tryP (Lexer.lexer False return)+      (bEnd, _) <- lift getInput+      case sp of+        UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed+        RealSrcSpan rsp _ -> do+          let typ = if inPrag then TkPragma else classify tok+              RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real+              (spaceBStr, bStart) = spanPosition lInit lStart bInit+              inPragDef = inPragma inPrag tok --- | Turn unrecognised chunk stream to more descriptive token stream.-tokenize :: [(Span, String)] -> [Token]-tokenize =-    map aux-  where-    aux (sp, str) = Token-        { tkType = classify str-        , tkValue = str-        , tkSpan = sp-        }+          (bEnd', inPrag') <- case tok of --- | Classify given string as appropriate Haskell token.------ This method is based on Haskell 98 Report lexical structure description:--- https://www.haskell.org/onlinereport/lexemes.html------ However, this is probably far from being perfect and most probably does not--- handle correctly all corner cases.-classify :: String -> TokenType-classify str-    | "--" `isPrefixOf` str = TkComment-    | "{-#" `isPrefixOf` str = TkPragma-    | "{-" `isPrefixOf` str = TkComment-classify "''" = TkSpecial-classify "'"  = TkSpecial-classify str@(c:_)-    | isSpace c = TkSpace-    | isDigit c = TkNumber-    | c `elem` special = TkSpecial-    | str `elem` glyphs = TkGlyph-    | all (`elem` symbols) str = TkOperator-    | c == '#' = TkCpp-    | c == '"' = TkString-    | c == '\'' = TkChar-classify str-    | str `elem` keywords = TkKeyword-    | isIdentifier str = TkIdentifier-    | otherwise = TkUnknown+            -- Update internal line + file position if this is a LINE pragma+            ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do+              L _ (ITinteger (IL { il_value = line })) <- tryP wrappedLexer+              L _ (ITstring _ file)                    <- tryP wrappedLexer+              L spF ITclose_prag                       <- tryP wrappedLexer -keywords :: [String]-keywords =-    [ "as"-    , "case"-    , "class"-    , "data"-    , "default"-    , "deriving"-    , "do"-    , "else"-    , "hiding"-    , "if"-    , "import"-    , "in"-    , "infix"-    , "infixl"-    , "infixr"-    , "instance"-    , "let"-    , "module"-    , "newtype"-    , "of"-    , "qualified"-    , "then"-    , "type"-    , "where"-    , "forall"-    , "family"-    , "mdo"-    ]+              let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF)+              (bEnd'', _) <- lift getInput+              lift $ setInput (bEnd'', newLoc) -glyphs :: [String]-glyphs =-    [ ".."-    , ":"-    , "::"-    , "="-    , "\\"-    , "|"-    , "<-"-    , "->"-    , "@"-    , "~"-    , "~#"-    , "=>"-    , "-"-    , "!"-    ]+              pure (bEnd'', False) -special :: [Char]-special = "()[]{},;`"+            -- Update internal column position if this is a COLUMN pragma+            ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do+              L _ (ITinteger (IL { il_value = col }))  <- tryP wrappedLexer+              L spF ITclose_prag                       <- tryP wrappedLexer --- TODO: Add support for any Unicode symbol or punctuation.--- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators-symbols :: [Char]-symbols = "!#$%&*+./<=>?@\\^|-~:"+              let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col)+              (bEnd'', _) <- lift getInput+              lift $ setInput (bEnd'', newLoc) -isIdentifier :: String -> Bool-isIdentifier (s:str)-    | (isLower' s || isUpper s) && all isAlphaNum' str = True-  where-    isLower' c = isLower c || c == '_'-    isAlphaNum' c = isAlphaNum c || c == '_' || c == '\''-isIdentifier _ = False+              pure (bEnd'', False)++            _ -> pure (bEnd, inPragDef)++          let tokBStr = splitStringBuffer bStart bEnd'+              plainTok = T.Token { tkType = typ+                                 , tkValue = tokBStr+                                 , tkSpan = rsp }+              spaceTok = T.Token { tkType = TkSpace+                                 , tkValue = spaceBStr+                                 , tkSpan = mkRealSrcSpan lInit lStart }++          pure (plainTok : [ spaceTok | not (BS.null spaceBStr) ], inPrag')++    -- | Parse whatever remains of the line as an unknown token (can't fail)+    unknownLine :: P ([T.Token], Bool)+    unknownLine = do+      (b, l) <- getInput+      let (unkBStr, l', b') = spanLine l b+          unkTok = T.Token { tkType = TkUnknown+                           , tkValue = unkBStr+                           , tkSpan = mkRealSrcSpan l l' }+      setInput (b', l')+      pure ([unkTok], False)+++-- | Get the input+getInput :: P (StringBuffer, RealSrcLoc)+getInput = P $ \p@PState { buffer = buf, loc = srcLoc } -> POk p (buf, psRealLoc srcLoc)++-- | Set the input+setInput :: (StringBuffer, RealSrcLoc) -> P ()+setInput (buf, srcLoc) =+  P $ \p@PState{ loc = PsLoc _ buf_loc } ->+    POk (p { buffer = buf, loc = PsLoc srcLoc buf_loc }) ()++tryP :: P a -> MaybeT P a+tryP (P f) = MaybeT $ P $ \s -> case f s of+  POk s' a -> POk s' (Just a)+  PFailed _ -> POk s Nothing++tryOrElse :: Alternative f => a -> f a -> f a+tryOrElse x p = p <|> pure x++-- | Classify given tokens as appropriate Haskell token type.+classify :: Lexer.Token -> TokenType+classify tok =+  case tok of+    ITas                   -> TkKeyword+    ITcase                 -> TkKeyword+    ITclass                -> TkKeyword+    ITdata                 -> TkKeyword+    ITdefault              -> TkKeyword+    ITderiving             -> TkKeyword+    ITdo                {} -> TkKeyword+    ITelse                 -> TkKeyword+    IThiding               -> TkKeyword+    ITforeign              -> TkKeyword+    ITif                   -> TkKeyword+    ITimport               -> TkKeyword+    ITin                   -> TkKeyword+    ITinfix                -> TkKeyword+    ITinfixl               -> TkKeyword+    ITinfixr               -> TkKeyword+    ITinstance             -> TkKeyword+    ITlet                  -> TkKeyword+    ITmodule               -> TkKeyword+    ITnewtype              -> TkKeyword+    ITof                   -> TkKeyword+    ITqualified            -> TkKeyword+    ITthen                 -> TkKeyword+    ITtype                 -> TkKeyword+    ITvia                  -> TkKeyword+    ITwhere                -> TkKeyword++    ITforall            {} -> TkKeyword+    ITexport               -> TkKeyword+    ITlabel                -> TkKeyword+    ITdynamic              -> TkKeyword+    ITsafe                 -> TkKeyword+    ITinterruptible        -> TkKeyword+    ITunsafe               -> TkKeyword+    ITstdcallconv          -> TkKeyword+    ITccallconv            -> TkKeyword+    ITcapiconv             -> TkKeyword+    ITprimcallconv         -> TkKeyword+    ITjavascriptcallconv   -> TkKeyword+    ITmdo               {} -> TkKeyword+    ITfamily               -> TkKeyword+    ITrole                 -> TkKeyword+    ITgroup                -> TkKeyword+    ITby                   -> TkKeyword+    ITusing                -> TkKeyword+    ITpattern              -> TkKeyword+    ITstatic               -> TkKeyword+    ITstock                -> TkKeyword+    ITanyclass             -> TkKeyword++    ITunit                 -> TkKeyword+    ITsignature            -> TkKeyword+    ITdependency           -> TkKeyword+    ITrequires             -> TkKeyword++    ITinline_prag       {} -> TkPragma+    ITopaque_prag       {} -> TkPragma+    ITspec_prag         {} -> TkPragma+    ITspec_inline_prag  {} -> TkPragma+    ITsource_prag       {} -> TkPragma+    ITrules_prag        {} -> TkPragma+    ITwarning_prag      {} -> TkPragma+    ITdeprecated_prag   {} -> TkPragma+    ITline_prag         {} -> TkPragma+    ITcolumn_prag       {} -> TkPragma+    ITscc_prag          {} -> TkPragma+    ITunpack_prag       {} -> TkPragma+    ITnounpack_prag     {} -> TkPragma+    ITann_prag          {} -> TkPragma+    ITcomplete_prag     {} -> TkPragma+    ITclose_prag           -> TkPragma+    IToptions_prag      {} -> TkPragma+    ITinclude_prag      {} -> TkPragma+    ITlanguage_prag        -> TkPragma+    ITminimal_prag      {} -> TkPragma+    IToverlappable_prag {} -> TkPragma+    IToverlapping_prag  {} -> TkPragma+    IToverlaps_prag     {} -> TkPragma+    ITincoherent_prag   {} -> TkPragma+    ITctype             {} -> TkPragma++    ITdotdot               -> TkGlyph+    ITcolon                -> TkGlyph+    ITdcolon            {} -> TkGlyph+    ITequal                -> TkGlyph+    ITlam                  -> TkGlyph+    ITlcase                -> TkGlyph+    ITlcases               -> TkGlyph+    ITvbar                 -> TkGlyph+    ITlarrow            {} -> TkGlyph+    ITrarrow            {} -> TkGlyph+    ITlolly             {} -> TkGlyph+    ITat                   -> TkGlyph+    ITtilde                -> TkGlyph+    ITdarrow            {} -> TkGlyph+    ITminus                -> TkGlyph+    ITprefixminus          -> TkGlyph+    ITbang                 -> TkGlyph+    ITdot                  -> TkOperator+    ITproj              {} -> TkOperator+    ITstar              {} -> TkOperator+    ITtypeApp              -> TkGlyph+    ITpercent              -> TkGlyph++    ITbiglam               -> TkGlyph++    ITocurly               -> TkSpecial+    ITccurly               -> TkSpecial+    ITvocurly              -> TkSpecial+    ITvccurly              -> TkSpecial+    ITobrack               -> TkSpecial+    ITopabrack             -> TkSpecial+    ITcpabrack             -> TkSpecial+    ITcbrack               -> TkSpecial+    IToparen               -> TkSpecial+    ITcparen               -> TkSpecial+    IToubxparen            -> TkSpecial+    ITcubxparen            -> TkSpecial+    ITsemi                 -> TkSpecial+    ITcomma                -> TkSpecial+    ITunderscore           -> TkIdentifier+    ITbackquote            -> TkSpecial+    ITsimpleQuote          -> TkSpecial++    ITvarid             {} -> TkIdentifier+    ITconid             {} -> TkIdentifier+    ITvarsym            {} -> TkOperator+    ITconsym            {} -> TkOperator+    ITqvarid            {} -> TkIdentifier+    ITqconid            {} -> TkIdentifier+    ITqvarsym           {} -> TkOperator+    ITqconsym           {} -> TkOperator++    ITdupipvarid        {} -> TkUnknown+    ITlabelvarid        {} -> TkUnknown++    ITchar              {} -> TkChar+    ITstring            {} -> TkString+    ITinteger           {} -> TkNumber+    ITrational          {} -> TkNumber++    ITprimchar          {} -> TkChar+    ITprimstring        {} -> TkString+    ITprimint           {} -> TkNumber+    ITprimword          {} -> TkNumber+    ITprimfloat         {} -> TkNumber+    ITprimdouble        {} -> TkNumber++    ITopenExpQuote      {} -> TkSpecial+    ITopenPatQuote         -> TkSpecial+    ITopenDecQuote         -> TkSpecial+    ITopenTypQuote         -> TkSpecial+    ITcloseQuote        {} -> TkSpecial+    ITopenTExpQuote     {} -> TkSpecial+    ITcloseTExpQuote       -> TkSpecial+    ITdollar               -> TkSpecial+    ITdollardollar         -> TkSpecial+    ITtyQuote              -> TkSpecial+    ITquasiQuote        {} -> TkUnknown+    ITqQuasiQuote       {} -> TkUnknown++    ITproc                 -> TkKeyword+    ITrec                  -> TkKeyword+    IToparenbar         {} -> TkGlyph+    ITcparenbar         {} -> TkGlyph+    ITlarrowtail        {} -> TkGlyph+    ITrarrowtail        {} -> TkGlyph+    ITLarrowtail        {} -> TkGlyph+    ITRarrowtail        {} -> TkGlyph++    ITcomment_line_prag    -> TkUnknown+    ITunknown           {} -> TkUnknown+    ITeof                  -> TkUnknown++    ITlineComment       {} -> TkComment+    ITdocComment        {} -> TkComment+    ITdocOptions        {} -> TkComment++    -- The lexer considers top-level pragmas as comments (see `pragState` in+    -- the GHC lexer for more), so we have to manually reverse this. The+    -- following is a hammer: it smashes _all_ pragma-like block comments into+    -- pragmas.+    ITblockComment c _+      | isPrefixOf "{-#" c+      , isSuffixOf "#-}" c -> TkPragma+      | otherwise          -> TkComment++-- | Classify given tokens as beginning pragmas (or not).+inPragma :: Bool           -- ^ currently in pragma+         -> Lexer.Token    -- ^ current token+         -> Bool           -- ^ new information about whether we are in a pragma+inPragma _ ITclose_prag = False+inPragma True _ = True+inPragma False tok =+  case tok of+    ITinline_prag       {} -> True+    ITopaque_prag       {} -> True+    ITspec_prag         {} -> True+    ITspec_inline_prag  {} -> True+    ITsource_prag       {} -> True+    ITrules_prag        {} -> True+    ITwarning_prag      {} -> True+    ITdeprecated_prag   {} -> True+    ITline_prag         {} -> True+    ITcolumn_prag       {} -> True+    ITscc_prag          {} -> True+    ITunpack_prag       {} -> True+    ITnounpack_prag     {} -> True+    ITann_prag          {} -> True+    ITcomplete_prag     {} -> True+    IToptions_prag      {} -> True+    ITinclude_prag      {} -> True+    ITlanguage_prag        -> True+    ITminimal_prag      {} -> True+    IToverlappable_prag {} -> True+    IToverlapping_prag  {} -> True+    IToverlaps_prag     {} -> True+    ITincoherent_prag   {} -> True+    ITctype             {} -> True++    _                      -> False+
src/Haddock/Backends/Hyperlinker/Renderer.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE RecordWildCards #-}-+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}  module Haddock.Backends.Hyperlinker.Renderer (render) where @@ -7,16 +9,21 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils -import qualified GHC-import qualified Name as GHC-import qualified Unique as GHC+import qualified Data.ByteString as BS +import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo )+import GHC.Unit.Module ( ModuleName, moduleNameString )+import GHC.Types.Name   ( getOccString, isInternalName, Name, nameModule, nameUnique )+import GHC.Types.SrcLoc+import GHC.Types.Unique ( getKey )+import GHC.Utils.Encoding ( utf8DecodeByteString )+ import System.FilePath.Posix ((</>)) -import Data.List-import Data.Maybe-import Data.Monoid import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List  import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html@@ -24,48 +31,24 @@  type StyleClass = String --render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]-       -> Html-render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens---data TokenGroup-    = GrpNormal Token-    | GrpRich TokenDetails [Token]----- | Group consecutive tokens pointing to the same element.------ We want to render qualified identifiers as one entity. For example,--- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for--- better user experience when highlighting and clicking links, these tokens--- should be regarded as one identifier. Therefore, before rendering we must--- group consecutive elements pointing to the same 'GHC.Name' (note that even--- dot token has it if it is part of qualified name).-groupTokens :: [RichToken] -> [TokenGroup]-groupTokens [] = []-groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)-groupTokens ((RichToken tok (Just det)):rest) =-    let (grp, rest') = span same rest-    in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')-  where-    same (RichToken _ (Just det')) = det == det'-    same _ = False-+-- | Produce the HTML corresponding to a hyperlinked Haskell source+render+  :: Maybe FilePath    -- ^ path to the CSS file+  -> Maybe FilePath    -- ^ path to the JS file+  -> SrcMaps            -- ^ Paths to sources+  -> HieAST PrintedType  -- ^ ASTs from @.hie@ files+  -> [Token]       -- ^ tokens to render+  -> Html+render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens -body :: SrcMap -> [RichToken] -> Html-body srcs tokens =-    Html.body . Html.pre $ hypsrc+body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html+body srcs ast tokens = Html.body . Html.pre $ hypsrc   where-    hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens-+    hypsrc = renderWithAst srcs ast tokens  header :: Maybe FilePath -> Maybe FilePath -> Html-header mcss mjs-    | isNothing mcss && isNothing mjs = Html.noHtml-header mcss mjs =-    Html.header $ css mcss <> js mjs+header Nothing Nothing = Html.noHtml+header mcss mjs = Html.header $ css mcss <> js mjs   where     css Nothing = Html.noHtml     css (Just cssFile) = Html.thelink Html.noHtml !@@ -80,34 +63,137 @@         ]  -tokenGroup :: SrcMap -> TokenGroup -> Html-tokenGroup _ (GrpNormal tok@(Token { .. }))-    | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue-    | otherwise = tokenSpan tok ! attrs+splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token])+splitTokens ast toks = (before,during,after)   where-    attrs = [ multiclass . tokenStyle $ tkType ]-tokenGroup srcs (GrpRich det tokens) =-    externalAnchor det . internalAnchor det . hyperlink srcs det $ content+    (before,rest) = span leftOf toks+    (during,after) = span inAst rest+    leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp+    inAst t = nodeSp `containsSpan` tkSpan t+    nodeSp = nodeSpan ast++-- | Turn a list of tokens into hyperlinked sources, threading in relevant link+-- information from the 'HieAST'.+renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html+renderWithAst srcs Node{..} toks = anchored $ case toks of++    [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok++    -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators+    -- as multiple tokens.+    --+    --  * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens)+    --  * @(+) 1 2@    turns into @[(, +, ), 1, 2]@    (excluding space tokens)+    --+    -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In+    -- order to make sure these get hyperlinked properly, we intercept these+    -- special sequences of tokens and merge them into just one identifier or+    -- operator token.+    [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2]+          | realSrcSpanStart s1 == realSrcSpanStart nodeSpan+          , realSrcSpanEnd s2   == realSrcSpanEnd nodeSpan+          -> richToken srcs nodeInfo+                       (Token{ tkValue = "`" <> tkValue tok <> "`"+                             , tkType = TkOperator+                             , tkSpan = nodeSpan })+    [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2]+          | realSrcSpanStart s1 == realSrcSpanStart nodeSpan+          , realSrcSpanEnd s2   == realSrcSpanEnd nodeSpan+          -> richToken srcs nodeInfo+                       (Token{ tkValue = "(" <> tkValue tok <> ")"+                             , tkType = TkOperator+                             , tkSpan = nodeSpan })++    _ -> go nodeChildren toks   where-    content = mconcat . map (richToken det) $ tokens+    nodeInfo = maybe emptyNodeInfo id (Map.lookup SourceInfo $ getSourcedNodeInfo sourcedNodeInfo)+    go _ [] = mempty+    go [] xs = foldMap renderToken xs+    go (cur:rest) xs =+        foldMap renderToken before <> renderWithAst srcs cur during <> go rest after+      where+        (before,during,after) = splitTokens cur xs+    anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo)+    anchorOne n dets c = externalAnchor n d $ internalAnchor n d c+      where d = identInfo dets +renderToken :: Token -> Html+renderToken Token{..}+    | BS.null tkValue = mempty+    | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'+    | otherwise = tokenSpan ! [ multiclass style ]+  where+    tkValue' = filterCRLF $ utf8DecodeByteString tkValue+    style = tokenStyle tkType+    tokenSpan = Html.thespan (Html.toHtml tkValue') -richToken :: TokenDetails -> Token -> Html-richToken det tok =-    tokenSpan tok ! [ multiclass style ]++-- | Given information about the source position of definitions, render a token+richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html+richToken srcs details Token{..}+    | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'+    | otherwise = annotate details $ linked content   where-    style = (tokenStyle . tkType) tok ++ richTokenStyle det+    tkValue' = filterCRLF $ utf8DecodeByteString tkValue+    content = tokenSpan ! [ multiclass style ]+    tokenSpan = Html.thespan (Html.toHtml tkValue')+    style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts +    contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details -tokenSpan :: Token -> Html-tokenSpan = Html.thespan . Html.toHtml . tkValue+    -- pick an arbitrary non-evidence identifier to hyperlink with+    identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details+    notEvidence = not . any isEvidenceContext . identInfo +    -- If we have name information, we can make links+    linked = case identDet of+      Just (n,_) -> hyperlink srcs n+      Nothing -> id -richTokenStyle :: TokenDetails -> [StyleClass]-richTokenStyle (RtkVar _) = ["hs-var"]-richTokenStyle (RtkType _) = ["hs-type"]-richTokenStyle _ = []+-- | Remove CRLFs from source+filterCRLF :: String -> String+filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs+filterCRLF (c:cs) = c : filterCRLF cs+filterCRLF [] = [] +annotate :: NodeInfo PrintedType -> Html -> Html+annotate  ni content =+    Html.thespan (annot <> content) ! [ Html.theclass "annot" ]+  where+    annot+      | not (null annotation) =+          Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ]+      | otherwise = mempty+    annotation = typ ++ identTyps+    typ = unlines (nodeType ni)+    typedIdents = [ (n,t) | (n, c@(identType -> Just t)) <- Map.toList $ nodeIdentifiers ni+                          , not (any isEvidenceContext $ identInfo c) ]+    identTyps+      | length typedIdents > 1 || null (nodeType ni)+          = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents+      | otherwise = ""++    printName :: Either ModuleName Name -> String+    printName = either moduleNameString getOccString++richTokenStyle+  :: Bool         -- ^ are we lacking a type annotation?+  -> ContextInfo  -- ^ in what context did this token show up?+  -> [StyleClass]+richTokenStyle True  Use               = ["hs-type"]+richTokenStyle False Use               = ["hs-var"]+richTokenStyle  _    RecField{}        = ["hs-var"]+richTokenStyle  _    PatternBind{}     = ["hs-var"]+richTokenStyle  _    MatchBind{}       = ["hs-var"]+richTokenStyle  _    TyVarBind{}       = ["hs-type"]+richTokenStyle  _    ValBind{}         = ["hs-var"]+richTokenStyle  _    TyDecl            = ["hs-type"]+richTokenStyle  _    ClassTyDecl{}     = ["hs-type"]+richTokenStyle  _    Decl{}            = ["hs-var"]+richTokenStyle  _    IEThing{}         = []  -- could be either a value or type+richTokenStyle  _    EvidenceVarBind{} = []+richTokenStyle  _    EvidenceVarUse{}  = []+ tokenStyle :: TokenType -> [StyleClass] tokenStyle TkIdentifier = ["hs-identifier"] tokenStyle TkKeyword = ["hs-keyword"]@@ -124,59 +210,78 @@ tokenStyle TkUnknown = []  multiclass :: [StyleClass] -> HtmlAttr-multiclass = Html.theclass . intercalate " "+multiclass = Html.theclass . unwords -externalAnchor :: TokenDetails -> Html -> Html-externalAnchor (RtkDecl name) content =-    Html.anchor content ! [ Html.name $ externalAnchorIdent name ]-externalAnchor _ content = content+externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html+externalAnchor (Right name) contexts content+  | not (isInternalName name)+  , any isBinding contexts+  = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ]+externalAnchor _ _ content = content -internalAnchor :: TokenDetails -> Html -> Html-internalAnchor (RtkBind name) content =-    Html.anchor content ! [ Html.name $ internalAnchorIdent name ]-internalAnchor _ content = content+isBinding :: ContextInfo -> Bool+isBinding (ValBind RegularBind _ _) = True+isBinding PatternBind{} = True+isBinding Decl{} = True+isBinding (RecField RecFieldDecl _) = True+isBinding TyVarBind{} = True+isBinding ClassTyDecl{} = True+isBinding _ = False -externalAnchorIdent :: GHC.Name -> String-externalAnchorIdent = hypSrcNameUrl+internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html+internalAnchor (Right name) contexts content+  | isInternalName name+  , any isBinding contexts+  = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ]+internalAnchor _ _ content = content -internalAnchorIdent :: GHC.Name -> String-internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique+externalAnchorIdent :: Name -> String+externalAnchorIdent = hypSrcNameUrl -hyperlink :: SrcMap -> TokenDetails -> Html -> Html-hyperlink srcs details = case rtkName details of-    Left name ->-        if GHC.isInternalName name-        then internalHyperlink name-        else externalNameHyperlink srcs name-    Right name -> externalModHyperlink srcs name+internalAnchorIdent :: Name -> String+internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique -internalHyperlink :: GHC.Name -> Html -> Html-internalHyperlink name content =-    Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]+-- | Generate the HTML hyperlink for an identifier+hyperlink :: SrcMaps -> Identifier -> Html -> Html+hyperlink (srcs, srcs') ident = case ident of+    Right name | isInternalName name -> internalHyperlink name+               | otherwise -> externalNameHyperlink name+    Left name -> externalModHyperlink name -externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html-externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of-    Just SrcLocal -> Html.anchor content !-        [ Html.href $ hypSrcModuleNameUrl mdl name ]-    Just (SrcExternal path) -> Html.anchor content !-        [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]-    Nothing -> content   where-    mdl = GHC.nameModule name+    -- In a Nix environment, we have file:// URLs with absolute paths+    makeHyperlinkUrl url | List.isPrefixOf "file://" url = url+    makeHyperlinkUrl url = ".." </> url -externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html-externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of-    Just SrcLocal -> Html.anchor content !-        [ Html.href $ hypSrcModuleUrl' name ]-    Just (SrcExternal path) -> Html.anchor content !-        [ Html.href $ path </> hypSrcModuleUrl' name ]-    Nothing -> content+    internalHyperlink name content =+        Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] +    externalNameHyperlink name content = case Map.lookup mdl srcs of+        Just SrcLocal -> Html.anchor content !+            [ Html.href $ hypSrcModuleNameUrl mdl name ]+        Just (SrcExternal path) ->+          let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleNameUrl mdl name+           in Html.anchor content !+                [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing hyperlinkUrl ]+        Nothing -> content+      where+        mdl = nameModule name +    externalModHyperlink moduleName content =+        case Map.lookup moduleName srcs' of+          Just SrcLocal -> Html.anchor content !+            [ Html.href $ hypSrcModuleUrl' moduleName ]+          Just (SrcExternal path) ->+            let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleUrl' moduleName+             in Html.anchor content !+                  [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing hyperlinkUrl ]+          Nothing -> content++ renderSpace :: Int -> String -> Html-renderSpace _ [] = Html.noHtml-renderSpace line ('\n':rest) = mconcat-    [ Html.thespan . Html.toHtml $ "\n"+renderSpace !_ "" = Html.noHtml+renderSpace !line ('\n':rest) = mconcat+    [ Html.thespan (Html.toHtml '\n')     , lineAnchor (line + 1)     , renderSpace (line + 1) rest     ]@@ -186,4 +291,4 @@   lineAnchor :: Int -> Html-lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]+lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ]
src/Haddock/Backends/Hyperlinker/Types.hs view
@@ -1,30 +1,26 @@+{-# LANGUAGE PatternSynonyms, OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Types where - import qualified GHC -import Data.Map (Map)-import qualified Data.Map as Map+import Data.ByteString  ( ByteString ) +import Data.Map (Map)  data Token = Token     { tkType :: TokenType-    , tkValue :: String-    , tkSpan :: Span+    , tkValue :: ByteString -- ^ UTF-8 encoded+    , tkSpan :: {-# UNPACK #-} !Span     }     deriving (Show) -data Position = Position-    { posRow :: !Int-    , posCol :: !Int-    }-    deriving (Show)+pattern BacktickTok, OpenParenTok, CloseParenTok :: Span -> Token+pattern BacktickTok   sp = Token TkSpecial "`" sp+pattern OpenParenTok  sp = Token TkSpecial "(" sp+pattern CloseParenTok sp = Token TkSpecial ")" sp -data Span = Span-    { spStart :: Position-    , spEnd :: Position-    }-    deriving (Show)+type Position = GHC.RealSrcLoc+type Span = GHC.RealSrcSpan  data TokenType     = TkIdentifier@@ -42,29 +38,6 @@     | TkUnknown     deriving (Show, Eq) --data RichToken = RichToken-    { rtkToken :: Token-    , rtkDetails :: Maybe TokenDetails-    }--data TokenDetails-    = RtkVar GHC.Name-    | RtkType GHC.Name-    | RtkBind GHC.Name-    | RtkDecl GHC.Name-    | RtkModule GHC.ModuleName-    deriving (Eq)---rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName-rtkName (RtkVar name) = Left name-rtkName (RtkType name) = Left name-rtkName (RtkBind name) = Left name-rtkName (RtkDecl name) = Left name-rtkName (RtkModule name) = Right name-- -- | Path for making cross-package hyperlinks in generated sources. -- -- Used in 'SrcMap' to determine whether module originates in current package@@ -74,15 +47,5 @@     | SrcLocal  -- | Mapping from modules to cross-package source paths.------ This mapping is actually a pair of maps instead of just one map. The reason--- for this is because when hyperlinking modules in import lists we have no--- 'GHC.Module' available. On the other hand, we can't just use map with--- 'GHC.ModuleName' as indices because certain modules may have common name--- but originate in different packages. Hence, we use both /rich/ and /poor/--- versions, where the /poor/ is just projection of /rich/ one cached in pair--- for better performance.-type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)+type SrcMaps = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) -mkSrcMap :: Map GHC.Module SrcPath -> SrcMap-mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
src/Haddock/Backends/Hyperlinker/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.Utils     ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'     , hypSrcModuleUrl, hypSrcModuleUrl'@@ -6,21 +7,35 @@     , hypSrcModuleNameUrl, hypSrcModuleLineUrl     , hypSrcModuleUrlFormat     , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat-    ) where+    , spliceURL, spliceURL' +    -- * HIE file processing+    , PrintedType+    , recoverFullIfaceTypes+    ) where +import Haddock.Utils import Haddock.Backends.Xhtml.Utils  import GHC-import FastString-import System.FilePath.Posix ((</>))+import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )+import GHC.Iface.Type+import GHC.Types.Name      ( getOccFS, getOccString )+import GHC.Driver.Ppr      ( showSDoc )+import GHC.Types.Var       ( VarBndr(..), visArg, invisArg, TypeOrConstraint(..) ) +import System.FilePath.Posix ((</>), (<.>)) +import qualified Data.Array as A+++{-# INLINE hypSrcDir #-} hypSrcDir :: FilePath hypSrcDir = "src" +{-# INLINE hypSrcModuleFile #-} hypSrcModuleFile :: Module -> FilePath-hypSrcModuleFile = hypSrcModuleFile' . moduleName+hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html"  hypSrcModuleFile' :: ModuleName -> FilePath hypSrcModuleFile' mdl = spliceURL'@@ -32,20 +47,19 @@ hypSrcModuleUrl' :: ModuleName -> String hypSrcModuleUrl' = hypSrcModuleFile' +{-# INLINE hypSrcNameUrl #-} hypSrcNameUrl :: Name -> String-hypSrcNameUrl name = spliceURL-    Nothing Nothing (Just name) Nothing nameFormat+hypSrcNameUrl = escapeStr . getOccString +{-# INLINE hypSrcLineUrl #-} hypSrcLineUrl :: Int -> String-hypSrcLineUrl line = spliceURL-    Nothing Nothing Nothing (Just spn) lineFormat-  where-    loc = mkSrcLoc nilFS line 1-    spn = mkSrcSpan loc loc+hypSrcLineUrl line = "line-" ++ show line +{-# INLINE hypSrcModuleNameUrl #-} hypSrcModuleNameUrl :: Module -> Name -> String hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name +{-# INLINE hypSrcModuleLineUrl #-} hypSrcModuleLineUrl :: Module -> Int -> String hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line @@ -66,3 +80,65 @@  lineFormat :: String lineFormat = "line-%{LINE}"+++-- * HIE file processing++-- This belongs in GHC.Iface.Ext.Utils...++-- | Pretty-printed type, ready to be turned into HTML by @xhtml@+type PrintedType = String++-- | Expand the flattened HIE AST into one where the types printed out and+-- ready for end-users to look at.+--+-- Using just primitives found in GHC's HIE utilities, we could write this as+-- follows:+--+-- > 'recoverFullIfaceTypes' dflags hieTypes hieAst+-- >     = 'fmap' (\ti -> 'showSDoc' df .+-- >                      'pprIfaceType' $+-- >                      'recoverFullType' ti hieTypes)+-- >       hieAst+--+-- However, this is very inefficient (both in time and space) because the+-- multiple calls to 'recoverFullType' don't share intermediate results. This+-- function fixes that.+recoverFullIfaceTypes+  :: DynFlags+  -> A.Array TypeIndex HieTypeFlat -- ^ flat types+  -> HieAST TypeIndex              -- ^ flattened AST+  -> HieAST PrintedType       -- ^ full AST+recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast+    where++    -- Splitting this out into its own array is also important: we don't want+    -- to pretty print the same type many times+    printed :: A.Array TypeIndex PrintedType+    printed = fmap (showSDoc df . pprIfaceType) unflattened++    -- The recursion in 'unflattened' is crucial - it's what gives us sharing+    -- between the IfaceType's produced+    unflattened :: A.Array TypeIndex IfaceType+    unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened++    -- Unfold an 'HieType' whose subterms have already been unfolded+    go :: HieType IfaceType -> IfaceType+    go (HTyVarTy n) = IfaceTyVar (getOccFS n)+    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)+    go (HLitTy l) = IfaceLitTy l+    go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k)+                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t+    go (HFunTy w a b)  = IfaceFunTy (visArg TypeLike)   w a b          -- t1 -> t2+    go (HQualTy con b) = IfaceFunTy (invisArg TypeLike) many_ty con b  -- c => t+    go (HCastTy a) = a+    go HCoercionTy = IfaceTyVar "<coercion type>"+    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
src/Haddock/Backends/LaTeX.hs view
@@ -1,1270 +1,1454 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-}--------------------------------------------------------------------------------- |--- Module      :  Haddock.Backends.LaTeX--- Copyright   :  (c) Simon Marlow      2010,---                    Mateusz Kowalczyk 2013--- License     :  BSD-like------ Maintainer  :  haddock@projects.haskell.org--- Stability   :  experimental--- Portability :  portable-------------------------------------------------------------------------------module Haddock.Backends.LaTeX (-  ppLaTeX-) where---import Haddock.Types-import Haddock.Utils-import Haddock.GhcUtils-import Pretty hiding (Doc, quote)-import qualified Pretty--import GHC-import OccName-import Name                 ( nameOccName )-import RdrName              ( rdrNameOcc )-import FastString           ( unpackFS, unpackLitString, zString )-import Outputable           ( panic)--import qualified Data.Map as Map-import System.Directory-import System.FilePath-import Data.Char-import Control.Monad-import Data.Maybe-import Data.List--import Haddock.Doc (combineDocumentation)---- import Debug.Trace--{- SAMPLE OUTPUT--\haddockmoduleheading{\texttt{Data.List}}-\hrulefill-{\haddockverb\begin{verbatim}-module Data.List (-    (++),  head,  last,  tail,  init,  null,  length,  map,  reverse,-  ) where\end{verbatim}}-\hrulefill--\section{Basic functions}-\begin{haddockdesc}-\item[\begin{tabular}{@{}l}-head\ ::\ {\char 91}a{\char 93}\ ->\ a-\end{tabular}]\haddockbegindoc-Extract the first element of a list, which must be non-empty.-\par--\end{haddockdesc}-\begin{haddockdesc}-\item[\begin{tabular}{@{}l}-last\ ::\ {\char 91}a{\char 93}\ ->\ a-\end{tabular}]\haddockbegindoc-Extract the last element of a list, which must be finite and non-empty.-\par--\end{haddockdesc}--}---{- TODO- * don't forget fixity!!--}--ppLaTeX :: String                       -- Title-        -> Maybe String                 -- Package name-        -> [Interface]-        -> FilePath                     -- destination directory-        -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe-        -> Maybe String                 -- style file-        -> FilePath-        -> IO ()--ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir- = do-   createDirectoryIfMissing True odir-   when (isNothing maybe_style) $-     copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)-   ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces-   mapM_ (ppLaTeXModule title odir) visible_ifaces---haddockSty :: FilePath-haddockSty = "haddock.sty"---type LaTeX = Pretty.Doc---ppLaTeXTop-   :: String-   -> Maybe String-   -> FilePath-   -> Maybe (Doc GHC.RdrName)-   -> Maybe String-   -> [Interface]-   -> IO ()--ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do--  let tex = vcat [-        text "\\documentclass{book}",-        text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),-        text "\\begin{document}",-        text "\\begin{titlepage}",-        text "\\begin{haddocktitle}",-        text doctitle,-        text "\\end{haddocktitle}",-        case prologue of-           Nothing -> empty-           Just d  -> vcat [text "\\begin{haddockprologue}",-                            rdrDocToLaTeX d,-                            text "\\end{haddockprologue}"],-        text "\\end{titlepage}",-        text "\\tableofcontents",-        vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],-        text "\\end{document}"-        ]--      mods = sort (map (moduleBasename.ifaceMod) ifaces)--      filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")--  writeFile filename (show tex)---ppLaTeXModule :: String -> FilePath -> Interface -> IO ()-ppLaTeXModule _title odir iface = do-  createDirectoryIfMissing True odir-  let-      mdl = ifaceMod iface-      mdl_str = moduleString mdl--      exports = ifaceRnExportItems iface--      tex = vcat [-        text "\\haddockmoduleheading" <> braces (text mdl_str),-        text "\\label{module:" <> text mdl_str <> char '}',-        text "\\haddockbeginheader",-        verb $ vcat [-           text "module" <+> text mdl_str <+> lparen,-           text "    " <> fsep (punctuate (text ", ") $-                               map exportListItem $-                               filter forSummary exports),-           text "  ) where"-         ],-        text "\\haddockendheader" $$ text "",-        description,-        body-       ]--      description-          = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface--      body = processExports exports-  ---  writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex)---string_txt :: TextDetails -> String -> String-string_txt (Chr c)   s  = c:s-string_txt (Str s1)  s2 = s1 ++ s2-string_txt (PStr s1) s2 = unpackFS s1 ++ s2-string_txt (ZStr s1) s2 = zString s1 ++ s2-string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2---exportListItem :: ExportItem DocName -> LaTeX-exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }-  = sep (punctuate comma . map ppDocBinder $ declNames decl) <>-     case subdocs of-       [] -> empty-       _  -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))-exportListItem (ExportNoDecl y [])-  = ppDocBinder y-exportListItem (ExportNoDecl y subs)-  = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))-exportListItem (ExportModule mdl)-  = text "module" <+> text (moduleString mdl)-exportListItem _-  = error "exportListItem"----- Deal with a group of undocumented exports together, to avoid lots--- of blank vertical space between them.-processExports :: [ExportItem DocName] -> LaTeX-processExports [] = empty-processExports (decl : es)-  | Just sig <- isSimpleSig decl-  = multiDecl [ ppTypeSig (map getName names) typ False-              | (names,typ) <- sig:sigs ] $$-    processExports es'-  where (sigs, es') = spanWith isSimpleSig es-processExports (ExportModule mdl : es)-  = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$-    processExports es'-  where (mdls, es') = spanWith isExportModule es-processExports (e : es) =-  processExport e $$ processExports es---isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t))-                       , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }-  | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))-isSimpleSig _ = Nothing---isExportModule :: ExportItem DocName -> Maybe Module-isExportModule (ExportModule m) = Just m-isExportModule _ = Nothing---processExport :: ExportItem DocName -> LaTeX-processExport (ExportGroup lev _id0 doc)-  = ppDocGroup lev (docToLaTeX doc)-processExport (ExportDecl decl doc subdocs insts fixities _splice)-  = ppDecl decl doc insts subdocs fixities-processExport (ExportNoDecl y [])-  = ppDocName y-processExport (ExportNoDecl y subs)-  = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))-processExport (ExportModule mdl)-  = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing-processExport (ExportDoc doc)-  = docToLaTeX $ _doc doc---ppDocGroup :: Int -> LaTeX -> LaTeX-ppDocGroup lev doc = sec lev <> braces doc-  where sec 1 = text "\\section"-        sec 2 = text "\\subsection"-        sec 3 = text "\\subsubsection"-        sec _ = text "\\paragraph"---declNames :: LHsDecl DocName -> [DocName]-declNames (L _ decl) = case decl of-  TyClD d  -> [tcdName d]-  SigD (TypeSig lnames _ ) -> map unLoc lnames-  SigD (PatSynSig lname _) -> [unLoc lname]-  ForD (ForeignImport (L _ n) _ _ _) -> [n]-  ForD (ForeignExport (L _ n) _ _ _) -> [n]-  _ -> error "declaration not supported by declNames"---forSummary :: (ExportItem DocName) -> Bool-forSummary (ExportGroup _ _ _) = False-forSummary (ExportDoc _)       = False-forSummary _                    = True---moduleLaTeXFile :: Module -> FilePath-moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"---moduleBasename :: Module -> FilePath-moduleBasename mdl = map (\c -> if c == '.' then '-' else c)-                         (moduleNameString (moduleName mdl))------------------------------------------------------------------------------------- * Decls-----------------------------------------------------------------------------------ppDecl :: LHsDecl DocName-       -> DocForDecl DocName-       -> [DocInstance DocName]-       -> [(DocName, DocForDecl DocName)]-       -> [(DocName, Fixity)]-       -> LaTeX--ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of-  TyClD d@(FamDecl {})          -> ppTyFam False loc doc d unicode-  TyClD d@(DataDecl {})-                                -> ppDataDecl instances subdocs loc (Just doc) d unicode-  TyClD d@(SynDecl {})          -> ppTySyn loc (doc, fnArgsDoc) d unicode--- Family instances happen via FamInst now---  TyClD d@(TySynonym {})---    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode--- Family instances happen via FamInst now-  TyClD d@(ClassDecl {})    -> ppClassDecl instances loc doc subdocs d unicode-  SigD (TypeSig lnames t)   -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames)-                                        (hsSigWcType t) unicode-  SigD (PatSynSig lname ty) ->-      ppLPatSig loc (doc, fnArgsDoc) lname ty unicode-  ForD d                         -> ppFor loc (doc, fnArgsDoc) d unicode-  InstD _                        -> empty-  _                              -> error "declaration not supported by ppDecl"-  where-    unicode = False---ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->-              TyClDecl DocName -> Bool -> LaTeX-ppTyFam _ _ _ _ _ =-  error "type family declarations are currently not supported by --latex"---ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX-ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode =-  ppFunSig loc doc [name] (hsSigType typ) unicode-ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"---  error "foreign declarations are currently not supported by --latex"------------------------------------------------------------------------------------- * Type Synonyms------------------------------------------------------------------------------------- we skip type patterns for now-ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX--ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars-                         , tcdRhs = ltype }) unicode-  = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode-  where-    hdr  = hsep (keyword "type"-                 : ppDocBinder name-                 : map ppSymName (tyvarNames ltyvars))-    full = hdr <+> char '=' <+> ppLType unicode ltype--ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"------------------------------------------------------------------------------------- * Function signatures-----------------------------------------------------------------------------------ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName-         -> Bool -> LaTeX-ppFunSig loc doc docnames (L _ typ) unicode =-  ppTypeOrFunSig loc docnames typ doc-    ( ppTypeSig names typ False-    , hsep . punctuate comma $ map ppSymName names-    , dcolon unicode)-    unicode- where-   names = map getName docnames--ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName-          -> LHsSigType DocName-          -> Bool -> LaTeX-ppLPatSig _loc (doc, _argDocs) (L _ name) ty unicode-  = declWithDoc pref1 (documentationToLaTeX doc)-  where-    pref1 = hsep [ keyword "pattern"-                 , ppDocBinder name-                 , dcolon unicode-                 , ppLType unicode (hsSigType ty)-                 ]--ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName-               -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)-               -> Bool -> LaTeX-ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)-               unicode-  | Map.null argDocs =-      declWithDoc pref1 (documentationToLaTeX doc)-  | otherwise        =-      declWithDoc pref2 $ Just $-        text "\\haddockbeginargs" $$-        do_args 0 sep0 typ $$-        text "\\end{tabulary}\\par" $$-        fromMaybe empty (documentationToLaTeX doc)-  where-     do_largs n leader (L _ t) = do_args n leader t--     arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs--     do_args :: Int -> LaTeX -> HsType DocName -> LaTeX-     do_args _n leader (HsForAllTy tvs ltype)-       = decltt leader-         <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))-         <+> ppLType unicode ltype-     do_args n leader (HsQualTy lctxt ltype)-       = decltt leader-         <-> ppLContextNoArrow lctxt unicode <+> nl $$-             do_largs n (darrow unicode) ltype-     do_args n leader (HsFunTy lt r)-       = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$-         do_largs (n+1) (arrow unicode) r-     do_args n leader t-       = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl---ppTypeSig :: [Name] -> HsType DocName  -> Bool -> LaTeX-ppTypeSig nms ty unicode =-  hsep (punctuate comma $ map ppSymName nms)-    <+> dcolon unicode-    <+> ppType unicode ty---ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]-ppTyVars = map (ppSymName . getName . hsLTyVarName)---tyvarNames :: LHsQTyVars DocName -> [Name]-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit---declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX-declWithDoc decl doc =-   text "\\begin{haddockdesc}" $$-   text "\\item[\\begin{tabular}{@{}l}" $$-   text (latexMonoFilter (show decl)) $$-   text "\\end{tabular}]" <>-       (if isNothing doc then empty else text "\\haddockbegindoc") $$-   maybe empty id doc $$-   text "\\end{haddockdesc}"----- in a group of decls, we don't put them all in the same tabular,--- because that would prevent the group being broken over a page--- boundary (breaks Foreign.C.Error for example).-multiDecl :: [LaTeX] -> LaTeX-multiDecl decls =-   text "\\begin{haddockdesc}" $$-   vcat [-      text "\\item[" $$-      text (latexMonoFilter (show decl)) $$-      text "]"-      | decl <- decls ] $$-   text "\\end{haddockdesc}"------------------------------------------------------------------------------------- * Rendering Doc-----------------------------------------------------------------------------------maybeDoc :: Maybe (Doc DocName) -> LaTeX-maybeDoc = maybe empty docToLaTeX----- for table cells, we strip paragraphs out to avoid extra vertical space--- and don't add a quote environment.-rDoc  :: Maybe (Doc DocName) -> LaTeX-rDoc = maybeDoc . fmap latexStripTrailingWhitespace------------------------------------------------------------------------------------- * Class declarations-----------------------------------------------------------------------------------ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName-           -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]-           -> Bool -> LaTeX-ppClassHdr summ lctxt n tvs fds unicode =-  keyword "class"-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)-  <+> ppAppDocNameNames summ n (tyvarNames tvs)-  <+> ppFds fds unicode---ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX-ppFds fds unicode =-  if null fds then empty else-    char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))-  where-    fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>-                           hsep (map (ppDocName . unLoc) vars2)---ppClassDecl :: [DocInstance DocName] -> SrcSpan-            -> Documentation DocName -> [(DocName, DocForDecl DocName)]-            -> TyClDecl DocName -> Bool -> LaTeX-ppClassDecl instances loc doc subdocs-  (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds-             , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode-  = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$-    instancesBit-  where-    classheader-      | null lsigs = hdr unicode-      | otherwise  = hdr unicode <+> keyword "where"--    hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds--    body = catMaybes [documentationToLaTeX doc, body_]--    body_-      | null lsigs, null ats, null at_defs = Nothing-      | null ats, null at_defs = Just methodTable----     | otherwise = atTable $$ methodTable-      | otherwise = error "LaTeX.ppClassDecl"--    methodTable =-      text "\\haddockpremethods{}\\textbf{Methods}" $$-      vcat  [ ppFunSig loc doc names (hsSigWcType typ) unicode-            | L _ (TypeSig lnames typ) <- lsigs-            , let doc = lookupAnySubdoc (head names) subdocs-                  names = map unLoc lnames ]-              -- FIXME: is taking just the first name ok? Is it possible that-              -- there are different subdocs for different names in a single-              -- type signature?--    instancesBit = ppDocInstances unicode instances--ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"--ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX-ppDocInstances _unicode [] = empty-ppDocInstances unicode (i : rest)-  | Just ihead <- isUndocdInstance i-  = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$-    ppDocInstances unicode rest'-  | otherwise-  = ppDocInstance unicode i $$ ppDocInstances unicode rest-  where-    (is, rest') = spanWith isUndocdInstance rest--isUndocdInstance :: DocInstance a -> Maybe (InstHead a)-isUndocdInstance (i,Nothing,_) = Just i-isUndocdInstance _ = Nothing---- | Print a possibly commented instance. The instance header is printed inside--- an 'argBox'. The comment is printed to the right of the box in normal comment--- style.-ppDocInstance :: Bool -> DocInstance DocName -> LaTeX-ppDocInstance unicode (instHead, doc, _) =-  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)---ppInstDecl :: Bool -> InstHead DocName -> LaTeX-ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead---ppInstHead :: Bool -> InstHead DocName -> LaTeX-ppInstHead unicode (InstHead {..}) = case ihdInstType of-    ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ-    TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs-    DataInst _ -> error "data instances not supported by --latex yet"-  where-    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode-    tibody = maybe empty (\t -> equals <+> ppType unicode t)--lookupAnySubdoc :: (Eq name1) =>-                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2-lookupAnySubdoc n subdocs = case lookup n subdocs of-  Nothing -> noDocForDecl-  Just docs -> docs------------------------------------------------------------------------------------- * Data & newtype declarations-----------------------------------------------------------------------------------ppDataDecl :: [DocInstance DocName] ->-              [(DocName, DocForDecl DocName)] -> SrcSpan ->-              Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->-              LaTeX-ppDataDecl instances subdocs _loc doc dataDecl unicode--   =  declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)-                  (if null body then Nothing else Just (vcat body))-   $$ instancesBit--  where-    cons      = dd_cons (tcdDataDefn dataDecl)-    resTy     = (unLoc . head) cons--    body = catMaybes [constrBit, doc >>= documentationToLaTeX]--    (whereBit, leaders)-      | null cons = (empty,[])-      | otherwise = case resTy of-        ConDeclGADT{} -> (decltt (keyword "where"), repeat empty)-        _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))--    constrBit-      | null cons = Nothing-      | otherwise = Just $-          text "\\haddockbeginconstrs" $$-          vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$-          text "\\end{tabulary}\\par"--    instancesBit = ppDocInstances unicode instances----- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX-ppConstrHdr forall tvs ctxt unicode- = (if null tvs then empty else ppForall)-   <+>-   (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")-  where-    ppForall = case forall of-      True  -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "-      False -> empty---ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX-                   -> LConDecl DocName -> LaTeX-ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =-  leader <->-  case con_details con of--    PrefixCon args ->-      decltt (hsep ((header_ unicode <+> ppOcc) :-                 map (ppLParendType unicode) args))-      <-> rDoc mbDoc <+> nl--    RecCon (L _ fields) ->-      (decltt (header_ unicode <+> ppOcc)-        <-> rDoc mbDoc <+> nl)-      $$-      doRecordFields fields--    InfixCon arg1 arg2 ->-      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,-                 ppOcc,-                 ppLParendType unicode arg2 ])-      <-> rDoc mbDoc <+> nl-- where-    doRecordFields fields =-        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))---    header_ = ppConstrHdr False tyVars context-    occ     = map (nameOccName . getName . unLoc) $ getConNames con-    ppOcc   = case occ of-      [one] -> ppBinder one-      _     -> cat (punctuate comma (map ppBinder occ))-    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))-    context = unLoc (fromMaybe (noLoc []) (con_cxt con))--    -- don't use "con_doc con", in case it's reconstructed from a .hi file,-    -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = case getConNames con of-              [] -> panic "empty con_names"-              (cn:_) -> lookup (unLoc cn) subdocs >>=-                        fmap _doc . combineDocumentation . fst--ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) =-  leader <->-  doGADTCon (hsib_body $ con_type con)-- where-    doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+>-                               ppLType unicode resTy-                            ) <-> rDoc mbDoc--    occ     = map (nameOccName . getName . unLoc) $ getConNames con-    ppOcc   = case occ of-      [one] -> ppBinder one-      _     -> cat (punctuate comma (map ppBinder occ))--    -- don't use "con_doc con", in case it's reconstructed from a .hi file,-    -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = case getConNames con of-              [] -> panic "empty con_names"-              (cn:_) -> lookup (unLoc cn) subdocs >>=-                        fmap _doc . combineDocumentation . fst-{- old--ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX-                   -> LConDecl DocName -> LaTeX-ppSideBySideConstr subdocs unicode leader (L loc con) =-  leader <->-  case con_res con of-  ResTyH98 -> case con_details con of--    PrefixCon args ->-      decltt (hsep ((header_ unicode <+> ppOcc) :-                 map (ppLParendType unicode) args))-      <-> rDoc mbDoc <+> nl--    RecCon (L _ fields) ->-      (decltt (header_ unicode <+> ppOcc)-        <-> rDoc mbDoc <+> nl)-      $$-      doRecordFields fields--    InfixCon arg1 arg2 ->-      decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,-                 ppOcc,-                 ppLParendType unicode arg2 ])-      <-> rDoc mbDoc <+> nl--  ResTyGADT _ resTy -> case con_details con of-    -- prefix & infix could also use hsConDeclArgTys if it seemed to-    -- simplify the code.-    PrefixCon args -> doGADTCon args resTy-    cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$-                                     doRecordFields fields-    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy-- where-    doRecordFields fields =-        vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields))--    doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+>-                               ppLType unicode (mk_forall $ mk_phi $-                                                foldr mkFunTy resTy args)-                            ) <-> rDoc mbDoc---    header_ = ppConstrHdr (con_explicit con) tyVars context-    occ     = map (nameOccName . getName . unLoc) $ con_names con-    ppOcc   = case occ of-      [one] -> ppBinder one-      _     -> cat (punctuate comma (map ppBinder occ))-    ltvs    = con_qvars con-    tyVars  = tyvarNames (con_qvars con)-    context = unLoc (con_cxt con)--    mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty)-                 | otherwise        = ty-    mk_phi ty | null context = ty-              | otherwise    = L loc (HsQualTy (con_cxt con) ty)--    -- don't use "con_doc con", in case it's reconstructed from a .hi file,-    -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = case con_names con of-              [] -> panic "empty con_names"-              (cn:_) -> lookup (unLoc cn) subdocs >>=-                        fmap _doc . combineDocumentation . fst-    mkFunTy a b = noLoc (HsFunTy a b)--}--ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  LaTeX-ppSideBySideField subdocs unicode (ConDeclField names ltype _) =-  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))-    <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc-  where-    -- don't use cd_fld_doc for same reason we don't use con_doc above-    -- Where there is more than one name, they all have the same documentation-    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst---- {---- ppHsFullConstr :: HsConDecl -> LaTeX--- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =---      declWithDoc False doc (--- 	hsep ((ppHsConstrHdr tvs ctxt +++--- 		ppHsBinder False nm) : map ppHsBangType typeList)---       )--- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =---    td << vanillaTable << (---      case doc of---        Nothing -> aboves [hdr, fields_html]---        Just _  -> aboves [hdr, constr_doc, fields_html]---    )------   where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)------ 	constr_doc--- 	  | isJust doc = docBox (docToLaTeX (fromJust doc))--- 	  | otherwise  = LaTeX.emptyTable------ 	fields_html =--- 	   td <<--- 	      table ! [width "100%", cellpadding 0, cellspacing 8] << (--- 		   aboves (map ppFullField (concat (map expandField fields)))--- 		)--- -}------ ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX--- ppShortField summary unicode (ConDeclField (L _ name) ltype _)---   = tda [theclass "recfield"] << (---       ppBinder summary (docNameOcc name)---       <+> dcolon unicode <+> ppLType unicode ltype---     )------ {---- ppFullField :: HsFieldDecl -> LaTeX--- ppFullField (HsFieldDecl [n] ty doc)---   = declWithDoc False doc (--- 	ppHsBinder False n <+> dcolon <+> ppHsBangType ty---     )--- ppFullField _ = error "ppFullField"------ expandField :: HsFieldDecl -> [HsFieldDecl]--- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]--- -}----- | Print the LHS of a data\/newtype declaration.--- Currently doesn't handle 'data instance' decls or kind signatures-ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX-ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars-                       , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode-  = -- newtype or data-    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>-    -- context-    ppLContext ctxt unicode <+>-    -- T a b c ..., or a :+: b-    ppAppDocNameNames False name (tyvarNames tyvars)-ppDataHeader _ _ = error "ppDataHeader: illegal argument"------------------------------------------------------------------------------------- * Type applications-------------------------------------------------------------------------------------- | Print an application of a DocName and two lists of HsTypes (kinds, types)-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX-ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)----- | Print an application of a DocName and a list of Names-ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX-ppAppDocNameNames _summ n ns =-  ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName----- | General printing of type applications-ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX-ppTypeApp n [] (t1:t2:rest) ppDN ppT-  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)-  | operator                    = opApp-  where-    operator = isNameSym . getName $ n-    opApp = ppT t1 <+> ppDN n <+> ppT t2--ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)------------------------------------------------------------------------------------- * Contexts-----------------------------------------------------------------------------------ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX-ppLContext        = ppContext        . unLoc-ppLContextNoArrow = ppContextNoArrow . unLoc--ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX-ppContextNoLocsMaybe [] _ = Nothing-ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode--ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX-ppContextNoArrow cxt unicode = fromMaybe empty $-                               ppContextNoLocsMaybe (map unLoc cxt) unicode---ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX-ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $-                              ppContextNoLocsMaybe cxt unicode---ppContext :: HsContext DocName -> Bool -> LaTeX-ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode---pp_hs_context :: [HsType DocName] -> Bool -> LaTeX-pp_hs_context []  _       = empty-pp_hs_context [p] unicode = ppType unicode p-pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)------------------------------------------------------------------------------------- * Types and contexts-----------------------------------------------------------------------------------ppBang :: HsSrcBang -> LaTeX-ppBang (HsSrcBang _ _ SrcStrict) = char '!'-ppBang (HsSrcBang _ _ SrcLazy)   = char '~'-ppBang _                         = empty---tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX-tupleParens HsUnboxedTuple = ubxParenList-tupleParens _              = parenList------------------------------------------------------------------------------------- * Rendering of HsType------ Stolen from Html and tweaked for LaTeX generation-----------------------------------------------------------------------------------pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int--pREC_TOP = (0 :: Int)   -- type in ParseIface.y in GHC-pREC_FUN = (1 :: Int)   -- btype in ParseIface.y in GHC-                        -- Used for LH arg of (->)-pREC_OP  = (2 :: Int)   -- Used for arg of any infix operator-                        -- (we don't keep their fixities around)-pREC_CON = (3 :: Int)   -- Used for arg of type applicn:-                        -- always parenthesise unless atomic--maybeParen :: Int           -- Precedence of context-           -> Int           -- Precedence of top-level operator-           -> LaTeX -> LaTeX  -- Wrap in parens if (ctxt >= op)-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p-                               | otherwise            = p---ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX-ppLType       unicode y = ppType unicode (unLoc y)-ppLParendType unicode y = ppParendType unicode (unLoc y)-ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)---ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX-ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode-ppFunLhType  unicode ty = ppr_mono_ty pREC_FUN ty unicode--ppLKind :: Bool -> LHsKind DocName -> LaTeX-ppLKind unicode y = ppKind unicode (unLoc y)--ppKind :: Bool -> HsKind DocName -> LaTeX-ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode----- Drop top-level for-all type variables in user style--- since they are implicit in Haskell--ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode---ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode-  = maybeParen ctxt_prec pREC_FUN $-    sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot-        , ppr_mono_lty pREC_TOP ty unicode ]-ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode-  = maybeParen ctxt_prec pREC_FUN $-    sep [ ppLContext ctxt unicode-        , ppr_mono_lty pREC_TOP ty unicode ]--ppr_mono_ty _         (HsBangTy b ty)     u = ppBang b <> ppLParendType u ty-ppr_mono_ty _         (HsTyVar (L _ name)) _ = ppDocName name-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u = ppr_fun_ty ctxt_prec ty1 ty2 u-ppr_mono_ty _         (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)-ppr_mono_ty _         (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)-ppr_mono_ty _         (HsListTy ty)       u = brackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _         (HsPArrTy ty)       u = pabrackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _         (HsIParamTy n ty)   u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _         (HsSpliceTy {})     _ = error "ppr_mono_ty HsSpliceTy"-ppr_mono_ty _         (HsRecTy {})        _ = error "ppr_mono_ty HsRecTy"-ppr_mono_ty _         (HsCoreTy {})       _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _         (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys-ppr_mono_ty _         (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys--ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode-  = maybeParen ctxt_prec pREC_OP $-    ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode--ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode-  = maybeParen ctxt_prec pREC_CON $-    hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]--ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode-  = maybeParen ctxt_prec pREC_FUN $-    ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode-  where-    ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op-    occName = nameOccName . getName . unLoc $ op--ppr_mono_ty ctxt_prec (HsParTy ty) unicode---  = parens (ppr_mono_lty pREC_TOP ty)-  = ppr_mono_lty ctxt_prec ty unicode--ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode-  = ppr_mono_lty ctxt_prec ty unicode--ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'--ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u--ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy"---ppr_tylit :: HsTyLit -> Bool -> LaTeX-ppr_tylit (HsNumTy _ n) _ = integer n-ppr_tylit (HsStrTy _ s) _ = text (show s)-  -- XXX: Ok in verbatim, but not otherwise-  -- XXX: Do something with Unicode parameter?---ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX-ppr_fun_ty ctxt_prec ty1 ty2 unicode-  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode-        p2 = ppr_mono_lty pREC_TOP ty2 unicode-    in-    maybeParen ctxt_prec pREC_FUN $-    sep [p1, arrow unicode <+> p2]------------------------------------------------------------------------------------- * Names-----------------------------------------------------------------------------------ppBinder :: OccName -> LaTeX-ppBinder n-  | isInfixName n = parens $ ppOccName n-  | otherwise     = ppOccName n--isInfixName :: OccName -> Bool-isInfixName n = isVarSym n || isConSym n--ppSymName :: Name -> LaTeX-ppSymName name-  | isNameSym name = parens $ ppName name-  | otherwise = ppName name---ppVerbOccName :: OccName -> LaTeX-ppVerbOccName = text . latexFilter . occNameString--ppIPName :: HsIPName -> LaTeX-ppIPName ip = text $ unpackFS $ hsIPNameFS ip--ppOccName :: OccName -> LaTeX-ppOccName = text . occNameString---ppVerbDocName :: DocName -> LaTeX-ppVerbDocName = ppVerbOccName . nameOccName . getName---ppVerbRdrName :: RdrName -> LaTeX-ppVerbRdrName = ppVerbOccName . rdrNameOcc---ppDocName :: DocName -> LaTeX-ppDocName = ppOccName . nameOccName . getName---ppLDocName :: Located DocName -> LaTeX-ppLDocName (L _ d) = ppDocName d---ppDocBinder :: DocName -> LaTeX-ppDocBinder = ppBinder . nameOccName . getName---ppName :: Name -> LaTeX-ppName = ppOccName . nameOccName---latexFilter :: String -> String-latexFilter = foldr latexMunge ""---latexMonoFilter :: String -> String-latexMonoFilter = foldr latexMonoMunge ""---latexMunge :: Char -> String -> String-latexMunge '#'  s = "{\\char '43}" ++ s-latexMunge '$'  s = "{\\char '44}" ++ s-latexMunge '%'  s = "{\\char '45}" ++ s-latexMunge '&'  s = "{\\char '46}" ++ s-latexMunge '~'  s = "{\\char '176}" ++ s-latexMunge '_'  s = "{\\char '137}" ++ s-latexMunge '^'  s = "{\\char '136}" ++ s-latexMunge '\\' s = "{\\char '134}" ++ s-latexMunge '{'  s = "{\\char '173}" ++ s-latexMunge '}'  s = "{\\char '175}" ++ s-latexMunge '['  s = "{\\char 91}" ++ s-latexMunge ']'  s = "{\\char 93}" ++ s-latexMunge c    s = c : s---latexMonoMunge :: Char -> String -> String-latexMonoMunge ' ' s = '\\' : ' ' : s-latexMonoMunge '\n' s = '\\' : '\\' : s-latexMonoMunge c   s = latexMunge c s------------------------------------------------------------------------------------- * Doc Markup-----------------------------------------------------------------------------------parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)-parLatexMarkup ppId = Markup {-  markupParagraph            = \p v -> p v <> text "\\par" $$ text "",-  markupEmpty                = \_ -> empty,-  markupString               = \s v -> text (fixString v s),-  markupAppend               = \l r v -> l v <> r v,-  markupIdentifier           = markupId ppId,-  markupIdentifierUnchecked  = markupId (ppVerbOccName . snd),-  markupModule               = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),-  markupWarning              = \p v -> emph (p v),-  markupEmphasis             = \p v -> emph (p v),-  markupBold                 = \p v -> bold (p v),-  markupMonospaced           = \p _ -> tt (p Mono),-  markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",-  markupPic                  = \p _ -> markupPic p,-  markupMathInline           = \p _ -> markupMathInline p,-  markupMathDisplay          = \p _ -> markupMathDisplay p,-  markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",-  markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),-  markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",-  markupHyperlink            = \l _ -> markupLink l,-  markupAName                = \_ _ -> empty,-  markupProperty             = \p _ -> quote $ verb $ text p,-  markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,-  markupHeader               = \(Header l h) p -> header l (h p)-  }-  where-    header 1 d = text "\\section*" <> braces d-    header 2 d = text "\\subsection*" <> braces d-    header l d-      | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d-    header l _ = error $ "impossible header level in LaTeX generation: " ++ show l--    fixString Plain s = latexFilter s-    fixString Verb  s = s-    fixString Mono  s = latexMonoFilter s--    markupLink (Hyperlink url mLabel) = case mLabel of-      Just label -> text "\\href" <> braces (text url) <> braces (text label)-      Nothing    -> text "\\url"  <> braces (text url)--    -- Is there a better way of doing this? Just a space is an aribtrary choice.-    markupPic (Picture uri title) = parens (imageText title)-      where-        imageText Nothing = beg-        imageText (Just t) = beg <> text " " <> text t--        beg = text "image: " <> text uri--    markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)"--    markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]"--    markupId ppId_ id v =-      case v of-        Verb  -> theid-        Mono  -> theid-        Plain -> text "\\haddockid" <> braces theid-      where theid = ppId_ id---latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)-latexMarkup = parLatexMarkup ppVerbDocName---rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)-rdrLatexMarkup = parLatexMarkup ppVerbRdrName---docToLaTeX :: Doc DocName -> LaTeX-docToLaTeX doc = markup latexMarkup doc Plain---documentationToLaTeX :: Documentation DocName -> Maybe LaTeX-documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation---rdrDocToLaTeX :: Doc RdrName -> LaTeX-rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain---data StringContext = Plain | Verb | Mono---latexStripTrailingWhitespace :: Doc a -> Doc a-latexStripTrailingWhitespace (DocString s)-  | null s'   = DocEmpty-  | otherwise = DocString s-  where s' = reverse (dropWhile isSpace (reverse s))-latexStripTrailingWhitespace (DocAppend l r)-  | DocEmpty <- r' = latexStripTrailingWhitespace l-  | otherwise      = DocAppend l r'-  where-    r' = latexStripTrailingWhitespace r-latexStripTrailingWhitespace (DocParagraph p) =-  latexStripTrailingWhitespace p-latexStripTrailingWhitespace other = other------------------------------------------------------------------------------------- * LaTeX utils-----------------------------------------------------------------------------------itemizedList :: [LaTeX] -> LaTeX-itemizedList items =-  text "\\begin{itemize}" $$-  vcat (map (text "\\item" $$) items) $$-  text "\\end{itemize}"---enumeratedList :: [LaTeX] -> LaTeX-enumeratedList items =-  text "\\begin{enumerate}" $$-  vcat (map (text "\\item " $$) items) $$-  text "\\end{enumerate}"---descriptionList :: [(LaTeX,LaTeX)] -> LaTeX-descriptionList items =-  text "\\begin{description}" $$-  vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$-  text "\\end{description}"---tt :: LaTeX -> LaTeX-tt ltx = text "\\haddocktt" <> braces ltx---decltt :: LaTeX -> LaTeX-decltt ltx = text "\\haddockdecltt" <> braces ltx---emph :: LaTeX -> LaTeX-emph ltx = text "\\emph" <> braces ltx--bold :: LaTeX -> LaTeX-bold ltx = text "\\textbf" <> braces ltx--verb :: LaTeX -> LaTeX-verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"-   -- NB. swallow a trailing \n in the verbatim text by appending the-   -- \end{verbatim} directly, otherwise we get spurious blank lines at the-   -- end of code blocks.---quote :: LaTeX -> LaTeX-quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"---dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX-dcolon unicode = text (if unicode then "∷" else "::")-arrow  unicode = text (if unicode then "→" else "->")-darrow unicode = text (if unicode then "⇒" else "=>")-forallSymbol unicode = text (if unicode then "∀" else "forall")---dot :: LaTeX-dot = char '.'---parenList :: [LaTeX] -> LaTeX-parenList = parens . hsep . punctuate comma---ubxParenList :: [LaTeX] -> LaTeX-ubxParenList = ubxparens . hsep . punctuate comma---ubxparens :: LaTeX -> LaTeX-ubxparens h = text "(#" <> h <> text "#)"---pabrackets :: LaTeX -> LaTeX-pabrackets h = text "[:" <> h <> text ":]"+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Backends.LaTeX+-- Copyright   :  (c) Simon Marlow      2010,+--                    Mateusz Kowalczyk 2013+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------+module Haddock.Backends.LaTeX (+  ppLaTeX,+) where++import Documentation.Haddock.Markup+import Haddock.Doc (combineDocumentation)+import Haddock.Types+import Haddock.Utils+import Haddock.GhcUtils+import GHC.Utils.Ppr hiding (Doc, quote)+import qualified GHC.Utils.Ppr as Pretty++import GHC hiding (fromMaybeContext )+import GHC.Types.Name.Occurrence+import GHC.Types.Name        ( nameOccName )+import GHC.Types.Name.Reader ( rdrNameOcc )+import GHC.Core.Type         ( Specificity(..) )+import GHC.Data.FastString   ( unpackFS )++import qualified Data.Map as Map+import System.Directory+import System.FilePath+import Data.Char+import Control.Monad+import Data.Maybe+import Data.List            ( sort )+import Data.List.NonEmpty ( NonEmpty (..) )+import Data.Foldable ( toList )+import Prelude hiding ((<>))++{- SAMPLE OUTPUT++\haddockmoduleheading{\texttt{Data.List}}+\hrulefill+{\haddockverb\begin{verbatim}+module Data.List (+    (++),  head,  last,  tail,  init,  null,  length,  map,  reverse,+  ) where\end{verbatim}}+\hrulefill++\section{Basic functions}+\begin{haddockdesc}+\item[\begin{tabular}{@{}l}+head\ ::\ {\char 91}a{\char 93}\ ->\ a+\end{tabular}]\haddockbegindoc+Extract the first element of a list, which must be non-empty.+\par++\end{haddockdesc}+\begin{haddockdesc}+\item[\begin{tabular}{@{}l}+last\ ::\ {\char 91}a{\char 93}\ ->\ a+\end{tabular}]\haddockbegindoc+Extract the last element of a list, which must be finite and non-empty.+\par++\end{haddockdesc}+-}+++{- TODO+ * don't forget fixity!!+-}++ppLaTeX :: String                       -- Title+        -> Maybe String                 -- Package name+        -> [Interface]+        -> FilePath                     -- destination directory+        -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe+        -> Maybe String                 -- style file+        -> FilePath+        -> IO ()++ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir+ = do+   createDirectoryIfMissing True odir+   when (isNothing maybe_style) $+     copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)+   ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces+   mapM_ (ppLaTeXModule title odir) visible_ifaces+++haddockSty :: FilePath+haddockSty = "haddock.sty"+++type LaTeX = Pretty.Doc++-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100+-- often overflows the line).+latex2String :: LaTeX -> String+latex2String = fullRender (PageMode True) 90 1 txtPrinter ""++ppLaTeXTop+   :: String+   -> Maybe String+   -> FilePath+   -> Maybe (Doc GHC.RdrName)+   -> Maybe String+   -> [Interface]+   -> IO ()++ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do++  let tex = vcat [+        text "\\documentclass{book}",+        text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),+        text "\\begin{document}",+        text "\\begin{titlepage}",+        text "\\begin{haddocktitle}",+        text doctitle,+        text "\\end{haddocktitle}",+        case prologue of+           Nothing -> empty+           Just d  -> vcat [text "\\begin{haddockprologue}",+                            rdrDocToLaTeX d,+                            text "\\end{haddockprologue}"],+        text "\\end{titlepage}",+        text "\\tableofcontents",+        vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],+        text "\\end{document}"+        ]++      mods = sort (map (moduleBasename.ifaceMod) ifaces)++      filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")++  writeUtf8File filename (show tex)+++ppLaTeXModule :: String -> FilePath -> Interface -> IO ()+ppLaTeXModule _title odir iface = do+  createDirectoryIfMissing True odir+  let+      mdl = ifaceMod iface+      mdl_str = moduleString mdl++      exports = ifaceRnExportItems iface++      tex = vcat [+        text "\\haddockmoduleheading" <> braces (text mdl_str),+        text "\\label{module:" <> text mdl_str <> char '}',+        text "\\haddockbeginheader",+        verb $ vcat [+           text "module" <+> text mdl_str <+> lparen,+           text "    " <> fsep (punctuate (char ',') $+                               map exportListItem $+                               filter forSummary exports),+           text "  ) where"+         ],+        text "\\haddockendheader" $$ text "",+        description,+        body+       ]++      description+          = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface++      body = processExports exports+  --+  writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex)++-- | Prints out an entry in a module export list.+exportListItem :: ExportItem DocNameI -> LaTeX+exportListItem+    ( ExportDecl+      ( RnExportD+        { rnExpDExpD =+          ( ExportD+            { expDDecl    = decl+            , expDSubDocs = subdocs+            }+          )+        }+      )+    )+  = let (leader, names) = declNames decl+    in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <>+         case subdocs of+           [] -> empty+           _  -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))+exportListItem (ExportNoDecl y [])+  = ppDocBinder y+exportListItem (ExportNoDecl y subs)+  = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))+exportListItem (ExportModule mdl)+  = text "module" <+> text (moduleString mdl)+exportListItem _+  = error "exportListItem"+++-- Deal with a group of undocumented exports together, to avoid lots+-- of blank vertical space between them.+processExports :: [ExportItem DocNameI] -> LaTeX+processExports [] = empty+processExports (decl : es)+  | Just sig <- isSimpleSig decl+  = multiDecl [ ppTypeSig (map getName names) typ False+              | (names,typ) <- sig:sigs ] $$+    processExports es'+  where (sigs, es') = spanWith isSimpleSig es+processExports (ExportModule mdl : es)+  = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$+    processExports es'+  where (mdls, es') = spanWith isExportModule es+processExports (e : es) =+  processExport e $$ processExports es+++isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI)+isSimpleSig+    ( ExportDecl+      ( RnExportD+        { rnExpDExpD =+          ExportD+          { expDDecl  = L _ (SigD _ (TypeSig _ lnames t))+          , expDMbDoc = (Documentation Nothing Nothing, argDocs)+          }+        }+      )+    )+    | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t))+isSimpleSig _ = Nothing+++isExportModule :: ExportItem DocNameI -> Maybe Module+isExportModule (ExportModule m) = Just m+isExportModule _ = Nothing+++processExport :: ExportItem DocNameI -> LaTeX+processExport (ExportGroup lev _id0 doc)+  = ppDocGroup lev (docToLaTeX doc)+processExport (ExportDecl (RnExportD (ExportD decl pats doc subdocs insts fixities _splice) _))+  = ppDecl decl pats doc insts subdocs fixities+processExport (ExportNoDecl y [])+  = ppDocName y+processExport (ExportNoDecl y subs)+  = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))+processExport (ExportModule mdl)+  = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing+processExport (ExportDoc doc)+  = docToLaTeX $ _doc doc+++ppDocGroup :: Int -> LaTeX -> LaTeX+ppDocGroup lev doc = sec lev <> braces doc+  where sec 1 = text "\\section"+        sec 2 = text "\\subsection"+        sec 3 = text "\\subsubsection"+        sec _ = text "\\paragraph"+++-- | Given a declaration, extract out the names being declared+declNames :: LHsDecl DocNameI+          -> ( LaTeX           --   to print before each name in an export list+             , [DocName]       --   names being declared+             )+declNames (L _ decl) = case decl of+  TyClD _ d  -> (empty, [tcdNameI d])+  SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames)+  SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames)+  ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n])+  ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n])+  _ -> error "declaration not supported by declNames"+++forSummary :: (ExportItem DocNameI) -> Bool+forSummary (ExportGroup _ _ _) = False+forSummary (ExportDoc _)       = False+forSummary _                    = True+++moduleLaTeXFile :: Module -> FilePath+moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"+++moduleBasename :: Module -> FilePath+moduleBasename mdl = map (\c -> if c == '.' then '-' else c)+                         (moduleNameString (moduleName mdl))+++-------------------------------------------------------------------------------+-- * Decls+-------------------------------------------------------------------------------++-- | Pretty print a declaration+ppDecl :: LHsDecl DocNameI                         -- ^ decl to print+       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ all pattern decls+       -> DocForDecl DocName                       -- ^ documentation for decl+       -> [DocInstance DocNameI]                   -- ^ all instances+       -> [(DocName, DocForDecl DocName)]          -- ^ all subdocs+       -> [(DocName, Fixity)]                      -- ^ all fixities+       -> LaTeX++ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of+  TyClD _ d@FamDecl {}           -> ppFamDecl False doc instances d unicode+  TyClD _ d@DataDecl {}          -> ppDataDecl pats instances subdocs (Just doc) d unicode+  TyClD _ d@SynDecl {}           -> ppTySyn (doc, fnArgsDoc) d unicode+  TyClD _ d@ClassDecl{}          -> ppClassDecl instances doc subdocs d unicode+  SigD _ (TypeSig _ lnames ty)   -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode+  SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode+  ForD _ d                       -> ppFor (doc, fnArgsDoc) d unicode+  InstD _ _                      -> empty+  DerivD _ _                     -> empty+  _                              -> error "declaration not supported by ppDecl"+  where+    unicode = False+++ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX+ppFor doc (ForeignImport _ (L _ name) typ _) unicode =+  ppFunSig Nothing doc [name] typ unicode+ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"+--  error "foreign declarations are currently not supported by --latex"+++-------------------------------------------------------------------------------+-- * Type families+-------------------------------------------------------------------------------++-- | Pretty-print a data\/type family declaration+ppFamDecl :: Bool                     -- ^ is the family associated?+          -> Documentation DocName    -- ^ this decl's docs+          -> [DocInstance DocNameI]   -- ^ relevant instances+          -> TyClDecl DocNameI        -- ^ family to print+          -> Bool                     -- ^ unicode+          -> LaTeX+ppFamDecl associated doc instances decl unicode =+  declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit)+              (if null body then Nothing else Just (vcat body))+  $$ instancesBit+  where+    body = catMaybes [familyEqns, documentationToLaTeX doc]++    whereBit = case fdInfo (tcdFam decl) of+      ClosedTypeFamily _ -> keyword "where"+      _                  -> empty++    familyEqns+      | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl+      , not (null eqns)+      = Just (text "\\haddockbeginargs" $$+              vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$+              text "\\end{tabulary}\\par")+      | otherwise = Nothing++    -- Individual equations of a closed type family+    ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n+                         , feqn_rhs = rhs+                         , feqn_pats = ts })+      = hsep [ ppAppNameTypeArgs n ts unicode+             , equals+             , ppType unicode (unLoc rhs)+             ]++    instancesBit = ppDocInstances unicode instances++-- | Print the LHS of a type\/data family declaration.+ppFamHeader :: FamilyDecl DocNameI  -- ^ family header to print+            -> Bool                 -- ^ unicode+            -> Bool                 -- ^ is the family associated?+            -> LaTeX+ppFamHeader (FamilyDecl { fdLName = L _ name+                        , fdTyVars = tvs+                        , fdInfo = info+                        , fdResultSig = L _ result+                        , fdInjectivityAnn = injectivity })+              unicode associated =+  famly leader <+> famName <+> famSig <+> injAnn+  where+    leader = case info of+      OpenTypeFamily     -> keyword "type"+      ClosedTypeFamily _ -> keyword "type"+      DataFamily         -> keyword "data"++    famly | associated = id+          | otherwise = (<+> keyword "family")++    famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs)++    famSig = case result of+      NoSig _               -> empty+      KindSig _ kind        -> dcolon unicode <+> ppLKind unicode kind+      TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode bndr++    injAnn = case injectivity of+      Nothing -> empty+      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|")+                                                    : ppLDocName lhs+                                                    : arrow unicode+                                                    : map ppLDocName rhs)+      Just _ -> empty++++-------------------------------------------------------------------------------+-- * Type Synonyms+-------------------------------------------------------------------------------+++-- we skip type patterns for now+ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX++ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars+                         , tcdRhs = ltype }) unicode+  = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode+  where+    hdr  = hsep (keyword "type"+                 : ppDocBinder name+                 : map ppSymName (tyvarNames ltyvars))+    full = hdr <+> char '=' <+> ppLType unicode ltype++ppTySyn _ _ _ = error "declaration not supported by ppTySyn"+++-------------------------------------------------------------------------------+-- * Function signatures+-------------------------------------------------------------------------------+++ppFunSig+  :: Maybe LaTeX         -- ^ a prefix to put right before the signature+  -> DocForDecl DocName  -- ^ documentation+  -> [DocName]           -- ^ pattern names in the pattern signature+  -> LHsSigType DocNameI -- ^ type of the pattern synonym+  -> Bool                -- ^ unicode+  -> LaTeX+ppFunSig leader doc docnames (L _ typ) unicode =+  ppTypeOrFunSig typ doc+    ( lead $ ppTypeSig names typ False+    , lead $ hsep . punctuate comma $ map ppSymName names+    , dcolon unicode+    )+    unicode+ where+   names = map getName docnames+   lead = maybe id (<+>) leader++-- | Pretty-print a pattern synonym+ppLPatSig :: DocForDecl DocName  -- ^ documentation+          -> [DocName]           -- ^ pattern names in the pattern signature+          -> LHsSigType DocNameI -- ^ type of the pattern synonym+          -> Bool                -- ^ unicode+          -> LaTeX+ppLPatSig doc docnames ty unicode+  = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode++-- | Pretty-print a type, adding documentation to the whole type and its+-- arguments as needed.+ppTypeOrFunSig :: HsSigType DocNameI+               -> DocForDecl DocName  -- ^ documentation+               -> ( LaTeX             --   first-line (no-argument docs only)+                  , LaTeX             --   first-line (argument docs only)+                  , LaTeX             --   type prefix (argument docs only)+                  )+               -> Bool                -- ^ unicode+               -> LaTeX+ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode+  | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc)+  | otherwise        = declWithDoc pref2 $ Just $+        text "\\haddockbeginargs" $$+        vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$+        text "\\end{tabulary}\\par" $$+        fromMaybe empty (documentationToLaTeX doc)++-- | This splits up a type signature along @->@ and adds docs (when they exist)+-- to the arguments. The output is a list of (leader/seperator, argument and+-- its doc)+ppSubSigLike :: Bool                  -- ^ unicode+             -> HsSigType DocNameI    -- ^ type signature+             -> FnArgsDoc DocName     -- ^ docs to add+             -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)+             -> LaTeX                 -- ^ seperator (beginning of first line)+             -> [(LaTeX, LaTeX)]      -- ^ arguments (leader/sep, type)+ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ+  where+    do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)]+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =+      case outer_bndrs of+        HsOuterExplicit{hso_bndrs = bndrs} ->+          [ ( decltt leader+            , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode)+                <+> ppLType unicode ltype+            ) ]+        HsOuterImplicit{} -> do_largs n leader ltype++    do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)]+    do_largs n leader (L _ t) = do_args n leader t++    arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs++    do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)]+    do_args _n leader (HsForAllTy _ tele ltype)+      = [ ( decltt leader+          , decltt (ppHsForAllTelescope tele unicode)+              <+> ppLType unicode ltype+          ) ]+    do_args n leader (HsQualTy _ lctxt ltype)+      = ( decltt leader+        , decltt (ppLContextNoArrow lctxt unicode) <+> nl+        ) : do_largs n (darrow unicode) ltype++    do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)+      = [ (decltt ldr, latex <+> nl)+        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)+        , let latex = ppSideBySideField subdocs unicode field+        ]+        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r+    do_args n leader (HsFunTy _ _w lt r)+      = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl)+        : do_largs (n+1) (arrow unicode) r+    do_args n leader t+      = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ]++    -- FIXME: this should be done more elegantly+    --+    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from+    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode+    -- mode since `->` and `::` are rendered as single characters.+    gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ','+    gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}'+    gadtOpen = char '{'+++ppTypeSig :: [Name] -> HsSigType DocNameI  -> Bool -> LaTeX+ppTypeSig nms ty unicode =+  hsep (punctuate comma $ map ppSymName nms)+    <+> dcolon unicode+    <+> ppSigType unicode ty++ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX+ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty+ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode =+    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot++ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX+ppHsForAllTelescope tele unicode = case tele of+  HsForAllVis { hsf_vis_bndrs = bndrs } ->+    hsep (forallSymbol unicode : ppTyVars bndrs) <> text "\\" <> arrow unicode+  HsForAllInvis { hsf_invis_bndrs = bndrs } ->+    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot+++ppTyVars :: [LHsTyVarBndr flag DocNameI] -> [LaTeX]+ppTyVars = map (ppSymName . getName . hsLTyVarNameI)+++tyvarNames :: LHsQTyVars DocNameI -> [Name]+tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit+++declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX+declWithDoc decl doc =+   text "\\begin{haddockdesc}" $$+   text "\\item[\\begin{tabular}{@{}l}" $$+   text (latexMonoFilter (latex2String decl)) $$+   text "\\end{tabular}]" $$+   maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$+   text "\\end{haddockdesc}"+++-- in a group of decls, we don't put them all in the same tabular,+-- because that would prevent the group being broken over a page+-- boundary (breaks Foreign.C.Error for example).+multiDecl :: [LaTeX] -> LaTeX+multiDecl decls =+   text "\\begin{haddockdesc}" $$+   vcat [+      text "\\item[\\begin{tabular}{@{}l}" $$+      text (latexMonoFilter (latex2String decl)) $$+      text "\\end{tabular}]"+      | decl <- decls ] $$+   text "\\end{haddockdesc}"+++-------------------------------------------------------------------------------+-- * Rendering Doc+-------------------------------------------------------------------------------+++maybeDoc :: Maybe (Doc DocName) -> LaTeX+maybeDoc = maybe empty docToLaTeX+++-- for table cells, we strip paragraphs out to avoid extra vertical space+-- and don't add a quote environment.+rDoc  :: Maybe (Doc DocName) -> LaTeX+rDoc = maybeDoc . fmap latexStripTrailingWhitespace+++-------------------------------------------------------------------------------+-- * Class declarations+-------------------------------------------------------------------------------+++ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName+           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]+           -> Bool -> LaTeX+ppClassHdr summ lctxt n tvs fds unicode =+  keyword "class"+  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty)+  <+> ppAppDocNameNames summ n (tyvarNames tvs)+  <+> ppFds fds unicode++-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX+ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX+ppFds fds unicode =+  if null fds then empty else+    char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))+  where+    fundep (FunDep _ vars1 vars2)+                         = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>+                           hsep (map (ppDocName . unLoc) vars2)+    fundep (XFunDep _) = error "ppFds"+++-- TODO: associated type defaults, docs on default methods+ppClassDecl :: [DocInstance DocNameI]+            -> Documentation DocName -> [(DocName, DocForDecl DocName)]+            -> TyClDecl DocNameI -> Bool -> LaTeX+ppClassDecl instances doc subdocs+  (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds+             , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode+  = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$+    instancesBit+  where+    classheader+      | null lsigs = hdr unicode+      | otherwise  = hdr unicode <+> keyword "where"++    hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds++    body = catMaybes [documentationToLaTeX doc, body_]++    body_+      | null lsigs, null ats, null at_defs = Nothing+      | null ats, null at_defs = Just methodTable+      | otherwise = Just (atTable $$ methodTable)++    atTable =+      text "\\haddockpremethods{}" <> emph (text "Associated Types") $$+      vcat  [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True+            | L _ decl <- ats+            , let name = unLoc . fdLName $ decl+                  doc = lookupAnySubdoc name subdocs+            ]+++    methodTable =+      text "\\haddockpremethods{}" <> emph (text "Methods") $$+      vcat  [ ppFunSig leader doc names typ unicode+            | L _ (ClassOpSig _ is_def lnames typ) <- lsigs+            , let doc | is_def = noDocForDecl+                      | otherwise = lookupAnySubdoc (head names) subdocs+                  names = map unLoc lnames+                  leader = if is_def then Just (keyword "default") else Nothing+            ]+            -- N.B. taking just the first name is ok. Signatures with multiple+            -- names are expanded so that each name gets its own signature.++    instancesBit = ppDocInstances unicode instances++ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"++ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX+ppDocInstances _unicode [] = empty+ppDocInstances unicode (i : rest)+  | Just ihead <- isUndocdInstance i+  = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$+    ppDocInstances unicode rest'+  | otherwise+  = ppDocInstance unicode i $$ ppDocInstances unicode rest+  where+    (is, rest') = spanWith isUndocdInstance rest++isUndocdInstance :: DocInstance a -> Maybe (InstHead a)+isUndocdInstance (i,Nothing,_,_) = Just i+isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i+isUndocdInstance _ = Nothing++-- | Print a possibly commented instance. The instance header is printed inside+-- an 'argBox'. The comment is printed to the right of the box in normal comment+-- style.+ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX+ppDocInstance unicode (instHead, doc, _, _) =+  declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)+++ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX+ppInstDecl unicode (InstHead {..}) = case ihdInstType of+  ClassInst ctx _ _ _ -> keyword "instance" <+> ppContextNoLocs ctx unicode <+> typ+  TypeInst rhs -> keyword "type" <+> keyword "instance" <+> typ <+> tibody rhs+  DataInst dd ->+    let cons = dd_cons (tcdDataDefn dd)+        pref = case cons of { NewTypeCon _ -> keyword "newtype"; DataTypeCons _ _ -> keyword "data" }+    in pref <+> keyword "instance" <+> typ+  where+    typ = ppAppNameTypes ihdClsName ihdTypes unicode+    tibody = maybe empty (\t -> equals <+> ppType unicode t)++lookupAnySubdoc :: (Eq name1) =>+                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2+lookupAnySubdoc n subdocs = case lookup n subdocs of+  Nothing -> noDocForDecl+  Just docs -> docs+++-------------------------------------------------------------------------------+-- * Data & newtype declarations+-------------------------------------------------------------------------------++-- | Pretty-print a data declaration+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns+           -> [DocInstance DocNameI]                  -- ^ relevant instances+           -> [(DocName, DocForDecl DocName)]         -- ^ relevant decl docs+           -> Maybe (Documentation DocName)           -- ^ this decl's docs+           -> TyClDecl DocNameI                       -- ^ data decl to print+           -> Bool                                    -- ^ unicode+           -> LaTeX+ppDataDecl pats instances subdocs doc dataDecl unicode =+   declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)+               (if null body then Nothing else Just (vcat body))+   $$ instancesBit++  where+    cons      = dd_cons (tcdDataDefn dataDecl)++    body = catMaybes [doc >>= documentationToLaTeX, constrBit,patternBit]++    (whereBit, leaders)+      | null cons+      , null pats = (empty,[])+      | null cons = (text "where", repeat empty)+      | otherwise = case toList cons of+        L _ ConDeclGADT{} : _ -> (text "where", repeat empty)+        _             -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))++    constrBit+      | null cons = Nothing+      | otherwise = Just $+          text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$+          text "\\haddockbeginconstrs" $$+          vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders (toList cons)) $$+          text "\\end{tabulary}\\par"++    patternBit+      | null pats = Nothing+      | otherwise = Just $+          text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$+          text "\\haddockbeginconstrs" $$+          vcat [ empty <-> ppSideBySidePat lnames typ d unicode+               | (SigD _ (PatSynSig _ lnames typ), d) <- pats+               ] $$+          text "\\end{tabulary}\\par"++    instancesBit = ppDocInstances unicode instances+++-- ppConstrHdr is for (non-GADT) existentials constructors' syntax+ppConstrHdr+  :: Bool                    -- ^ print explicit foralls+  -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables+  -> HsContext DocNameI      -- ^ context+  -> Bool                    -- ^ unicode+  -> LaTeX+ppConstrHdr forall_ tvs ctxt unicode = ppForall <> ppCtxt+  where+    ppForall+      | null tvs || not forall_ = empty+      | otherwise = ppHsForAllTelescope (mkHsForAllInvisTeleI tvs) unicode++    ppCtxt+      | null ctxt = empty+      | otherwise = ppContextNoArrow ctxt unicode <+> darrow unicode <> space+++-- | Pretty-print a constructor+ppSideBySideConstr :: [(DocName, DocForDecl DocName)]  -- ^ all decl docs+                   -> Bool                             -- ^ unicode+                   -> LaTeX                            -- ^ prefix to decl+                   -> LConDecl DocNameI                -- ^ constructor decl+                   -> LaTeX+ppSideBySideConstr subdocs unicode leader (L _ con) =+  leader <-> decltt decl <-> rDoc mbDoc <+> nl+  $$ fieldPart+  where+    -- Find the name of a constructors in the decl (`getConName` always returns+    -- a non-empty list)+    L _ aConName :| _ = getConNamesI con++    occ      = toList $ nameOccName . getName . unLoc <$> getConNamesI con++    ppOcc      = cat (punctuate comma (map ppBinder occ))+    ppOccInfix = cat (punctuate comma (map ppBinderInfix occ))++    -- Extract out the map of of docs corresponding to the constructors arguments+    argDocs = maybe Map.empty snd (lookup aConName subdocs)+    hasArgDocs = not $ Map.null argDocs++    -- First line of the constructor (no doc, no fields, single-line)+    decl = case con of+      ConDeclH98{ con_args = det+                , con_ex_tvs = tyVars+                , con_forall = forall_+                , con_mb_cxt = cxt+                } -> let context = fromMaybeContext cxt+                         header_ = ppConstrHdr forall_ tyVars context unicode+                     in case det of+        -- Prefix constructor, e.g. 'Just a'+        PrefixCon _ args+          | hasArgDocs -> header_ <+> ppOcc+          | otherwise -> hsep [ header_+                              , ppOcc+                              , hsep (map (ppLParendType unicode . hsScaledThing) args)+                              ]++        -- Record constructor, e.g. 'Identity { runIdentity :: a }'+        RecCon _ ->  header_ <+> ppOcc++        -- Infix constructor, e.g. 'a :| [a]'+        InfixCon arg1 arg2+          | hasArgDocs -> header_ <+> ppOcc+          | otherwise -> hsep [ header_+                              , ppLParendType unicode (hsScaledThing arg1)+                              , ppOccInfix+                              , ppLParendType unicode (hsScaledThing arg2)+                              ]++      ConDeclGADT{}+        | hasArgDocs || not (isEmpty fieldPart) -> ppOcc+        | otherwise -> hsep [ ppOcc+                            , dcolon unicode+                            -- ++AZ++ make this prepend "{..}" when it is a record style GADT+                            , ppLSigType unicode (getGADTConType con)+                            ]++    fieldPart = case con of+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of+          -- GADT record declarations+          RecConGADT _ _                  -> doConstrArgsWithDocs []+          -- GADT prefix data constructors+          PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)+          _                               -> empty++        ConDeclH98{con_args = con_args'} -> case con_args' of+          -- H98 record declarations+          RecCon (L _ fields)             -> doRecordFields fields+          -- H98 prefix data constructors+          PrefixCon _ args | hasArgDocs   -> doConstrArgsWithDocs (map hsScaledThing args)+          -- H98 infix data constructor+          InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])+          _                               -> empty++    doRecordFields fields =+      vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl+           | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields+           ]+      $$+      empty <-> tt (text "\\qquad \\}") <+> nl++    doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of+      ConDeclH98{} ->+        [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl+        | (i, arg) <- zip [0..] args+        , let mdoc = Map.lookup i argDocs+        ]+      ConDeclGADT{} ->+        [ l <+> text "\\enspace" <+> r+        | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode)+        ]+++    -- don't use "con_doc con", in case it's reconstructed from a .hi file,+    -- or also because we want Haddock to do the doc-parsing, not GHC.+    mbDoc = case getConNamesI con of+              cn:|_ -> lookup (unLoc cn) subdocs >>=+                        fmap _doc . combineDocumentation . fst+++-- | Pretty-print a record field+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI ->  LaTeX+ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =+  decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names))+    <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc+  where+    -- don't use cd_fld_doc for same reason we don't use con_doc above+    -- Where there is more than one name, they all have the same documentation+    mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst+++-- | Pretty-print a bundled pattern synonym+ppSideBySidePat :: [LocatedN DocName]   -- ^ pattern name(s)+                -> LHsSigType DocNameI  -- ^ type of pattern(s)+                -> DocForDecl DocName   -- ^ doc map+                -> Bool                 -- ^ unicode+                -> LaTeX+ppSideBySidePat lnames typ (doc, argDocs) unicode =+  decltt decl <-> rDoc mDoc <+> nl+  $$ fieldPart+  where+    hasArgDocs = not $ Map.null argDocs+    ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames))++    decl | hasArgDocs = keyword "pattern" <+> ppOcc+         | otherwise = hsep [ keyword "pattern"+                            , ppOcc+                            , dcolon unicode+                            , ppLSigType unicode typ+                            ]++    fieldPart+      | not hasArgDocs = empty+      | otherwise = vcat+          [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r+          | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode)+          ]++    mDoc = fmap _doc $ combineDocumentation doc+++-- | Print the LHS of a data\/newtype declaration.+-- Currently doesn't handle 'data instance' decls or kind signatures+ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX+ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars+                       , tcdDataDefn = HsDataDefn { dd_cons = cons, dd_ctxt = ctxt } }) unicode+  = -- newtype or data+    (case cons of+        { NewTypeCon _ -> keyword "newtype"+        ; DataTypeCons False _ -> keyword "data"+        ; DataTypeCons True _ -> keyword "type" <+> keyword "data"+        }) <+>+    -- context+    ppLContext ctxt unicode <+>+    -- T a b c ..., or a :+: b+    ppAppDocNameNames False name (tyvarNames tyvars)+ppDataHeader _ _ = error "ppDataHeader: illegal argument"+++--------------------------------------------------------------------------------+-- * Type applications+--------------------------------------------------------------------------------++ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>+  Bool -> DocName -> [LHsTyVarBndr flag DocNameI] -> LaTeX+ppAppDocNameTyVarBndrs unicode n vs =+    ppTypeApp n vs ppDN (ppHsTyVarBndr unicode . unLoc)+  where+    ppDN = ppBinder . nameOccName . getName+++-- | Print an application of a DocName to its list of HsTypes+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)++ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Bool -> LaTeX+ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) unicode+  = ppTypeApp n args ppDocName (ppLHsTypeArg unicode)+ppAppNameTypeArgs n args unicode+  = ppDocName n <+> hsep (map (ppLHsTypeArg unicode) args)++-- | Print an application of a DocName and a list of Names+ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX+ppAppDocNameNames _summ n ns =+  ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName+++-- | General printing of type applications+ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX+ppTypeApp n (t1:t2:rest) ppDN ppT+  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)+  | operator                    = opApp+  where+    operator = isNameSym . getName $ n+    opApp = ppT t1 <+> ppDN n <+> ppT t2++ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)++-------------------------------------------------------------------------------+-- * Contexts+-------------------------------------------------------------------------------+++ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX+ppLContext Nothing _ = empty+ppLContext (Just ctxt) unicode  = ppContext (unLoc ctxt) unicode++ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX+ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode++ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX+ppContextNoLocsMaybe [] _ = Nothing+ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode++ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX+ppContextNoArrow cxt unicode = fromMaybe empty $+                               ppContextNoLocsMaybe (map unLoc cxt) unicode+++ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX+ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $+                              ppContextNoLocsMaybe cxt unicode+++ppContext :: HsContext DocNameI -> Bool -> LaTeX+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode+++pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX+pp_hs_context []  _       = empty+pp_hs_context [p] unicode = ppCtxType unicode p+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)+++-------------------------------------------------------------------------------+-- * Types and contexts+-------------------------------------------------------------------------------+++ppBang :: HsSrcBang -> LaTeX+ppBang (HsSrcBang _ _ SrcStrict) = char '!'+ppBang (HsSrcBang _ _ SrcLazy)   = char '~'+ppBang _                         = empty+++tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX+tupleParens HsUnboxedTuple = ubxParenList+tupleParens _              = parenList+++sumParens :: [LaTeX] -> LaTeX+sumParens = ubxparens . hsep . punctuate (text " |")+++-------------------------------------------------------------------------------+-- * Rendering of HsType+--+-- Stolen from Html and tweaked for LaTeX generation+-------------------------------------------------------------------------------++ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX+ppLType       unicode y = ppType unicode (unLoc y)+ppLParendType unicode y = ppParendType unicode (unLoc y)+ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y)++ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX+ppLSigType unicode y = ppSigType unicode (unLoc y)++ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX+ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode+ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode+ppCtxType    unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode++ppSigType :: Bool -> HsSigType DocNameI -> LaTeX+ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode++ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX+ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty+ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>+                                       ppLParendType unicode ki+ppLHsTypeArg _ (HsArgPar _) = text ""++class RenderableBndrFlag flag where+  ppHsTyVarBndr :: Bool -> HsTyVarBndr flag DocNameI -> LaTeX++instance RenderableBndrFlag () where+  ppHsTyVarBndr _ (UserTyVar _ _ (L _ name)) = ppDocName name+  ppHsTyVarBndr unicode (KindedTyVar _ _ (L _ name) kind) =+    parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind++instance RenderableBndrFlag Specificity where+  ppHsTyVarBndr _ (UserTyVar _ SpecifiedSpec (L _ name)) = ppDocName name+  ppHsTyVarBndr _ (UserTyVar _ InferredSpec (L _ name)) = braces $ ppDocName name+  ppHsTyVarBndr unicode (KindedTyVar _ SpecifiedSpec (L _ name) kind) =+    parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind+  ppHsTyVarBndr unicode (KindedTyVar _ InferredSpec (L _ name) kind) =+    braces (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind++ppLKind :: Bool -> LHsKind DocNameI -> LaTeX+ppLKind unicode y = ppKind unicode (unLoc y)++ppKind :: Bool -> HsKind DocNameI -> LaTeX+ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode++-- Drop top-level for-all type variables in user style+-- since they are implicit in Haskell++ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode+  = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode+        , ppr_mono_lty ltype unicode ]++ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX+ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode+++ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX+ppr_mono_ty (HsForAllTy _ tele ty) unicode+  = sep [ ppHsForAllTelescope tele unicode+        , ppr_mono_lty ty unicode ]+ppr_mono_ty (HsQualTy _ ctxt ty) unicode+  = sep [ ppLContext (Just ctxt) unicode+        , ppr_mono_lty ty unicode ]+ppr_mono_ty (HsFunTy _ mult ty1 ty2)   u+  = sep [ ppr_mono_lty ty1 u+        , arr <+> ppr_mono_lty ty2 u ]+   where arr = case mult of+                 HsLinearArrow _ -> lollipop u+                 HsUnrestrictedArrow _ -> arrow u+                 HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u++ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name+ppr_mono_ty (HsTyVar _ IsPromoted  (L _ name)) _ = char '\'' <> ppDocName name+ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)+ppr_mono_ty (HsSumTy _ tys) u       = sumParens (map (ppLType u) tys)+ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)+ppr_mono_ty (HsListTy _ ty)       u = brackets (ppr_mono_lty ty u)+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u+ppr_mono_ty (HsSpliceTy v _)    _ = dataConCantHappen v+ppr_mono_ty (HsRecTy {})        _ = text "{..}"+ppr_mono_ty (XHsType {})        _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys++ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode+  = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode]++ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode+  = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode]++ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode+  = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode+  where+    ppr_op_prom | isPromoted prom+                = char '\'' <> ppr_op+                | otherwise+                = ppr_op+    ppr_op | isSymOcc (getOccName op) = ppLDocName op+           | otherwise = char '`' <> ppLDocName op <> char '`'++ppr_mono_ty (HsParTy _ ty) unicode+  = parens (ppr_mono_lty ty unicode)+--  = ppr_mono_lty ty unicode++ppr_mono_ty (HsDocTy _ ty _) unicode+  = ppr_mono_lty ty unicode++ppr_mono_ty (HsWildCardTy _) _ = char '_'++ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u+ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)+++ppr_tylit :: HsTyLit DocNameI -> Bool -> LaTeX+ppr_tylit (HsNumTy _ n) _ = integer n+ppr_tylit (HsStrTy _ s) _ = text (show s)+ppr_tylit (HsCharTy _ c) _ = text (show c)+  -- XXX: Ok in verbatim, but not otherwise+  -- XXX: Do something with Unicode parameter?+++-------------------------------------------------------------------------------+-- * Names+-------------------------------------------------------------------------------+++ppBinder :: OccName -> LaTeX+ppBinder n+  | isSymOcc n = parens $ ppOccName n+  | otherwise  = ppOccName n++ppBinderInfix :: OccName -> LaTeX+ppBinderInfix n+  | isSymOcc n = ppOccName n+  | otherwise  = cat [ char '`', ppOccName n, char '`' ]++ppSymName :: Name -> LaTeX+ppSymName name+  | isNameSym name = parens $ ppName name+  | otherwise = ppName name+++ppIPName :: HsIPName -> LaTeX+ppIPName = text . ('?':) . unpackFS . hsIPNameFS++ppOccName :: OccName -> LaTeX+ppOccName = text . occNameString+++ppDocName :: DocName -> LaTeX+ppDocName = ppOccName . nameOccName . getName++ppLDocName :: GenLocated l DocName -> LaTeX+ppLDocName (L _ d) = ppDocName d+++ppDocBinder :: DocName -> LaTeX+ppDocBinder = ppBinder . nameOccName . getName+++ppName :: Name -> LaTeX+ppName = ppOccName . nameOccName+++latexFilter :: String -> String+latexFilter = foldr latexMunge ""+++latexMonoFilter :: String -> String+latexMonoFilter = foldr latexMonoMunge ""+++latexMunge :: Char -> String -> String+latexMunge '#'  s = "{\\char '43}" ++ s+latexMunge '$'  s = "{\\char '44}" ++ s+latexMunge '%'  s = "{\\char '45}" ++ s+latexMunge '&'  s = "{\\char '46}" ++ s+latexMunge '~'  s = "{\\char '176}" ++ s+latexMunge '_'  s = "{\\char '137}" ++ s+latexMunge '^'  s = "{\\char '136}" ++ s+latexMunge '\\' s = "{\\char '134}" ++ s+latexMunge '{'  s = "{\\char '173}" ++ s+latexMunge '}'  s = "{\\char '175}" ++ s+latexMunge '['  s = "{\\char 91}" ++ s+latexMunge ']'  s = "{\\char 93}" ++ s+latexMunge c    s = c : s+++latexMonoMunge :: Char -> String -> String+latexMonoMunge ' '      (' ':s) = "\\ \\ " ++ s+latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s+latexMonoMunge '\n' s = '\\' : '\\' : s+latexMonoMunge c s = latexMunge c s+++-------------------------------------------------------------------------------+-- * Doc Markup+-------------------------------------------------------------------------------+++latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX)+latexMarkup = Markup+  { markupParagraph            = \p v -> blockElem (p v (text "\\par"))+  , markupEmpty                = \_ -> id+  , markupString               = \s v -> inlineElem (text (fixString v s))+  , markupAppend               = \l r v -> l v . r v+  , markupIdentifier           = \i v -> inlineElem (markupId v (fmap occName i))+  , markupIdentifierUnchecked  = \i v -> inlineElem (markupId v (fmap snd i))+  , markupModule               =+      \(ModLink m mLabel) v ->+        case mLabel of+          Just lbl -> inlineElem . tt $ lbl v empty+          Nothing -> inlineElem (let (mdl,_ref) = break (=='#') m+                                 in (tt (text mdl)))+  , markupWarning              = \p v -> p v+  , markupEmphasis             = \p v -> inlineElem (emph (p v empty))+  , markupBold                 = \p v -> inlineElem (bold (p v empty))+  , markupMonospaced           = \p v -> inlineElem (markupMonospace p v)+  , markupUnorderedList        = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p))+  , markupPic                  = \p _ -> inlineElem (markupPic p)+  , markupMathInline           = \p _ -> inlineElem (markupMathInline p)+  , markupMathDisplay          = \p _ -> blockElem (markupMathDisplay p)+  , markupOrderedList          = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p))+  , markupDefList              = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l))+  , markupCodeBlock            = \p _ -> blockElem (quote (verb (p Verb empty)))+  , markupHyperlink            = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))+  , markupAName                = \_ _ -> id -- TODO+  , markupProperty             = \p _ -> blockElem (quote (verb (text p)))+  , markupExample              = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e)))+  , markupHeader               = \(Header l h) p -> blockElem (header l (h p empty))+  , markupTable                = \(Table h b) p -> blockElem (table h b p)+  }+  where+    blockElem :: LaTeX -> LaTeX -> LaTeX+    blockElem = ($$)++    inlineElem :: LaTeX -> LaTeX -> LaTeX+    inlineElem = (<>)++    header 1 d = text "\\section*" <> braces d+    header 2 d = text "\\subsection*" <> braces d+    header l d+      | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d+    header l _ = error $ "impossible header level in LaTeX generation: " ++ show l++    table _ _ _ = text "{TODO: Table}"++    fixString Plain s = latexFilter s+    fixString Verb  s = s+    fixString Mono  s = latexMonoFilter s++    markupMonospace p Verb = p Verb empty+    markupMonospace p _ = tt (p Mono empty)++    markupLink url mLabel = case mLabel of+      Just label -> text "\\href" <> braces (text url) <> braces label+      Nothing    -> text "\\url"  <> braces (text url)++    -- Is there a better way of doing this? Just a space is an arbitrary choice.+    markupPic (Picture uri title) = parens (imageText title)+      where+        imageText Nothing = beg+        imageText (Just t) = beg <> text " " <> text t++        beg = text "image: " <> text uri++    markupMathInline mathjax = text "\\(" <> text mathjax <> text "\\)"++    markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]"++    markupId v wrappedOcc =+      case v of+        Verb  -> text i+        Mono  -> text "\\haddockid" <> braces (text . latexMonoFilter $ i)+        Plain -> text "\\haddockid" <> braces (text . latexFilter $ i)+      where i = showWrapped occNameString wrappedOcc++docToLaTeX :: Doc DocName -> LaTeX+docToLaTeX doc = markup latexMarkup doc Plain empty++documentationToLaTeX :: Documentation DocName -> Maybe LaTeX+documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation+++rdrDocToLaTeX :: Doc RdrName -> LaTeX+rdrDocToLaTeX doc = markup latexMarkup doc Plain empty+++data StringContext+  = Plain  -- ^ all special characters have to be escape+  | Mono   -- ^ on top of special characters, escape space characters+  | Verb   -- ^ don't escape anything+++latexStripTrailingWhitespace :: Doc a -> Doc a+latexStripTrailingWhitespace (DocString s)+  | null s'   = DocEmpty+  | otherwise = DocString s+  where s' = reverse (dropWhile isSpace (reverse s))+latexStripTrailingWhitespace (DocAppend l r)+  | DocEmpty <- r' = latexStripTrailingWhitespace l+  | otherwise      = DocAppend l r'+  where+    r' = latexStripTrailingWhitespace r+latexStripTrailingWhitespace (DocParagraph p) =+  latexStripTrailingWhitespace p+latexStripTrailingWhitespace other = other+++-------------------------------------------------------------------------------+-- * LaTeX utils+-------------------------------------------------------------------------------+++itemizedList :: [LaTeX] -> LaTeX+itemizedList items =+  text "\\vbox{\\begin{itemize}" $$+  vcat (map (text "\\item" $$) items) $$+  text "\\end{itemize}}"+++enumeratedList :: [LaTeX] -> LaTeX+enumeratedList items =+  text "\\vbox{\\begin{enumerate}" $$+  vcat (map (text "\\item " $$) items) $$+  text "\\end{enumerate}}"+++descriptionList :: [(LaTeX,LaTeX)] -> LaTeX+descriptionList items =+  text "\\vbox{\\begin{description}" $$+  vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$+  text "\\end{description}}"+++tt :: LaTeX -> LaTeX+tt ltx = text "\\haddocktt" <> braces ltx+++decltt :: LaTeX -> LaTeX+decltt ltx = text "\\haddockdecltt" <> braces (text filtered)+  where filtered = latexMonoFilter (latex2String ltx)++emph :: LaTeX -> LaTeX+emph ltx = text "\\emph" <> braces ltx++bold :: LaTeX -> LaTeX+bold ltx = text "\\textbf" <> braces ltx++-- TODO: @verbatim@ is too much since+--+--   * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX+--     representing that markup gets printed verbatim+--   * Verbatim environments are not supported everywhere (example: not nested+--     inside a @tabulary@ environment)+verb :: LaTeX -> LaTeX+verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"+   -- NB. swallow a trailing \n in the verbatim text by appending the+   -- \end{verbatim} directly, otherwise we get spurious blank lines at the+   -- end of code blocks.+++quote :: LaTeX -> LaTeX+quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"+++dcolon, arrow, lollipop, darrow, forallSymbol, starSymbol, atSign :: Bool -> LaTeX+dcolon unicode = text (if unicode then "∷" else "::")+arrow  unicode = text (if unicode then "→" else "->")+lollipop unicode = text (if unicode then "⊸" else "%1 ->")+darrow unicode = text (if unicode then "⇒" else "=>")+forallSymbol unicode = text (if unicode then "∀" else "forall")+starSymbol unicode = text (if unicode then "★" else "*")+atSign unicode = text (if unicode then "@" else "@")++multAnnotation :: LaTeX+multAnnotation = text "%"++dot :: LaTeX+dot = char '.'+++parenList :: [LaTeX] -> LaTeX+parenList = parens . hsep . punctuate comma+++ubxParenList :: [LaTeX] -> LaTeX+ubxParenList = ubxparens . hsep . punctuate comma+++ubxparens :: LaTeX -> LaTeX+ubxparens h = text "(#" <+> h <+> text "#)"   nl :: LaTeX
src/Haddock/Backends/Xhtml.hs view
@@ -11,10 +11,17 @@ -- Stability   :  experimental -- Portability :  portable ------------------------------------------------------------------------------{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE BangPatterns     #-}+ module Haddock.Backends.Xhtml (   ppHtml, copyHtmlBits,   ppHtmlIndex, ppHtmlContents,+  ppJsonIndex ) where  @@ -27,108 +34,154 @@ import Haddock.Backends.Xhtml.Themes import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils+import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo) import Haddock.ModuleTree+import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Version import Haddock.Utils+import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote )+import qualified Text.XHtml as XHtml import Haddock.GhcUtils  import Control.Monad         ( when, unless )+import qualified Data.ByteString.Builder as Builder+import Control.DeepSeq       (force)+import Data.Bifunctor        ( bimap ) import Data.Char             ( toUpper, isSpace )-import Data.List             ( sortBy, intercalate, isPrefixOf, intersperse )+import Data.Either           ( partitionEithers )+import Data.Foldable         ( traverse_, foldl')+import Data.List             ( sortBy, isPrefixOf, intersperse ) import Data.Maybe-import System.FilePath hiding ( (</>) ) import System.Directory-import Data.Map              ( Map )-import qualified Data.Map as Map hiding ( Map )+import System.FilePath hiding ( (</>) )+import qualified System.IO as IO+import qualified System.FilePath as FilePath+import Data.Map.Strict       (Map)+import qualified Data.Map.Strict as Map import qualified Data.Set as Set hiding ( Set ) import Data.Ord              ( comparing ) -import DynFlags (Language(..))-import GHC hiding ( NoLink, moduleInfo )-import Name-import Module+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor )+import GHC.Types.Name+import GHC.Unit.State  -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- --ppHtml :: DynFlags+ppHtml :: UnitState        -> String                       -- ^ Title        -> Maybe String                 -- ^ Package        -> [Interface]+       -> [InstalledInterface]         -- ^ Reexported interfaces        -> FilePath                     -- ^ Destination directory        -> Maybe (MDoc GHC.RdrName)     -- ^ Prologue text, maybe        -> Themes                       -- ^ Themes        -> Maybe String                 -- ^ The mathjax URL (--mathjax)        -> SourceURLs                   -- ^ The source URL (--source)        -> WikiURLs                     -- ^ The wiki URL (--wiki)+       -> BaseURL                      -- ^ The base URL (--base-url)        -> Maybe String                 -- ^ The contents URL (--use-contents)        -> Maybe String                 -- ^ The index URL (--use-index)        -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)+       -> Maybe String                 -- ^ Package name+       -> PackageInfo                  -- ^ Package info        -> QualOption                   -- ^ How to qualify names        -> Bool                         -- ^ Output pretty html (newlines and indenting)+       -> Bool                         -- ^ Also write Quickjump index        -> IO () -ppHtml dflags doctitle maybe_package ifaces odir prologue+ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue         themes maybe_mathjax_url maybe_source_url maybe_wiki_url-        maybe_contents_url maybe_index_url unicode-        qual debug =  do+        maybe_base_url maybe_contents_url maybe_index_url unicode+        pkg packageInfo qual debug withQuickjump = do   let     visible_ifaces = filter visible ifaces     visible i = OptHide `notElem` ifaceOptions i    when (isNothing maybe_contents_url) $-    ppHtmlContents dflags odir doctitle maybe_package+    ppHtmlContents state odir doctitle maybe_package         themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url-        (map toInstalledIface visible_ifaces)+        withQuickjump+        [PackageInterfaces+          { piPackageInfo = packageInfo+          , piVisibility  = Visible+          , piInstalledInterfaces = map toInstalledIface visible_ifaces+                                 ++ reexported_ifaces+          }]         False -- we don't want to display the packages in a single-package contents-        prologue debug (makeContentsQual qual)+        prologue debug pkg (makeContentsQual qual) -  when (isNothing maybe_index_url) $+  when (isNothing maybe_index_url) $ do     ppHtmlIndex odir doctitle maybe_package       themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url-      (map toInstalledIface visible_ifaces) debug+      withQuickjump+      (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug +  when withQuickjump $+    ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual+      visible_ifaces []+   mapM_ (ppHtmlModule odir doctitle themes-           maybe_mathjax_url maybe_source_url maybe_wiki_url-           maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces+           maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+           maybe_contents_url maybe_index_url withQuickjump+           unicode pkg qual debug) visible_ifaces  -copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()-copyHtmlBits odir libdir themes = do+copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()+copyHtmlBits odir libdir themes withQuickjump = do   let     libhtmldir = joinPath [libdir, "html"]     copyCssFile f = copyFile f (combine odir (takeFileName f))     copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])   mapM_ copyCssFile (cssFiles themes)-  copyLibFile jsFile+  copyLibFile haddockJsFile+  copyCssFile (joinPath [libhtmldir, quickJumpCssFile])+  when withQuickjump (copyLibFile jsQuickJumpFile)   return ()  -headHtml :: String -> Maybe String -> Themes -> Maybe String -> Html-headHtml docTitle miniPage themes mathjax_url =-  header << [-    meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],-    thetitle << docTitle,-    styleSheet themes,-    script ! [src jsFile, thetype "text/javascript"] << noHtml,-    script ! [src mjUrl, thetype "text/javascript"] << noHtml,-    script ! [thetype "text/javascript"]-        -- NB: Within XHTML, the content of script tags needs to be-        -- a <![CDATA[ section. Will break if the miniPage name could-        -- have "]]>" in it!-      << primHtml (-          "//<![CDATA[\nwindow.onload = function () {pageLoad();"-          ++ setSynopsis ++ "};\n//]]>\n")+headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html+headHtml docTitle themes mathjax_url base_url =+      header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url)+    <<+    [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"]+    , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"]+    , thetitle << docTitle+    , styleSheet base_url themes+    , thelink ! [ rel "stylesheet"+                , thetype "text/css"+                , href (withBaseURL base_url quickJumpCssFile) ]+             << noHtml+    , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml+    , script ! [ src (withBaseURL base_url haddockJsFile)+               , emptyAttr "async"+               , thetype "text/javascript" ]+            << noHtml+    , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf+    , script ! [src mjUrl, thetype "text/javascript"] << noHtml     ]   where-    setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage-    mjUrl = maybe "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url+    fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"+    mjUrl = fromMaybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" mathjax_url+    mjConf = unwords [ "MathJax.Hub.Config({"+                     ,   "tex2jax: {"+                     ,     "processClass: \"mathjax\","+                     ,     "ignoreClass: \".*\""+                     ,   "}"+                     , "});" ] +quickJumpButtonLi :: Bool  -- ^ With Quick Jump?+                  -> Maybe Html+-- The TypeScript should replace this <li> element, given its id. However, in+-- case it does not, the element is given content here too.+quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"]+  << anchor ! [href "#"] << "Quick Jump" +quickJumpButtonLi False = Nothing+ srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing =   Just (anchor ! [href src_base_url] << "Source")@@ -167,20 +220,18 @@ bodyHtml :: String -> Maybe Interface     -> SourceURLs -> WikiURLs     -> Maybe String -> Maybe String+    -> Bool  -- ^ With Quick Jump?     -> Html -> Html bodyHtml doctitle iface            maybe_source_url maybe_wiki_url            maybe_contents_url maybe_index_url+           withQuickjump            pageContent =-  body ! [theclass "no-frame"] << [+  body << [     divPackageHeader << [-      unordList (catMaybes [-        srcButton maybe_source_url iface,-        wikiButton maybe_wiki_url (ifaceMod <$> iface),-        contentsButton maybe_contents_url,-        indexButton maybe_index_url])-            ! [theclass "links", identifier "page-menu"],-      nonEmptySectionName << doctitle+      nonEmptySectionName << doctitle,+      ulist ! [theclass "links", identifier "page-menu"]+        << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis)       ],     divContent << pageContent,     divFooter << paragraph << (@@ -189,7 +240,13 @@       (" version " ++ projectVersion)       )     ]-+ where+  otherButtonLis = (fmap . fmap) (li <<)+    [ srcButton maybe_source_url iface+    , wikiButton maybe_wiki_url (ifaceMod <$> iface)+    , contentsButton maybe_contents_url+    , indexButton maybe_index_url+    ]  moduleInfo :: Interface -> Html moduleInfo iface =@@ -210,10 +267,7 @@           ("Language", lg)           ] ++ extsForm         where-          lg inf = case hmi_language inf of-            Nothing -> Nothing-            Just Haskell98 -> Just "Haskell98"-            Just Haskell2010 -> Just "Haskell2010"+          lg inf = fmap show (hmi_language inf)            multilineRow :: String -> [String] -> HtmlTable           multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)@@ -246,7 +300,7 @@   ppHtmlContents-   :: DynFlags+   :: UnitState    -> FilePath    -> String    -> Maybe String@@ -255,82 +309,244 @@    -> Maybe String    -> SourceURLs    -> WikiURLs-   -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)+   -> Bool  -- ^ With Quick Jump?+   -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName)    -> Bool+   -> Maybe Package  -- ^ Current package    -> Qualification  -- ^ How to qualify names    -> IO ()-ppHtmlContents dflags odir doctitle _maybe_package+ppHtmlContents state odir doctitle _maybe_package   themes mathjax_url maybe_index_url-  maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do-  let tree = mkModuleTree dflags showPkgs-         [(instMod iface, toInstalledDescription iface) | iface <- ifaces]+  maybe_source_url maybe_wiki_url withQuickjump+  packages showPkgs prologue debug pkg qual = do+  let trees =+        [ ( piPackageInfo pinfo+          , mkModuleTree state showPkgs+            [(instMod iface, toInstalledDescription iface)+            | iface <- piInstalledInterfaces pinfo+            , not (instIsSig iface)+            ]+          )+        | pinfo <- packages+        ]+      sig_trees =+        [ ( piPackageInfo pinfo+          , mkModuleTree state showPkgs+            [(instMod iface, toInstalledDescription iface)+            | iface <- piInstalledInterfaces pinfo+            , instIsSig iface+            ]+          )+        | pinfo <- packages+        ]       html =-        headHtml doctitle Nothing themes mathjax_url ++++        headHtml doctitle themes mathjax_url Nothing +++         bodyHtml doctitle Nothing           maybe_source_url maybe_wiki_url-          Nothing maybe_index_url << [-            ppPrologue qual doctitle prologue,-            ppModuleTree qual tree+          Nothing maybe_index_url withQuickjump << [+            ppPrologue pkg qual doctitle prologue,+            ppSignatureTrees pkg qual sig_trees,+            ppModuleTrees pkg qual trees           ]   createDirectoryIfMissing True odir-  writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)+  writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)+  where+    -- Extract a module's short description.+    toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)+    toInstalledDescription = fmap mkMeta . hmi_description . instInfo  -ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html-ppPrologue _ _ Nothing = noHtml-ppPrologue qual title (Just doc) =-  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))+ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html+ppPrologue _ _ _ Nothing = noHtml+ppPrologue pkg qual title (Just doc) =+  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) +ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html+ppSignatureTrees _ _ tss | all (null . snd) tss = mempty+ppSignatureTrees pkg qual [(info, ts)] =+  divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)+ppSignatureTrees pkg qual tss =+  divModuleList <<+    (sectionName << "Signatures"+     +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts+                    | (i, (info, ts)) <- zip [(1::Int)..] tss+                    ]) -ppModuleTree :: Qualification -> [ModuleTree] -> Html-ppModuleTree qual ts =-  divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)+ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html+ppSignatureTree _ _ _ _ [] = mempty+ppSignatureTree pkg qual p info ts =+  divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) +ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html+ppModuleTrees _ _ tss | all (null . snd) tss = mempty+ppModuleTrees pkg qual [(info, ts)] =+  divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)+ppModuleTrees pkg qual tss =+  divPackageList <<+    (sectionName << "Packages"+     +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts+                    | (i, (info, ts)) <- zip [(1::Int)..] tss+                    ]) -mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html-mkNodeList qual ss p ts = case ts of+ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html+ppModuleTree _ _ _ _ [] = mempty+ppModuleTree pkg qual p info ts =+  divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts)+++mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html+mkNodeList pkg qual ss p ts = case ts of   [] -> noHtml-  _ -> unordList (zipWith (mkNode qual ss) ps ts)+  _ -> unordList (zipWith (mkNode pkg qual ss) ps ts)   where     ps = [ p ++ '.' : show i | i <- [(1::Int)..]]  -mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html-mkNode qual ss p (Node s leaf pkg srcPkg short ts) =+mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html+mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =   htmlModule <+> shortDescr +++ htmlPkg +++ subtree   where     modAttrs = case (ts, leaf) of-      (_:_, False) -> collapseControl p True "module"+      (_:_, Nothing) -> collapseControl p "module"       (_,   _    ) -> [theclass "module"]      cBtn = case (ts, leaf) of-      (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml+      (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml+      ([] , Just _) -> thespan ! [theclass "noexpander"] << spaceHtml       (_,   _   ) -> noHtml       -- We only need an explicit collapser button when the module name       -- is also a leaf, and so is a link to a module page. Indeed, the       -- spaceHtml is a minor hack and does upset the layout a fraction.      htmlModule = thespan ! modAttrs << (cBtn +++-      if leaf-        then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg))-                                       (mkModuleName mdl))-        else toHtml s+      case leaf of+        Just m -> ppModule m+        Nothing -> toHtml s       ) -    mdl = intercalate "." (reverse (s:ss))--    shortDescr = maybe noHtml (origDocToHtml qual) short+    shortDescr = maybe noHtml (origDocToHtml pkg qual) short     htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg -    subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""--+    subtree =+      if null ts then noHtml else+      collapseDetails p DetailsOpen (+        thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" ++++        mkNodeList pkg qual (s:ss) p ts+      )  -------------------------------------------------------------------------------- -- * Generate the index -------------------------------------------------------------------------------- +data JsonIndexEntry = JsonIndexEntry {+      jieHtmlFragment :: String,+      jieName         :: String,+      jieModule       :: String,+      jieLink         :: String+    }+  deriving Show +instance ToJSON JsonIndexEntry where+    toJSON JsonIndexEntry+        { jieHtmlFragment+        , jieName+        , jieModule+        , jieLink } =+      Object+        [ "display_html" .= String jieHtmlFragment+        , "name"         .= String jieName+        , "module"       .= String jieModule+        , "link"         .= String jieLink+        ]++instance FromJSON JsonIndexEntry where+    parseJSON = withObject "JsonIndexEntry" $ \v ->+      JsonIndexEntry+        <$> v .: "display_html"+        <*> v .: "name"+        <*> v .: "module"+        <*> v .: "link"++ppJsonIndex :: FilePath+           -> SourceURLs                   -- ^ The source URL (--source)+           -> WikiURLs                     -- ^ The wiki URL (--wiki)+           -> Bool+           -> Maybe Package+           -> QualOption+           -> [Interface]+           -> [FilePath]                   -- ^ file paths to interface files+                                           -- (--read-interface)+           -> IO ()+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do+  createDirectoryIfMissing True odir+  (errors, installedIndexes) <-+    partitionEithers+      <$> traverse+            (\ifaceFile -> do+              let indexFile = takeDirectory ifaceFile+                    FilePath.</> "doc-index.json"+              a <- doesFileExist indexFile+              if a then+                    bimap (indexFile,) (map (fixLink ifaceFile))+                <$> eitherDecodeFile @[JsonIndexEntry] indexFile+                   else+                    return (Right [])+            )+            installedIfacesPaths+  traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)+            errors+  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->+      Builder.hPutBuilder+        h (encodeToBuilder (encodeIndexes (concat installedIndexes)))+  where+    encodeIndexes :: [JsonIndexEntry] -> Value+    encodeIndexes installedIndexes =+      toJSON+        (concatMap fromInterface ifaces+         ++ installedIndexes)++    fromInterface :: Interface -> [JsonIndexEntry]+    fromInterface iface =+        mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface+      where+        aliases = ifaceModuleAliases iface+        qual    = makeModuleQual qual_opt aliases mdl+        mdl     = ifaceMod iface++    mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry+    mkIndex mdl qual item+      | Just item_html <- processExport True links_info unicode pkg qual item+      = Just JsonIndexEntry+          { jieHtmlFragment = showHtmlFragment item_html+          , jieName         = unwords (map getOccString names)+          , jieModule       = moduleString mdl+          , jieLink         = fromMaybe "" (listToMaybe (map (nameLink mdl) names))+          }+      | otherwise = Nothing+      where+        names = exportName item ++ exportSubs item++    exportSubs :: ExportItem DocNameI -> [IdP DocNameI]+    exportSubs (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDSubDocs } })) = map fst expDSubDocs+    exportSubs _ = []++    exportName :: ExportItem DocNameI -> [IdP DocNameI]+    exportName (ExportDecl (RnExportD { rnExpDExpD = ExportD { expDDecl } })) = getMainDeclBinderI (unLoc expDDecl)+    exportName ExportNoDecl { expItemName } = [expItemName]+    exportName _ = []++    nameLink :: NamedThing name => Module -> name -> String+    nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName++    links_info = (maybe_source_url, maybe_wiki_url)++    -- update link using relative path to output directory+    fixLink :: FilePath+            -> JsonIndexEntry -> JsonIndexEntry+    fixLink ifaceFile jie =+      jie { jieLink = makeRelative odir (takeDirectory ifaceFile)+                        FilePath.</> jieLink jie }+ ppHtmlIndex :: FilePath             -> String             -> Maybe String@@ -339,11 +555,12 @@             -> Maybe String             -> SourceURLs             -> WikiURLs+            -> Bool  -- ^ With Quick Jump?             -> [InstalledInterface]             -> Bool             -> IO () ppHtmlIndex odir doctitle _maybe_package themes-  maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do+  maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do   let html = indexPage split_indices Nothing               (if split_indices then [] else index) @@ -353,16 +570,16 @@     mapM_ (do_sub_index index) initialChars     -- Let's add a single large index as well for those who don't know exactly what they're looking for:     let mergedhtml = indexPage False Nothing index-    writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)+    writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) -  writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)+  writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html)    where     indexPage showLetters ch items =-      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes maybe_mathjax_url ++++      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++       bodyHtml doctitle Nothing         maybe_source_url maybe_wiki_url-        maybe_contents_url Nothing << [+        maybe_contents_url Nothing withQuickjump << [           if showLetters then indexInitialLetterLinks else noHtml,           if null items then noHtml else             divIndex << [sectionName << indexName ch, buildIndex items]@@ -396,7 +613,7 @@      do_sub_index this_ix c       = unless (null index_part) $-          writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)+          writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)       where         html = indexPage True (Just c) index_part         index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]@@ -411,14 +628,34 @@     -- that export that entity.  Each of the modules exports the entity     -- in a visible or invisible way (hence the Bool).     full_index :: Map String (Map GHC.Name [(Module,Bool)])-    full_index = Map.fromListWith (flip (Map.unionWith (++)))-                 (concatMap getIfaceIndex ifaces)+    full_index = foldl' f Map.empty ifaces+      where+        f :: Map String (Map Name [(Module, Bool)])+          -> InstalledInterface+          -> Map String (Map Name [(Module, Bool)])+        f !idx iface =+          Map.unionWith+            (Map.unionWith (\a b -> let !x = force $ a ++ b in x))+            idx+            (getIfaceIndex iface) ++    getIfaceIndex :: InstalledInterface -> Map String (Map Name [(Module, Bool)])     getIfaceIndex iface =-      [ (getOccString name-         , Map.fromList [(name, [(mdl, name `Set.member` visible)])])-         | name <- instExports iface ]+        foldl' f Map.empty (instExports iface)       where+        f :: Map String (Map Name [(Module, Bool)])+          -> Name+          -> Map String (Map Name [(Module, Bool)])+        f !idx name =+          let !vis =  name `Set.member` visible+          in+            Map.insertWith+              (Map.unionWith (++))+              (getOccString name)+              (Map.singleton name [(mdl, vis)])+              idx+         mdl = instMod iface         visible = Set.fromList (instVisibleExports iface) @@ -459,46 +696,49 @@  ppHtmlModule         :: FilePath -> String -> Themes-        -> Maybe String -> SourceURLs -> WikiURLs-        -> Maybe String -> Maybe String -> Bool -> QualOption+        -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL+        -> Maybe String -> Maybe String+        -> Bool  -- ^ With Quick Jump?+        -> Bool -> Maybe Package -> QualOption         -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes-  maybe_mathjax_url maybe_source_url maybe_wiki_url-  maybe_contents_url maybe_index_url unicode qual debug iface = do+  maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+  maybe_contents_url maybe_index_url withQuickjump+  unicode pkg qual debug iface = do   let       mdl = ifaceMod iface       aliases = ifaceModuleAliases iface       mdl_str = moduleString mdl+      mdl_str_annot = mdl_str ++ if ifaceIsSig iface+                                    then " (signature)"+                                    else ""+      mdl_str_linked+        | ifaceIsSig iface+        = mdl_str +++ " (signature" ++++                       sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) ++++                       ")"+        | otherwise+        = toHtml mdl_str       real_qual = makeModuleQual qual aliases mdl       html =-        headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes maybe_mathjax_url ++++        headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++         bodyHtml doctitle (Just iface)           maybe_source_url maybe_wiki_url-          maybe_contents_url maybe_index_url << [-            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),-            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual+          maybe_contents_url maybe_index_url withQuickjump << [+            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),+            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual           ]    createDirectoryIfMissing True odir-  writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)-  ppHtmlModuleMiniSynopsis odir doctitle themes maybe_mathjax_url iface unicode real_qual debug+  writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes-  -> Maybe String -> Interface -> Bool -> Qualification -> Bool -> IO ()-ppHtmlModuleMiniSynopsis odir _doctitle themes maybe_mathjax_url iface unicode qual debug = do-  let mdl = ifaceMod iface-      html =-        headHtml (moduleString mdl) Nothing themes maybe_mathjax_url +++-        miniBody <<-          (divModuleHeader << sectionName << moduleString mdl +++-           miniSynopsis mdl iface unicode qual)-  createDirectoryIfMissing True odir-  writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)+signatureDocURL :: String+signatureDocURL = "https://wiki.haskell.org/Module_signature"  -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual-  = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) ++++ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual+  = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++     description +++     synopsis +++     divInterface (maybe_doc_hdr +++ bdy +++ orphans)@@ -507,7 +747,17 @@      -- todo: if something has only sub-docs, or fn-args-docs, should     -- it be measured here and thus prevent omitting the synopsis?-    has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning+    has_doc+      ( ExportDecl+        ( RnExportD+          { rnExpDExpD =+            ExportD+            { expDMbDoc =+              ( Documentation mDoc mWarn, _ )+            }+          }+        )+      ) = isJust mDoc || isJust mWarn     has_doc (ExportNoDecl _ _) = False     has_doc (ExportModule _) = False     has_doc _ = True@@ -516,17 +766,19 @@      description | isNoHtml doc = doc                 | otherwise    = divDescription $ sectionName << "Description" +++ doc-                where doc = docSection Nothing qual (ifaceRnDoc iface)+                where doc = docSection Nothing pkg qual (ifaceRnDoc iface)          -- omit the synopsis if there are no documentation annotations at all     synopsis       | no_doc_at_all = noHtml       | otherwise       = divSynopsis $-            paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++-            shortDeclList (-                mapMaybe (processExport True linksInfo unicode qual) exports-            ) ! (collapseSection "syn" False "" ++ collapseToggle "syn")+            collapseDetails "syn" DetailsClosed (+              thesummary << "Synopsis" ++++              shortDeclList (+                  mapMaybe (processExport True linksInfo unicode pkg qual) exports+              ) ! collapseToggle "syn" ""+            )          -- if the documentation doesn't begin with a section header, then         -- add one ("Documentation").@@ -538,76 +790,40 @@      bdy =       foldr (+++) noHtml $-        mapMaybe (processExport False linksInfo unicode qual) exports+        mapMaybe (processExport False linksInfo unicode pkg qual) exports      orphans =-      ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode qual+      ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual      linksInfo = (maybe_source_url, maybe_wiki_url)  -miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html-miniSynopsis mdl iface unicode qual =-    divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports-  where-    exports = numberSectionHeadings (ifaceRnExportItems iface)---processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName-                       -> [Html]-processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =-  ((divTopDecl <<).(declElem <<)) <$> case decl0 of-    TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of-        (FamDecl decl)    -> [ppTyFamHeader True False decl unicode qual]-        (DataDecl{})   -> [keyword "data" <+> b]-        (SynDecl{})    -> [keyword "type" <+> b]-        (ClassDecl {}) -> [keyword "class" <+> b]-    SigD (TypeSig lnames _) ->-      map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames-    _ -> []-processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =-  [groupTag lvl << docToHtml Nothing qual (mkMeta txt)]-processForMiniSynopsis _ _ _ _ = []---ppNameMini :: Notation -> Module -> OccName -> Html-ppNameMini notation mdl nm =-    anchor ! [ href (moduleNameUrl mdl nm)-             , target mainFrameName ]-      << ppBinder' notation nm---ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html-ppTyClBinderWithVarsMini mdl decl =-  let n = tcdName decl-      ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above-  in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName--ppModuleContents :: Qualification-                 -> [ExportItem DocName]-                 -> Bool -- ^ Orphans sections+ppModuleContents :: Maybe Package -- ^ This package+                 -> Qualification+                 -> [ExportItem DocNameI]+                 -> Bool          -- ^ Orphans sections                  -> Html-ppModuleContents qual exports orphan+ppModuleContents pkg qual exports orphan   | null sections && not orphan  = noHtml   | otherwise                    = contentsDiv  where-  contentsDiv = divTableOfContents << (-    sectionName << "Contents" +++-    unordList (sections ++ orphanSection))+  contentsDiv = divTableOfContents << (divContentsList << (+    (sectionName << "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] ++++    unordList (sections ++ orphanSection)))    (sections, _leftovers{-should be []-}) = process 0 exports   orphanSection     | orphan =  [ linkedAnchor "section.orphans" << "Orphan instances" ]     | otherwise = [] -  process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])+  process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI])   process _ [] = ([], [])   process n items@(ExportGroup lev id0 doc : rest)     | lev <= n  = ( [], items )     | otherwise = ( html:secs, rest2 )     where       html = linkedAnchor (groupId id0)-             << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs+             << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs       (ssecs, rest1) = process lev rest       (secs,  rest2) = process n   rest1   process n (_ : rest) = process n rest@@ -617,32 +833,55 @@  -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents:-numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]+numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI] numberSectionHeadings = go 1-  where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]+  where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI]         go _ [] = []         go n (ExportGroup lev _ doc : es)-          = ExportGroup lev (show n) doc : go (n+1) es+          = case collectAnchors doc of+              [] -> ExportGroup lev (show n) doc : go (n+1) es+              (a:_) -> ExportGroup lev a doc : go (n+1) es         go n (other:es)           = other : go n es +        collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String]+        collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b+        collectAnchors (DocAName a) = [a]+        collectAnchors _ = [] -processExport :: Bool -> LinksInfo -> Bool -> Qualification-              -> ExportItem DocName -> Maybe Html-processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances-processExport summary _ _ qual (ExportGroup lev id0 doc)-  = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc)-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)-  = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual-processExport summary _ _ qual (ExportNoDecl y [])+processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification+              -> ExportItem DocNameI -> Maybe Html+processExport _ _ _ _ _+    ( ExportDecl+      ( RnExportD+        { rnExpDExpD =+            ExportD+            { expDDecl = L _ (InstD {})+            }+        }+      )+    )+  = Nothing -- Hide empty instances+processExport summary links unicode pkg qual+    ( ExportDecl+      ( RnExportD+        { rnExpDExpD =+            ExportD decl pats doc subdocs insts fixities splice+        }+      )+    )+  = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual+processExport summary _ _ pkg qual (ExportGroup lev id0 doc)+  = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)+processExport summary _ _ _ qual (ExportNoDecl y [])   = processDeclOneLiner summary $ ppDocName qual Prefix True y-processExport summary _ _ qual (ExportNoDecl y subs)+processExport summary _ _ _ qual (ExportNoDecl y subs)   = processDeclOneLiner summary $       ppDocName qual Prefix True y       +++ parenList (map (ppDocName qual Prefix True) subs)-processExport summary _ _ qual (ExportDoc doc)-  = nothingIf summary $ docSection_ Nothing qual doc-processExport summary _ _ _ (ExportModule mdl)+processExport summary _ _ pkg qual (ExportDoc doc)+  = nothingIf summary $ docSection_ Nothing pkg qual doc+processExport summary _ _ _ _ (ExportModule mdl)   = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl  @@ -664,7 +903,8 @@ processDeclOneLiner False = Just . divTopDecl . declElem  groupHeading :: Int -> String -> Html -> Html-groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]+groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId]+  where grpId = groupId id0  groupTag :: Int -> Html -> Html groupTag lev
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -1,1051 +1,1312 @@ {-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-}--------------------------------------------------------------------------------- |--- Module      :  Haddock.Backends.Html.Decl--- Copyright   :  (c) Simon Marlow   2003-2006,---                    David Waern    2006-2009,---                    Mark Lentczner 2010--- License     :  BSD-like------ Maintainer  :  haddock@projects.haskell.org--- Stability   :  experimental--- Portability :  portable-------------------------------------------------------------------------------module Haddock.Backends.Xhtml.Decl (-  ppDecl,--  ppTyName, ppTyFamHeader, ppTypeApp, ppOrphanInstances,-  tyvarNames-) where--import Haddock.Backends.Xhtml.DocMarkup-import Haddock.Backends.Xhtml.Layout-import Haddock.Backends.Xhtml.Names-import Haddock.Backends.Xhtml.Types-import Haddock.Backends.Xhtml.Utils-import Haddock.GhcUtils-import Haddock.Types-import Haddock.Doc (combineDocumentation)--import           Data.List             ( intersperse, sort )-import qualified Data.Map as Map-import           Data.Maybe-import           Text.XHtml hiding     ( name, title, p, quote )--import GHC-import GHC.Exts-import Name-import BooleanFormula-import RdrName ( rdrNameOcc )--ppDecl :: Bool -> LinksInfo -> LHsDecl DocName-       -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]-       -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of-  TyClD (FamDecl d)         -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual-  TyClD d@(DataDecl {})     -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual-  TyClD d@(SynDecl {})      -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual-  TyClD d@(ClassDecl {})    -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual-  SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames-                                         (hsSigWcType lty) fixities splice unicode qual-  SigD (PatSynSig lname ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname-                                         ty fixities splice unicode qual-  ForD d                         -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual-  InstD _                        -> noHtml-  _                              -> error "declaration not supported by ppDecl"---ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-             [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->-             Splice -> Unicode -> Qualification -> Html-ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =-  ppFunSig summary links loc doc (map unLoc lnames) lty fixities-           splice unicode qual--ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-            [DocName] -> LHsType DocName -> [(DocName, Fixity)] ->-            Splice -> Unicode -> Qualification -> Html-ppFunSig summary links loc doc docnames typ fixities splice unicode qual =-  ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ)-            splice unicode qual-  where-    pp_typ = ppLType unicode qual typ--ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-             Located DocName -> LHsSigType DocName ->-             [(DocName, Fixity)] ->-             Splice -> Unicode -> Qualification -> Html-ppLPatSig summary links loc (doc, _argDocs) (L _ name) typ fixities splice unicode qual-  | summary = pref1-  | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)-                +++ docSection Nothing qual doc-  where-    pref1 = hsep [ keyword "pattern"-                 , ppBinder summary occname-                 , dcolon unicode-                 , ppLType unicode qual (hsSigType typ)-                 ]--    occname = nameOccName . getName $ name--ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->-             [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->-             Splice -> Unicode -> Qualification -> Html-ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)-          splice unicode qual =-  ppTypeOrFunSig summary links loc docnames typ doc-    ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode-    , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames-    , dcolon unicode-    )-    splice unicode qual-  where-    occnames = map (nameOccName . getName) docnames-    addFixities html-      | summary   = html-      | otherwise = html <+> ppFixities fixities qual---ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName-               -> DocForDecl DocName -> (Html, Html, Html)-               -> Splice -> Unicode -> Qualification -> Html-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual-  | summary = pref1-  | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc-  | otherwise = topDeclElem links loc splice docnames pref2 +++-      subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc-  where-    curName = getName <$> listToMaybe docnames-    argDoc n = Map.lookup n argDocs--    do_largs n leader (L _ t) = do_args n leader t--    do_args :: Int -> Html -> HsType DocName -> [SubDecl]-    do_args n leader (HsForAllTy tvs ltype)-      = do_largs n leader' ltype-      where-        leader' = leader <+> ppForAll tvs unicode qual--    do_args n leader (HsQualTy lctxt ltype)-      | null (unLoc lctxt)-      = do_largs n leader ltype-      | otherwise-      = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])-        : do_largs n (darrow unicode) ltype--    do_args n leader (HsFunTy lt r)-      = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])-        : do_largs (n+1) (arrow unicode) r-    do_args n leader t-      = [(leader <+> ppType unicode qual t, argDoc n, [])]--ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html-ppForAll tvs unicode qual =-  case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of-    [] -> noHtml-    ts -> forallSymbol unicode <+> hsep ts +++ dot-  where ppKTv n k = parens $-          ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k--ppFixities :: [(DocName, Fixity)] -> Qualification -> Html-ppFixities [] _ = noHtml-ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge-  where-    ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<-                         (toHtml d <+> toHtml (show p) <+> ppNames ns)--    ppDir InfixR = "infixr"-    ppDir InfixL = "infixl"-    ppDir InfixN = "infix"--    ppNames = case fs of-      _:[] -> const noHtml -- Don't display names for fixities on single names-      _    -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)--    uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs-                                   , let d' = ppDir d-                                   , then group by Down (p,d') using groupWith ]--    rightEdge = thespan ! [theclass "rightedge"] << noHtml----- | Pretty-print type variables.-ppTyVars :: [LHsTyVarBndr DocName] -> [Html]-ppTyVars tvs = map (ppTyName . getName . hsLTyVarName) tvs--tyvarNames :: LHsQTyVars DocName -> [Name]-tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit---ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName-      -> ForeignDecl DocName -> [(DocName, Fixity)]-      -> Splice -> Unicode -> Qualification -> Html-ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities-      splice unicode qual-  = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual-ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"----- we skip type patterns for now-ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan-        -> DocForDecl DocName -> TyClDecl DocName-        -> Splice -> Unicode -> Qualification -> Html-ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars-                                                , tcdRhs = ltype })-        splice unicode qual-  = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc-                   (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)-                   splice unicode qual-  where-    hdr  = hsep ([keyword "type", ppBinder summary occ]-                 ++ ppTyVars (hsQTvExplicit ltyvars))-    full = hdr <+> equals <+> ppLType unicode qual ltype-    occ  = nameOccName . getName $ name-    fixs-      | summary   = noHtml-      | otherwise = ppFixities fixities qual-ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"---ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html-ppTypeSig summary nms pp_ty unicode =-  concatHtml htmlNames <+> dcolon unicode <+> pp_ty-  where-    htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms---ppTyName :: Name -> Html-ppTyName = ppName Prefix---ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan-            -> [DocName] -> HsType DocName-            -> Html-ppSimpleSig links splice unicode qual loc names typ =-    topDeclElem' names $ ppTypeSig True occNames ppTyp unicode-  where-    topDeclElem' = topDeclElem links loc splice-    ppTyp = ppType unicode qual typ-    occNames = map getOccName names-------------------------------------------------------------------------------------- * Type families------------------------------------------------------------------------------------ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html-ppFamilyInfo assoc OpenTypeFamily-    | assoc = keyword "type"-    | otherwise = keyword "type family"-ppFamilyInfo assoc DataFamily-    | assoc = keyword "data"-    | otherwise = keyword "data family"-ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"---ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName-              -> Unicode -> Qualification -> Html-ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info-                                               , fdResultSig = L _ result-                                               , fdInjectivityAnn = injectivity })-              unicode qual =-  (case info of-     OpenTypeFamily-       | associated -> keyword "type"-       | otherwise  -> keyword "type family"-     DataFamily-       | associated -> keyword "data"-       | otherwise  -> keyword "data family"-     ClosedTypeFamily _-                    -> keyword "type family"-  ) <+>--  ppFamDeclBinderWithVars summary unicode qual d <+>-  ppResultSig result unicode qual <+>--  (case injectivity of-     Nothing                   -> noHtml-     Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn-  ) <+>--  (case info of-     ClosedTypeFamily _ -> keyword "where ..."-     _                  -> mempty-  )--ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html-ppResultSig result unicode qual = case result of-    NoSig               -> noHtml-    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind-    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr--ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName-                     -> Html-ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =-    ppFamilyInfo True pfdInfo <+>-    ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>-    ppResultSig (unLoc pfdKindSig) unicode qual--ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html-ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =-    char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+>-    hsep (map (ppLDocName qual Raw) rhs)---ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->-           [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->-           FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html-ppTyFam summary associated links instances fixities loc doc decl splice unicode qual--  | summary   = ppTyFamHeader True associated decl unicode qual-  | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit--  where-    docname = unLoc $ fdLName decl--    header_ = topDeclElem links loc splice [docname] $-       ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual--    instancesBit-      | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl-      , not summary-      = subEquations qual $ map (ppTyFamEqn . unLoc) $ fromMaybe [] mb_eqns--      | otherwise-      = ppInstances links (OriginFamily docname) instances splice unicode qual--    -- Individual equation of a closed type family-    ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs-                        , tfe_pats = HsIB { hsib_body = ts }}-      = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual-          <+> equals <+> ppType unicode qual (unLoc rhs)-        , Nothing, [] )----ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification-                   -> PseudoFamilyDecl DocName-                   -> Html-ppPseudoFamilyDecl links splice unicode qual-                   decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =-    wrapper $ ppPseudoFamilyHeader unicode qual decl-  where-    wrapper = topDeclElem links loc splice [name]-------------------------------------------------------------------------------------- * Associated Types------------------------------------------------------------------------------------ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName-            -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html-ppAssocType summ links doc (L loc decl) fixities splice unicode qual =-   ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual-------------------------------------------------------------------------------------- * TyClDecl helpers------------------------------------------------------------------------------------- | Print a type family and its variables-ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html-ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =-  ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (map unLoc $ hsq_explicit tvs)---- | Print a newtype / data binder and its variables-ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html-ppDataBinderWithVars summ decl =-  ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)------------------------------------------------------------------------------------- * Type applications-----------------------------------------------------------------------------------ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [HsTyVarBndr DocName] -> Html-ppAppDocNameTyVarBndrs summ unicode qual n vs =-    ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual)-  where-    ppDN notation = ppBinderFixity notation summ . nameOccName . getName-    ppBinderFixity Infix = ppBinderInfix-    ppBinderFixity _ = ppBinder---- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types)-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]-               -> Unicode -> Qualification -> Html-ppAppNameTypes n ks ts unicode qual =-    ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)----- | Print an application of a 'DocName' and a list of 'Names'-ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html-ppAppDocNameNames summ n ns =-    ppTypeApp n [] ns ppDN ppTyName-  where-    ppDN notation = ppBinderFixity notation summ . nameOccName . getName-    ppBinderFixity Infix = ppBinderInfix-    ppBinderFixity _ = ppBinder---- | General printing of type applications-ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html-ppTypeApp n [] (t1:t2:rest) ppDN ppT-  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)-  | operator                    = opApp-  where-    operator = isNameSym . getName $ n-    opApp = ppT t1 <+> ppDN Infix n <+> ppT t2--ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)------------------------------------------------------------------------------------- * Contexts-----------------------------------------------------------------------------------ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode-                              -> Qualification -> Html-ppLContext        = ppContext        . unLoc-ppLContextNoArrow = ppContextNoArrow . unLoc--ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html-ppContextNoArrow cxt unicode qual = fromMaybe noHtml $-                                    ppContextNoLocsMaybe (map unLoc cxt) unicode qual---ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html-ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $-                                   ppContextNoLocsMaybe cxt unicode qual---ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html-ppContextNoLocsMaybe []  _       _    = Nothing-ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual--ppContext :: HsContext DocName -> Unicode -> Qualification -> Html-ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual---ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html-ppHsContext []  _       _     = noHtml-ppHsContext [p] unicode qual = ppCtxType unicode qual p-ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)------------------------------------------------------------------------------------- * Class declarations-----------------------------------------------------------------------------------ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName-           -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]-           -> Unicode -> Qualification -> Html-ppClassHdr summ lctxt n tvs fds unicode qual =-  keyword "class"-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)-  <+> ppAppDocNameNames summ n (tyvarNames tvs)-  <+> ppFds fds unicode qual---ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html-ppFds fds unicode qual =-  if null fds then noHtml else-        char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))-  where-        fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2-        ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)--ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan-                 -> [(DocName, DocForDecl DocName)]-                 -> Splice -> Unicode -> Qualification -> Html-ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs-                                          , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc-    subdocs splice unicode qual =-  if not (any isUserLSig sigs) && null ats-    then (if summary then id else topDeclElem links loc splice [nm]) hdr-    else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")-      +++ shortSubDecls False-          (-            [ ppAssocType summary links doc at [] splice unicode qual | at <- ats-              , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]  ++--                -- ToDo: add associated type defaults--            [ ppFunSig summary links loc doc names (hsSigWcType typ)-                       [] splice unicode qual-              | L _ (TypeSig lnames typ) <- sigs-              , let doc = lookupAnySubdoc (head names) subdocs-                    names = map unLoc lnames ]-              -- FIXME: is taking just the first name ok? Is it possible that-              -- there are different subdocs for different names in a single-              -- type signature?-          )-  where-    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual-    nm  = unLoc lname-ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"----ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]-            -> SrcSpan -> Documentation DocName-            -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName-            -> Splice -> Unicode -> Qualification -> Html-ppClassDecl summary links instances fixities loc d subdocs-        decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars-                        , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })-            splice unicode qual-  | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual-  | otherwise = classheader +++ docSection Nothing qual d-                  +++ minimalBit +++ atBit +++ methodBit +++ instancesBit-  where-    sigs = map unLoc lsigs--    classheader-      | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)-      | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)--    -- Only the fixity relevant to the class header-    fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual--    nm   = tcdName decl--    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds--    -- ToDo: add assocatied typ defaults-    atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual-                      | at <- ats-                      , let n = unL . fdLName $ unL at-                            doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs-                            subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]--    methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)-                                      subfixs splice unicode qual-                           | L _ (ClassOpSig _ lnames typ) <- lsigs-                           , let doc = lookupAnySubdoc (head names) subdocs-                                 subfixs = [ f | n <- names-                                               , f@(n',_) <- fixities-                                               , n == n' ]-                                 names = map unLoc lnames ]-                           -- FIXME: is taking just the first name ok? Is it possible that-                           -- there are different subdocs for different names in a single-                           -- type signature?--    minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of-      -- Miminal complete definition = every shown method-      And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==-                   sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]-        -> noHtml--      -- Minimal complete definition = the only shown method-      Var (L _ n) : _ | [getName n] ==-                        [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]-        -> noHtml--      -- Minimal complete definition = nothing-      And [] : _ -> subMinimal $ toHtml "Nothing"--      m : _  -> subMinimal $ ppMinimal False m-      _ -> noHtml--    ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n-    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs-    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs-      where wrap | p = parens | otherwise = id-    ppMinimal p (Parens x) = ppMinimal p (unLoc x)--    instancesBit = ppInstances links (OriginClass nm) instances-        splice unicode qual--ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"---ppInstances :: LinksInfo-            -> InstOrigin DocName -> [DocInstance DocName]-            -> Splice -> Unicode -> Qualification-            -> Html-ppInstances links origin instances splice unicode qual-  = subInstances qual instName links True (zipWith instDecl [1..] instances)-  -- force Splice = True to use line URLs-  where-    instName = getOccString origin-    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)-    instDecl no (inst, mdoc, loc) =-        ((ppInstHead links splice unicode qual mdoc origin False no inst), loc)---ppOrphanInstances :: LinksInfo-                  -> [DocInstance DocName]-                  -> Splice -> Unicode -> Qualification-                  -> Html-ppOrphanInstances links instances splice unicode qual-  = subOrphanInstances qual links True (zipWith instDecl [1..] instances)-  where-    instOrigin :: InstHead name -> InstOrigin name-    instOrigin inst = OriginClass (ihdClsName inst)--    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)-    instDecl no (inst, mdoc, loc) =-        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc)---ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification-           -> Maybe (MDoc DocName)-           -> InstOrigin DocName-           -> Bool -- ^ Is instance orphan-           -> Int  -- ^ Normal-           -> InstHead DocName-           -> SubDecl-ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =-    case ihdInstType of-        ClassInst { .. } ->-            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ-            , mdoc-            , [subInstDetails iid ats sigs]-            )-          where-            sigs = ppInstanceSigs links splice unicode qual clsiSigs-            ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys-        TypeInst rhs ->-            ( subInstHead iid ptype-            , mdoc-            , [subFamInstDetails iid prhs]-            )-          where-            ptype = keyword "type" <+> typ-            prhs = ptype <+> maybe noHtml-                                   (\t -> equals <+> ppType unicode qual t) rhs-        DataInst dd ->-            ( subInstHead iid pdata-            , mdoc-            , [subFamInstDetails iid pdecl])-          where-            pdata = keyword "data" <+> typ-            pdecl = pdata <+> ppShortDataDecl False True dd unicode qual-  where-    iid = instanceId origin no orphan ihd-    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual---ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification-                   -> [PseudoFamilyDecl DocName]-                   -> [Html]-ppInstanceAssocTys links splice unicode qual =-    map ppFamilyDecl'-  where-    ppFamilyDecl' = ppPseudoFamilyDecl links splice unicode qual---ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification-              -> [Sig DocName]-              -> [Html]-ppInstanceSigs links splice unicode qual sigs = do-    TypeSig lnames typ <- sigs-    let names = map unLoc lnames-        L loc rtyp = get_type typ-    return $ ppSimpleSig links splice unicode qual loc names rtyp-    where-      get_type = hswc_body . hsib_body---lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2-lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n---instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String-instanceId origin no orphan ihd = concat $-    [ "o:" | orphan ] ++-    [ qual origin-    , ":" ++ getOccString origin-    , ":" ++ (occNameString . getOccName . ihdClsName) ihd-    , ":" ++ show no-    ]-  where-    qual (OriginClass _) = "ic"-    qual (OriginData _) = "id"-    qual (OriginFamily _) = "if"------------------------------------------------------------------------------------- * Data & newtype declarations------------------------------------------------------------------------------------- TODO: print contexts-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html-ppShortDataDecl summary dataInst dataDecl unicode qual--  | [] <- cons = dataHeader--  | [lcon] <- cons, isH98,-    (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual-       = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot--  | isH98 = dataHeader-      +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)--  | otherwise = (dataHeader <+> keyword "where")-      +++ shortSubDecls dataInst (map doGADTConstr cons)--  where-    dataHeader-      | dataInst  = noHtml-      | otherwise = ppDataHeader summary dataDecl unicode qual-    doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual-    doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual--    cons      = dd_cons (tcdDataDefn dataDecl)-    isH98     = case unLoc (head cons) of-                  ConDeclH98 {} -> True-                  ConDeclGADT{} -> False---ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->-              [(DocName, DocForDecl DocName)] ->-              SrcSpan -> Documentation DocName -> TyClDecl DocName ->-              Splice -> Unicode -> Qualification -> Html-ppDataDecl summary links instances fixities subdocs loc doc dataDecl-           splice unicode qual--  | summary   = ppShortDataDecl summary False dataDecl unicode qual-  | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit--  where-    docname   = tcdName dataDecl-    cons      = dd_cons (tcdDataDefn dataDecl)-    isH98     = case unLoc (head cons) of-                  ConDeclH98 {} -> True-                  ConDeclGADT{} -> False--    header_ = topDeclElem links loc splice [docname] $-             ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix--    fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual--    whereBit-      | null cons = noHtml-      | otherwise = if isH98 then noHtml else keyword "where"--    constrBit = subConstructors qual-      [ ppSideBySideConstr subdocs subfixs unicode qual c-      | c <- cons-      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)-                                     (map unLoc (getConNames (unLoc c)))) fixities-      ]--    instancesBit = ppInstances links (OriginData docname) instances-        splice unicode qual----ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html-ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot-  where-    (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual----- returns three pieces: header, body, footer so that header & footer can be--- incorporated into the declaration-ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)-ppShortConstrParts summary dataInst con unicode qual = case con of-  ConDeclH98{} -> case con_details con of-    PrefixCon args ->-      (header_ unicode qual +++ hsep (ppOcc-            : map (ppLParendType unicode qual) args), noHtml, noHtml)-    RecCon (L _ fields) ->-      (header_ unicode qual +++ ppOcc <+> char '{',-       doRecordFields fields,-       char '}')-    InfixCon arg1 arg2 ->-      (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,-            ppOccInfix, ppLParendType unicode qual arg2],-       noHtml, noHtml)--  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)--  where-    resTy = hsib_body (con_type con)--    doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))--    header_  = ppConstrHdr forall_ tyVars context-    occ        = map (nameOccName . getName . unLoc) $ getConNames con--    ppOcc      = case occ of-      [one] -> ppBinder summary one-      _     -> hsep (punctuate comma (map (ppBinder summary) occ))--    ppOccInfix = case occ of-      [one] -> ppBinderInfix summary one-      _     -> hsep (punctuate comma (map (ppBinderInfix summary) occ))--    ltvs     = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)-    tyVars   = tyvarNames ltvs-    lcontext = fromMaybe (noLoc []) (con_cxt con)-    context  = unLoc lcontext-    forall_  = False----- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode-            -> Qualification -> Html-ppConstrHdr forall_ tvs ctxt unicode qual- = (if null tvs then noHtml else ppForall)-   +++-   (if null ctxt then noHtml-    else ppContextNoArrow ctxt unicode qual-         <+> darrow unicode +++ toHtml " ")-  where-    ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)-                           <+> toHtml ". "-             | otherwise = noHtml--ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]-                   -> Unicode -> Qualification -> LConDecl DocName -> SubDecl-ppSideBySideConstr subdocs fixities unicode qual (L _ con)- = (decl, mbDoc, fieldPart)- where-    decl = case con of-      ConDeclH98{} -> case con_details con of-        PrefixCon args ->-          hsep ((header_ +++ ppOcc)-            : map (ppLParendType unicode qual) args)-          <+> fixity--        RecCon _ -> header_ +++ ppOcc <+> fixity--        InfixCon arg1 arg2 ->-          hsep [header_ +++ ppLParendType unicode qual arg1,-            ppOccInfix,-            ppLParendType unicode qual arg2]-          <+> fixity--      ConDeclGADT{} -> doGADTCon resTy--    resTy = hsib_body (con_type con)--    fieldPart = case getConDetails con of-        RecCon (L _ fields) -> [doRecordFields fields]-        _ -> []--    doRecordFields fields = subFields qual-      (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))--    doGADTCon :: Located (HsType DocName) -> Html-    doGADTCon ty = ppOcc <+> dcolon unicode-        -- ++AZ++ make this prepend "{..}" when it is a record style GADT-        <+> ppLType unicode qual ty-        <+> fixity--    fixity  = ppFixities fixities qual-    header_ = ppConstrHdr forall_ tyVars context unicode qual-    occ       = map (nameOccName . getName . unLoc) $ getConNames con--    ppOcc     = case occ of-      [one] -> ppBinder False one-      _     -> hsep (punctuate comma (map (ppBinder False) occ))--    ppOccInfix = case occ of-      [one] -> ppBinderInfix False one-      _     -> hsep (punctuate comma (map (ppBinderInfix False) occ))--    tyVars  = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con))-    context = unLoc (fromMaybe (noLoc []) (con_cxt con))-    forall_ = False-    -- don't use "con_doc con", in case it's reconstructed from a .hi file,-    -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>=-            combineDocumentation . fst---ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification-                  -> ConDeclField DocName -> SubDecl-ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =-  (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype,-    mbDoc,-    [])-  where-    -- don't use cd_fld_doc for same reason we don't use con_doc above-    -- Where there is more than one name, they all have the same documentation-    mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst---ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html-ppShortField summary unicode qual (ConDeclField names ltype _)-  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))-    <+> dcolon unicode <+> ppLType unicode qual ltype----- | Print the LHS of a data\/newtype declaration.--- Currently doesn't handle 'data instance' decls or kind signatures-ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html-ppDataHeader summary decl@(DataDecl { tcdDataDefn =-                                         HsDataDefn { dd_ND = nd-                                                    , dd_ctxt = ctxt-                                                    , dd_kindSig = ks } })-             unicode qual-  = -- newtype or data-    (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })-    <+>-    -- context-    ppLContext ctxt unicode qual <+>-    -- T a b c ..., or a :+: b-    ppDataBinderWithVars summary decl-    <+> case ks of-      Nothing -> mempty-      Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x--ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"------------------------------------------------------------------------------------- * Types and contexts------------------------------------------------------------------------------------ppBang :: HsSrcBang -> Html-ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"-ppBang (HsSrcBang _ _ SrcLazy)   = toHtml "~"-ppBang _                         = noHtml---tupleParens :: HsTupleSort -> [Html] -> Html-tupleParens HsUnboxedTuple = ubxParenList-tupleParens _              = parenList-------------------------------------------------------------------------------------- * Rendering of HsType------------------------------------------------------------------------------------pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int--pREC_TOP = 0 :: Int   -- type in ParseIface.y in GHC-pREC_CTX = 1 :: Int   -- Used for single contexts, eg. ctx => type-                      -- (as opposed to (ctx1, ctx2) => type)-pREC_FUN = 2 :: Int   -- btype in ParseIface.y in GHC-                      -- Used for LH arg of (->)-pREC_OP  = 3 :: Int   -- Used for arg of any infix operator-                      -- (we don't keep their fixities around)-pREC_CON = 4 :: Int   -- Used for arg of type applicn:-                      -- always parenthesise unless atomic--maybeParen :: Int           -- Precedence of context-           -> Int           -- Precedence of top-level operator-           -> Html -> Html  -- Wrap in parens if (ctxt >= op)-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p-                               | otherwise            = p---ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification-                                     -> Located (HsType DocName) -> Html-ppLType       unicode qual y = ppType unicode qual (unLoc y)-ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)-ppLFunLhType  unicode qual y = ppFunLhType unicode qual (unLoc y)---ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification-                                             -> HsType DocName -> Html-ppType       unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual-ppCtxType    unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual-ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual-ppFunLhType  unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual--ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html-ppHsTyVarBndr _       qual (UserTyVar (L _ name)) =-    ppDocName qual Raw False name-ppHsTyVarBndr unicode qual (KindedTyVar name kind) =-    parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>-            ppLKind unicode qual kind)--ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html-ppLKind unicode qual y = ppKind unicode qual (unLoc y)--ppKind :: Unicode -> Qualification -> HsKind DocName -> Html-ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual--ppForAllPart :: [LHsTyVarBndr DocName] -> Unicode -> Html-ppForAllPart tvs unicode = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot--ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html-ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)---ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html-ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual-  = maybeParen ctxt_prec pREC_FUN $-    ppForAllPart tvs unicode <+> ppr_mono_lty pREC_TOP ty unicode qual--ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual-  = maybeParen ctxt_prec pREC_FUN $-    ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual---- UnicodeSyntax alternatives-ppr_mono_ty _ (HsTyVar (L _ name)) True _-  | getOccString (getName name) == "*"    = toHtml "★"-  | getOccString (getName name) == "(->)" = toHtml "(→)"--ppr_mono_ty _         (HsBangTy b ty)     u q = ppBang b +++ ppLParendType u q ty-ppr_mono_ty _         (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q = ppr_fun_ty ctxt_prec ty1 ty2 u q-ppr_mono_ty _         (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)-ppr_mono_ty _         (HsKindSig ty kind) u q =-    parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)-ppr_mono_ty _         (HsListTy ty)       u q = brackets (ppr_mono_lty pREC_TOP ty u q)-ppr_mono_ty _         (HsPArrTy ty)       u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)-ppr_mono_ty ctxt_prec (HsIParamTy n ty)   u q =-    maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q-ppr_mono_ty _         (HsSpliceTy {})     _ _ = error "ppr_mono_ty HsSpliceTy"-ppr_mono_ty _         (HsRecTy {})        _ _ = toHtml "{..}"-       -- Can now legally occur in ConDeclGADT, the output here is to provide a-       -- placeholder in the signature, which is followed by the field-       -- declarations.-ppr_mono_ty _         (HsCoreTy {})       _ _ = error "ppr_mono_ty HsCoreTy"-ppr_mono_ty _         (HsExplicitListTy _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys-ppr_mono_ty _         (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys-ppr_mono_ty _         (HsAppsTy {})       _ _ = error "ppr_mono_ty HsAppsTy"--ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual-  = maybeParen ctxt_prec pREC_CTX $-    ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual--ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual-  = maybeParen ctxt_prec pREC_CON $-    hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]--ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual-  = maybeParen ctxt_prec pREC_FUN $-    ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual-  where-    -- `(:)` is valid in type signature only as constructor to promoted list-    -- and needs to be quoted in code so we explicitly quote it here too.-    ppr_op-        | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'-        | otherwise = ppr_op'-    ppr_op' = ppLDocName qual Infix op--ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual---  = parens (ppr_mono_lty pREC_TOP ty)-  = ppr_mono_lty ctxt_prec ty unicode qual--ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual-  = ppr_mono_lty ctxt_prec ty unicode qual--ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'-ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n--ppr_tylit :: HsTyLit -> Html-ppr_tylit (HsNumTy _ n) = toHtml (show n)-ppr_tylit (HsStrTy _ s) = toHtml (show s)---ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual-  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual-        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual-    in-    maybeParen ctxt_prec pREC_FUN $-    hsep [p1, arrow unicode <+> p2]+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Backends.Html.Decl+-- Copyright   :  (c) Simon Marlow   2003-2006,+--                    David Waern    2006-2009,+--                    Mark Lentczner 2010+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Decl (+  ppDecl,+  ppOrphanInstances,+) where++import Haddock.Backends.Xhtml.DocMarkup+import Haddock.Backends.Xhtml.Layout+import Haddock.Backends.Xhtml.Names+import Haddock.Backends.Xhtml.Types+import Haddock.Backends.Xhtml.Utils+import Haddock.GhcUtils+import Haddock.Types+import Haddock.Doc (combineDocumentation)++import           Data.Foldable         ( toList )+import           Data.List             ( intersperse, sort )+import           Data.List.NonEmpty    ( NonEmpty (..) )+import qualified Data.Map as Map+import           Data.Maybe+import           Text.XHtml hiding     ( name, title, p, quote )++import GHC.Core.Type ( Specificity(..) )+import GHC hiding (LexicalFixity(..), fromMaybeContext)+import GHC.Exts hiding (toList)+import GHC.Types.Name+import GHC.Data.BooleanFormula+import GHC.Types.Name.Reader ( rdrNameOcc )++-- | Pretty print a declaration+ppDecl :: Bool                                     -- ^ print summary info only+       -> LinksInfo                                -- ^ link information+       -> LHsDecl DocNameI                         -- ^ declaration to print+       -> [(HsDecl DocNameI, DocForDecl DocName)]  -- ^ relevant pattern synonyms+       -> DocForDecl DocName                       -- ^ documentation for this decl+       -> [DocInstance DocNameI]                   -- ^ relevant instances+       -> [(DocName, Fixity)]                      -- ^ relevant fixities+       -> [(DocName, DocForDecl DocName)]          -- ^ documentation for all decls+       -> Splice+       -> Unicode                                  -- ^ unicode output+       -> Maybe Package+       -> Qualification+       -> Html+ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of+  TyClD _ (FamDecl _ d)          -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual+  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual+  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual+  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual+  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames+                                         (dropWildCards lty) fixities splice unicode pkg qual+  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames+                                         lty fixities splice unicode pkg qual+  ForD _ d                       -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual+  InstD _ _                      -> noHtml+  DerivD _ _                     -> noHtml+  _                              -> error "declaration not supported by ppDecl"+++ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->+             [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->+             Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =+  ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities+           splice unicode pkg qual++ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->+            [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->+            Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual =+  ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)+            splice unicode pkg qual HideEmptyContexts+  where+    pp_typ = ppLSigType unicode qual HideEmptyContexts typ++-- | Pretty print a pattern synonym+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName+          -> [LocatedN DocName]     -- ^ names of patterns in declaration+          -> LHsSigType DocNameI   -- ^ type of patterns in declaration+          -> [(DocName, Fixity)]+          -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =+  ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities+            (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ)+  where+    pp_typ = ppPatSigType unicode qual typ+++ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->+             [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) ->+             Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)+          splice unicode pkg qual emptyCtxts =+  ppTypeOrFunSig summary links loc docnames typ doc+    ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode+    , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames+    , dcolon unicode+    )+    splice unicode pkg qual emptyCtxts+  where+    occnames = map (nameOccName . getName) docnames+    addFixities html+      | summary   = html+      | otherwise = html <+> ppFixities fixities qual+++ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI+               -> DocForDecl DocName -> (Html, Html, Html)+               -> Splice -> Unicode -> Maybe Package -> Qualification+               -> HideEmptyContexts -> Html+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep)+               splice unicode pkg qual emptyCtxts+  | summary = pref1+  | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curname pkg qual doc+  | otherwise = topDeclElem links loc splice docnames pref2+                  +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts)+                  +++ docSection curname pkg qual doc+  where+    curname = getName <$> listToMaybe docnames+++-- | This splits up a type signature along @->@ and adds docs (when they exist)+-- to the arguments.+--+-- If one passes in a list of the available subdocs, any top-level `HsRecTy`+-- found will be expanded out into their fields.+ppSubSigLike :: Unicode -> Qualification+             -> HsSigType DocNameI               -- ^ type signature+             -> FnArgsDoc DocName                -- ^ docs to add+             -> [(DocName, DocForDecl DocName)]  -- ^ all subdocs (useful when+                                                 -- we expand an `HsRecTy`)+             -> Html -> HideEmptyContexts -> [SubDecl]+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ+  where+    do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl]+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =+      case outer_bndrs of+        HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype+        HsOuterImplicit{}                  -> do_largs n leader          ltype+      where+        leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs)++    argDoc n = Map.lookup n argDocs++    do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl]+    do_largs n leader (L _ t) = do_args n leader t++    do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]+    do_args n leader (HsForAllTy _ tele ltype)+      = do_largs n leader' ltype+      where+        leader' = leader <+> ppForAllPart unicode qual tele++    do_args n leader (HsQualTy _ lctxt ltype)+      | null (unLoc lctxt)+      = do_largs n leader ltype+      | otherwise+      = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])+        : do_largs n (darrow unicode) ltype++    do_args n leader (HsFunTy _ _w (L _ (HsRecTy _ fields)) r)+      = [ (ldr <+> html, mdoc, subs)+        | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma)+        , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field+        ]+        ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r++    do_args n leader (HsFunTy _ _w lt r)+      = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])+        : do_largs (n+1) (arrow unicode) r++    do_args n leader t+      = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])]+++    -- FIXME: this should be done more elegantly+    --+    -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from+    -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode+    -- mode since `->` and `::` are rendered as single characters.+    gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml ","+    gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}"+    gadtOpen = toHtml "{"+++ppFixities :: [(DocName, Fixity)] -> Qualification -> Html+ppFixities [] _ = noHtml+ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge+  where+    ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<+                         (toHtml d <+> toHtml (show p) <+> ppNames ns)++    ppDir InfixR = "infixr"+    ppDir InfixL = "infixl"+    ppDir InfixN = "infix"++    ppNames = case fs of+      _:[] -> const noHtml -- Don't display names for fixities on single names+      _    -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)++    uniq_fs = [ (n, the p, the d') | (n, Fixity _ p d) <- fs+                                   , let d' = ppDir d+                                   , then group by Down (p,d') using groupWith ]++    rightEdge = thespan ! [theclass "rightedge"] << noHtml+++-- | Pretty-print type variables.+ppTyVars :: RenderableBndrFlag flag =>+  Unicode -> Qualification -> [LHsTyVarBndr flag DocNameI] -> [Html]+ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs+++ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName+      -> ForeignDecl DocNameI -> [(DocName, Fixity)]+      -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities+      splice unicode pkg qual+  = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual+ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"+++-- we skip type patterns for now+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan+        -> DocForDecl DocName -> TyClDecl DocNameI+        -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars+                                                , tcdRhs = ltype })+        splice unicode pkg qual+  = ppTypeOrFunSig summary links loc [name] sig_type doc+                   (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)+                   splice unicode pkg qual ShowEmptyToplevelContexts+  where+    sig_type = mkHsImplicitSigTypeI ltype+    hdr  = hsep ([keyword "type", ppBinder summary occ]+                 ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))+    full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type)+    occ  = nameOccName . getName $ name+    fixs+      | summary   = noHtml+      | otherwise = ppFixities fixities qual+ppTySyn _ _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"+++ppTypeSig :: Bool -> [OccName] -> Html -> Unicode -> Html+ppTypeSig summary nms pp_ty unicode =+  concatHtml htmlNames <+> dcolon unicode <+> pp_ty+  where+    htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms++ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan+            -> [DocName] -> HsSigType DocNameI+            -> Html+ppSimpleSig links splice unicode qual emptyCtxts loc names typ =+    topDeclElem' names $ ppTypeSig True occNames ppTyp unicode+  where+    topDeclElem' = topDeclElem links loc splice+    ppTyp = ppSigType unicode qual emptyCtxts typ+    occNames = map getOccName names+++--------------------------------------------------------------------------------+-- * Type families+--------------------------------------------------------------------------------+++-- | Print a data\/type family declaration+ppFamDecl :: Bool                     -- ^ is a summary+          -> Bool                     -- ^ is an associated type+          -> LinksInfo+          -> [DocInstance DocNameI]   -- ^ relevant instances+          -> [(DocName, Fixity)]      -- ^ relevant fixities+          -> SrcSpan+          -> Documentation DocName    -- ^ this decl's documentation+          -> FamilyDecl DocNameI      -- ^ this decl+          -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppFamDecl summary associated links instances fixities loc doc decl splice unicode pkg qual+  | summary   = ppFamHeader True associated decl unicode qual+  | otherwise = header_ +++ docSection curname pkg qual doc +++ instancesBit++  where+    docname = unLoc $ fdLName decl+    curname = Just $ getName docname++    header_ = topDeclElem links loc splice [docname] $+       ppFamHeader summary associated decl unicode qual <+> ppFixities fixities qual++    instancesBit+      | FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns } <- decl+      , not summary+      = subEquations pkg qual $ map (ppFamDeclEqn . unLoc) $ fromMaybe [] mb_eqns++      | otherwise+      = ppInstances links (OriginFamily docname) instances splice unicode pkg qual++    -- Individual equation of a closed type family+    ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n+                         , feqn_rhs = rhs+                         , feqn_pats = ts })+      = ( ppAppNameTypeArgs n ts unicode qual+          <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)+        , Nothing+        , []+        )+++-- | Print a pseudo family declaration+ppPseudoFamDecl :: LinksInfo -> Splice+                -> PseudoFamilyDecl DocNameI   -- ^ this decl+                -> Unicode -> Qualification -> Html+ppPseudoFamDecl links splice+                (PseudoFamilyDecl { pfdInfo = info+                                  , pfdKindSig = L _ kindSig+                                  , pfdTyVars = tvs+                                  , pfdLName = L loc name })+                unicode qual =+    topDeclElem links (locA loc) splice [name] leader+  where+    leader = hsep [ ppFamilyLeader True info+                  , ppAppNameTypes name (map unLoc tvs) unicode qual+                  , ppResultSig kindSig unicode qual+                  ]++-- | Print the LHS of a type\/data family declaration+ppFamHeader :: Bool                 -- ^ is a summary+            -> Bool                 -- ^ is an associated type+            -> FamilyDecl DocNameI  -- ^ family declaration+            -> Unicode -> Qualification -> Html+ppFamHeader summary associated (FamilyDecl { fdInfo = info+                                           , fdResultSig = L _ result+                                           , fdInjectivityAnn = injectivity+                                           , fdLName = L _ name+                                           , fdTyVars = tvs })+              unicode qual =+  hsep [ ppFamilyLeader associated info+       , ppAppDocNameTyVarBndrs summary unicode qual name (hsq_explicit tvs)+       , ppResultSig result unicode qual+       , injAnn+       , whereBit+       ]+  where+    whereBit = case info of+      ClosedTypeFamily _ -> keyword "where ..."+      _                  -> noHtml++    injAnn = case injectivity of+      Nothing -> noHtml+      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|"+                                                    : ppLDocName qual Raw lhs+                                                    : arrow unicode+                                                    : map (ppLDocName qual Raw) rhs)+      Just _ -> error "ppFamHeader:XInjectivityAnn"++-- | Print the keywords that begin the family declaration+ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html+ppFamilyLeader assoc info = keyword (typ ++ if assoc then "" else " family")+  where+    typ = case info of+       OpenTypeFamily     -> "type"+       ClosedTypeFamily _ -> "type"+       DataFamily         -> "data"++-- | Print the signature attached to a family+ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html+ppResultSig result unicode qual = case result of+    NoSig _               -> noHtml+    KindSig _ kind        -> dcolon unicode  <+> ppLKind unicode qual kind+    TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr+++--------------------------------------------------------------------------------+-- * Associated Types+--------------------------------------------------------------------------------+++ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI+            -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package+            -> Qualification -> Html+ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual =+   ppFamDecl summ True links [] fixities loc (fst doc) decl splice unicode pkg qual+++--------------------------------------------------------------------------------+-- * Type applications+--------------------------------------------------------------------------------++ppAppDocNameTyVarBndrs :: RenderableBndrFlag flag =>+  Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr flag DocNameI] -> Html+ppAppDocNameTyVarBndrs summ unicode qual n vs =+    ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc)+  where+    ppDN notation = ppBinderFixity notation summ . nameOccName . getName+    ppBinderFixity Infix = ppBinderInfix+    ppBinderFixity _ = ppBinder++-- | Print an application of a 'DocName' to its list of 'HsType's+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html+ppAppNameTypes n ts unicode qual =+    ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)++ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html+ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q+  = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts)+ppAppNameTypeArgs n args u q+  = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args)++-- | General printing of type applications+ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html+ppTypeApp n (t1:t2:rest) ppDN ppT+  | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)+  | operator                    = opApp+  where+    operator = isNameSym . getName $ n+    opApp = ppT t1 <+> ppDN Infix n <+> ppT t2++ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)++-------------------------------------------------------------------------------+-- * Contexts+-------------------------------------------------------------------------------+++ppLContext :: Maybe (LHsContext DocNameI) -> Unicode+                              -> Qualification -> HideEmptyContexts -> Html+ppLContext        Nothing  u q h = ppContext        []        u q h+ppLContext        (Just c) u q h = ppContext        (unLoc c) u q h++ppLContextNoArrow :: LHsContext DocNameI -> Unicode+                              -> Qualification -> HideEmptyContexts -> Html+ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h++ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $+                                               ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts+++ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $+                                              ppContextNoLocsMaybe cxt unicode qual emptyCtxts+++ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html+ppContextNoLocsMaybe [] _ _ emptyCtxts =+  case emptyCtxts of+    HideEmptyContexts -> Nothing+    ShowEmptyToplevelContexts -> Just (toHtml "()")+ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual++ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts+++ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html+ppHsContext []  _       _    = noHtml+ppHsContext [p] unicode qual = ppCtxType unicode qual p+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)+++-------------------------------------------------------------------------------+-- * Class declarations+-------------------------------------------------------------------------------+++ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName+           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]+           -> Unicode -> Qualification -> Html+ppClassHdr summ lctxt n tvs fds unicode qual =+  keyword "class"+  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)+  <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)+  <+> ppFds fds unicode qual+++ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html+ppFds fds unicode qual =+  if null fds then noHtml else+        char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))+  where+        fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2+        fundep (XFunDep _) = error "ppFds"+        ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)++ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan+                 -> [(DocName, DocForDecl DocName)]+                 -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs+                                          , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc+    subdocs splice unicode pkg qual =+  if not (any isUserLSig sigs) && null ats+    then (if summary then id else topDeclElem links loc splice [nm]) hdr+    else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")+      +++ shortSubDecls False+          (+            [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats+              , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]  ++++                -- ToDo: add associated type defaults++            [ ppFunSig summary links loc noHtml doc names typ+                       [] splice unicode pkg qual+              | L _ (ClassOpSig _ False lnames typ) <- sigs+              , let doc = lookupAnySubdoc (head names) subdocs+                    names = map unLoc lnames ]+              -- FIXME: is taking just the first name ok? Is it possible that+              -- there are different subdocs for different names in a single+              -- type signature?+          )+  where+    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual+    nm  = unLoc lname+ppShortClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"++++ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)]+            -> SrcSpan -> Documentation DocName+            -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI+            -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppClassDecl summary links instances fixities loc d subdocs+        decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars+                        , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = atsDefs })+            splice unicode pkg qual+  | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual+  | otherwise = classheader +++ docSection curname pkg qual d+                  +++ minimalBit +++ atBit +++ methodBit +++ instancesBit+  where+    curname = Just $ getName nm++    sigs = map unLoc lsigs++    classheader+      | any isUserLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)+      | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)++    -- Only the fixity relevant to the class header+    fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual++    nm   = tcdNameI decl++    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds++    -- Associated types+    atBit = subAssociatedTypes+      [ ppAssocType summary links doc at subfixs splice unicode pkg qual+          <+>+        subDefaults (maybeToList defTys)+      | at <- ats+      , let name = unLoc . fdLName $ unLoc at+            doc = lookupAnySubdoc name subdocs+            subfixs = filter ((== name) . fst) fixities+            defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name+      ]++    -- Default associated types+    ppDefaultAssocTy n (vs,rhs) = hsep+      [ keyword "type", ppAppNameTypeArgs n vs unicode qual, equals+      , ppType unicode qual HideEmptyContexts (unLoc rhs)+      ]++    lookupDAT name = Map.lookup (getName name) defaultAssocTys+    defaultAssocTys = Map.fromList+      [ (getName name, (vs, typ))+      | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ+                                     , feqn_tycon = L _ name+                                     , feqn_pats = vs })) <- atsDefs+      ]++    -- Methods+    methodBit = subMethods+      [ ppFunSig summary links loc noHtml doc [name] typ+                 subfixs splice unicode pkg qual+          <+>+        subDefaults (maybeToList defSigs)+      | ClassOpSig _ False lnames typ <- sigs+      , name <- map unLoc lnames+      , let doc = lookupAnySubdoc name subdocs+            subfixs = filter ((== name)  . fst) fixities+            defSigs = ppDefaultFunSig name <$> lookupDM name+      ]+      -- N.B. taking just the first name is ok. Signatures with multiple names+      -- are expanded so that each name gets its own signature.++    -- Default methods+    ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")+      d' [n] t [] splice unicode pkg qual++    lookupDM name = Map.lookup (getOccString name) defaultMethods+    defaultMethods = Map.fromList+      [ (nameStr, (typ, doc))+      | ClassOpSig _ True lnames typ <- sigs+      , name <- map unLoc lnames+      , let doc = noDocForDecl -- TODO: get docs for method defaults+            nameStr = getOccString name+      ]++    -- Minimal complete definition+    minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of+      -- Miminal complete definition = every shown method+      And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==+                   sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns]+        -> noHtml++      -- Minimal complete definition = the only shown method+      Var (L _ n) : _ | [getName n] ==+                        [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns]+        -> noHtml++      -- Minimal complete definition = nothing+      And [] : _ -> subMinimal $ toHtml "Nothing"++      m : _  -> subMinimal $ ppMinimal False m+      _ -> noHtml++    ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n+    ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True . unLoc) fs+    ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False . unLoc) fs+      where wrap | p = parens | otherwise = id+    ppMinimal p (Parens x) = ppMinimal p (unLoc x)++    -- Instances+    instancesBit = ppInstances links (OriginClass nm) instances+        splice unicode pkg qual++ppClassDecl _ _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+++ppInstances :: LinksInfo+            -> InstOrigin DocName -> [DocInstance DocNameI]+            -> Splice -> Unicode -> Maybe Package -> Qualification+            -> Html+ppInstances links origin instances splice unicode pkg qual+  = subInstances pkg qual instName links True (zipWith instDecl [1..] instances)+  -- force Splice = True to use line URLs+  where+    instName = getOccString origin+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)+    instDecl no (inst, mdoc, loc, mdl) =+        ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc)+++ppOrphanInstances :: LinksInfo+                  -> [DocInstance DocNameI]+                  -> Splice -> Unicode -> Maybe Package -> Qualification+                  -> Html+ppOrphanInstances links instances splice unicode pkg qual+  = subOrphanInstances pkg qual links True (zipWith instDecl [1..] instances)+  where+    instOrigin :: InstHead name -> InstOrigin (IdP name)+    instOrigin inst = OriginClass (ihdClsName inst)++    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)+    instDecl no (inst, mdoc, loc, mdl) =+        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)+++ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification+           -> Maybe (MDoc DocName)+           -> InstOrigin DocName+           -> Bool -- ^ Is instance orphan+           -> Int  -- ^ Normal+           -> InstHead DocNameI+           -> Maybe Module+           -> SubDecl+ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) mdl =+    case ihdInstType of+        ClassInst { .. } ->+            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ+            , mdoc+            , [subInstDetails iid ats sigs mname]+            )+          where+            sigs = ppInstanceSigs links splice unicode qual clsiSigs+            ats = ppInstanceAssocTys links splice unicode qual clsiAssocTys+        TypeInst rhs ->+            ( subInstHead iid ptype+            , mdoc+            , [subFamInstDetails iid prhs mname]+            )+          where+            ptype = keyword "type" <+> typ+            prhs = ptype <+> maybe noHtml+                                   (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs+        DataInst dd ->+            ( subInstHead iid pdata+            , mdoc+            , [subFamInstDetails iid pdecl mname])+          where+            cons = dd_cons (tcdDataDefn dd)+            pref = case cons of { NewTypeCon _ -> keyword "newtype"; DataTypeCons _ _ -> keyword "data" }+            pdata = pref <+> typ+            pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual+  where+    mname = maybe noHtml (\m -> toHtml "Defined in" <+> ppModule m) mdl+    iid = instanceId origin no orphan ihd+    typ = ppAppNameTypes ihdClsName ihdTypes unicode qual+++ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification+                   -> [PseudoFamilyDecl DocNameI]+                   -> [Html]+ppInstanceAssocTys links splice unicode qual =+    map (\pseudo -> ppPseudoFamDecl links splice pseudo unicode qual)+++ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification+              -> [Sig DocNameI]+              -> [Html]+ppInstanceSigs links splice unicode qual sigs = do+    TypeSig _ lnames typ <- sigs+    let names = map unLoc lnames+        L _ rtyp = dropWildCards typ+    -- Instance methods signatures are synified and thus don't have a useful+    -- SrcSpan value. Use the methods name location instead.+    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp+++lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n+++instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String+instanceId origin no orphan ihd = concat $+    [ "o:" | orphan ] +++    [ qual origin+    , ":" ++ getOccString origin+    , ":" ++ getOccString (ihdClsName ihd)+    , ":" ++ show no+    ]+  where+    qual (OriginClass _) = "ic"+    qual (OriginData _) = "id"+    qual (OriginFamily _) = "if"+++-------------------------------------------------------------------------------+-- * Data & newtype declarations+-------------------------------------------------------------------------------+++-- TODO: print contexts+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI+                -> [(HsDecl DocNameI, DocForDecl DocName)]+                -> Unicode -> Qualification -> Html+ppShortDataDecl summary dataInst dataDecl pats unicode qual++  | [] <- toList cons+  , [] <- pats = dataHeader++  | [lcon] <- toList cons, [] <- pats, isH98,+    (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual+       = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot++  | [] <- pats, isH98 = dataHeader+      +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') (toList cons) ++ pats1)++  | otherwise = (dataHeader <+> keyword "where")+      +++ shortSubDecls dataInst (map doGADTConstr (toList cons) ++ pats1)++  where+    dataHeader+      | dataInst  = noHtml+      | otherwise = ppDataHeader summary dataDecl unicode qual+    doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual+    doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual++    cons      = dd_cons (tcdDataDefn dataDecl)+    isH98     = flip any (unLoc <$> cons) $ \ case+                  ConDeclH98 {} -> True+                  ConDeclGADT{} -> False++    pats1 = [ hsep [ keyword "pattern"+                   , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames+                   , dcolon unicode+                   , ppPatSigType unicode qual typ+                   ]+            | (SigD _ (PatSynSig _ lnames typ),_) <- pats+            ]+++-- | Pretty-print a data declaration+ppDataDecl :: Bool -> LinksInfo+           -> [DocInstance DocNameI]                  -- ^ relevant instances+           -> [(DocName, Fixity)]                     -- ^ relevant fixities+           -> [(DocName, DocForDecl DocName)]         -- ^ all decl documentation+           -> SrcSpan+           -> Documentation DocName                   -- ^ this decl's documentation+           -> TyClDecl DocNameI                       -- ^ this decl+           -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns+           -> Splice -> Unicode -> Maybe Package -> Qualification -> Html+ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats+           splice unicode pkg qual++  | summary   = ppShortDataDecl summary False dataDecl pats unicode qual+  | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit++  where+    docname   = tcdNameI dataDecl+    curname   = Just $ getName docname+    cons      = dd_cons (tcdDataDefn dataDecl)+    isH98     = flip any (unLoc <$> cons) $ \ case+                  ConDeclH98 {} -> True+                  ConDeclGADT{} -> False++    header_ = topDeclElem links loc splice [docname] $+             ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix++    fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual++    whereBit+      | null cons+      , null pats = noHtml+      | isH98 = noHtml+      | otherwise = keyword "where"++    constrBit = subConstructors pkg qual+      [ ppSideBySideConstr subdocs subfixs unicode pkg qual c+      | c <- toList cons+      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)+                                            (unL <$> getConNamesI (unLoc c))) fixities+      ]++    patternBit = subPatterns pkg qual+      [ ppSideBySidePat subfixs unicode qual lnames typ d+      | (SigD _ (PatSynSig _ lnames typ), d) <- pats+      , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)+                                            (map unLoc lnames)) fixities+      ]++    instancesBit = ppInstances links (OriginData docname) instances+        splice unicode pkg qual+++ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot+  where+    (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual+++-- returns three pieces: header, body, footer so that header & footer can be+-- incorporated into the declaration+ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html)+ppShortConstrParts summary dataInst con unicode qual+  = case con of+      ConDeclH98{ con_args = det+                , con_ex_tvs = tyVars+                , con_forall = forall_+                , con_mb_cxt = cxt+                } -> let context = fromMaybeContext cxt+                         header_ = ppConstrHdr forall_ tyVars context unicode qual+                     in case det of++        -- Prefix constructor, e.g. 'Just a'+        PrefixCon _ args ->+          ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)+          , noHtml+          , noHtml+          )++        -- Record constructor, e.g. 'Identity { runIdentity :: a }'+        RecCon (L _ fields) ->+          ( header_ +++ ppOcc <+> char '{'+          , shortSubDecls dataInst [ ppShortField summary unicode qual field+                                   | L _ field <- fields+                                   ]+          , char '}'+          )++        -- Infix constructor, e.g. 'a :| [a]'+        InfixCon arg1 arg2 ->+          ( header_ <+> hsep [ ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)+                             , ppOccInfix+                             , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)+                             ]+          , noHtml+          , noHtml+          )++      -- GADT constructor, e.g. 'Foo :: Int -> Foo'+      ConDeclGADT {} ->+          ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ]+          , noHtml+          , noHtml+          )++  where+    occ        = toList $ nameOccName . getName . unL <$> getConNamesI con+    ppOcc      = hsep (punctuate comma (map (ppBinder summary) occ))+    ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ))+++-- | Pretty print an expanded constructor+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]+                   -> Unicode -> Maybe Package -> Qualification+                   -> LConDecl DocNameI -- ^ constructor declaration to print+                   -> SubDecl+ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)+ = ( decl       -- Constructor header (name, fixity)+   , mbDoc      -- Docs on the whole constructor+   , fieldPart  -- Information on the fields (or arguments, if they have docs)+   )+ where+    -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)+    L _ aConName :| _ = getConNamesI con++    fixity   = ppFixities fixities qual+    occ      = toList $ nameOccName . getName . unL <$> getConNamesI con++    ppOcc      = hsep (punctuate comma (map (ppBinder False) occ))+    ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))++    -- Extract out the map of of docs corresponding to the constructors arguments+    argDocs = maybe Map.empty snd (lookup aConName subdocs)+    hasArgDocs = not $ Map.null argDocs++    decl = case con of+      ConDeclH98{ con_args = det+                , con_ex_tvs = tyVars+                , con_forall = forall_+                , con_mb_cxt = cxt+                } -> let context = fromMaybeContext cxt+                         header_ = ppConstrHdr forall_ tyVars context unicode qual+                     in case det of+        -- Prefix constructor, e.g. 'Just a'+        PrefixCon _ args+          | hasArgDocs -> header_ <+> ppOcc <+> fixity+          | otherwise -> hsep [ header_ <+> ppOcc+                              , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)+                              , fixity+                              ]++        -- Record constructor, e.g. 'Identity { runIdentity :: a }'+        RecCon _ -> header_ <+> ppOcc <+> fixity++        -- Infix constructor, e.g. 'a :| [a]'+        InfixCon arg1 arg2+          | hasArgDocs -> header_ <+> ppOcc <+> fixity+          | otherwise -> hsep [ header_ <+> ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg1)+                              , ppOccInfix+                              , ppLParendType unicode qual HideEmptyContexts (hsScaledThing arg2)+                              , fixity+                              ]++      -- GADT constructor, e.g. 'Foo :: Int -> Foo'+      ConDeclGADT{}+          | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity+          | otherwise -> hsep [ ppOcc+                              , dcolon unicode+                              -- ++AZ++ make this prepend "{..}" when it is a record style GADT+                              , ppLSigType unicode qual HideEmptyContexts (getGADTConType con)+                              , fixity+                              ]++    fieldPart = case con of+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of+          -- GADT record declarations+          RecConGADT _ _                  -> [ doConstrArgsWithDocs [] ]+          -- GADT prefix data constructors+          PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]+          _                               -> []++        ConDeclH98{con_args = con_args'} -> case con_args' of+          -- H98 record declarations+          RecCon (L _ fields)             -> [ doRecordFields fields ]+          -- H98 prefix data constructors+          PrefixCon _ args | hasArgDocs   -> [ doConstrArgsWithDocs args ]+          -- H98 infix data constructor+          InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]+          _                               -> []++    doRecordFields fields = subFields pkg qual+      (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))++    doConstrArgsWithDocs args = subFields pkg qual $ case con of+      ConDeclH98{} ->+        [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, [])+        | (i, arg) <- zip [0..] (map hsScaledThing args)+        , let mdoc = Map.lookup i argDocs+        ]+      ConDeclGADT{} ->+        ppSubSigLike unicode qual (unLoc (getGADTConType con))+                     argDocs subdocs (dcolon unicode) HideEmptyContexts++    -- don't use "con_doc con", in case it's reconstructed from a .hi file,+    -- or also because we want Haddock to do the doc-parsing, not GHC.+    mbDoc = lookup aConName subdocs >>=+            combineDocumentation . fst+++-- ppConstrHdr is for (non-GADT) existentials constructors' syntax+ppConstrHdr+  :: Bool                    -- ^ print explicit foralls+  -> [LHsTyVarBndr Specificity DocNameI] -- ^ type variables+  -> HsContext DocNameI      -- ^ context+  -> Unicode -> Qualification+  -> Html+ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt+  where+    ppForall+      | null tvs || not forall_ = noHtml+      | otherwise = ppForAllPart unicode qual (HsForAllInvis noExtField tvs)++    ppCtxt+      | null ctxt = noHtml+      | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts+                      <+> darrow unicode +++ toHtml " "+++-- | Pretty-print a record field+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification+                  -> ConDeclField DocNameI -> SubDecl+ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) =+  ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field)+                          | L _ name <- names+                          , let field = (unLoc . foLabel) name+                          ])+      <+> dcolon unicode+      <+> ppLType unicode qual HideEmptyContexts ltype+  , mbDoc+  , []+  )+  where+    -- don't use cd_fld_doc for same reason we don't use con_doc above+    -- Where there is more than one name, they all have the same documentation+    mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst+++ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html+ppShortField summary unicode qual (ConDeclField _ names ltype _)+  = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names))+    <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype+++-- | Pretty print an expanded pattern (for bundled patterns)+ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification+                   -> [LocatedN DocName]   -- ^ pattern name(s)+                   -> LHsSigType DocNameI  -- ^ type of pattern(s)+                   -> DocForDecl DocName   -- ^ doc map+                   -> SubDecl+ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) =+  ( decl+  , combineDocumentation doc+  , fieldPart+  )+  where+    hasArgDocs = not $ Map.null argDocs+    fixity = ppFixities fixities qual+    ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames))++    decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity+         | otherwise = hsep [ keyword "pattern"+                            , ppOcc+                            , dcolon unicode+                            , ppPatSigType unicode qual typ+                            , fixity+                            ]++    fieldPart+      | not hasArgDocs = []+      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ)+                                                        argDocs [] (dcolon unicode)+                                                        emptyCtxt) ]++    emptyCtxt = patSigContext typ+++-- | Print the LHS of a data\/newtype declaration.+-- Currently doesn't handle 'data instance' decls or kind signatures+ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html+ppDataHeader summary (DataDecl { tcdDataDefn =+                                    HsDataDefn { dd_cons = cons+                                               , dd_ctxt = ctxt+                                               , dd_kindSig = ks }+                               , tcdLName = L _ name+                               , tcdTyVars = tvs })+             unicode qual+  = -- newtype or data+    (case cons of+       { NewTypeCon _ -> keyword "newtype"+       ; DataTypeCons False _ -> keyword "data"+       ; DataTypeCons True _ -> keyword "type" <+> keyword "data"+       })+    <+>+    -- context+    ppLContext ctxt unicode qual HideEmptyContexts <+>+    -- T a b c ..., or a :+: b+    ppAppDocNameTyVarBndrs summary unicode qual name (hsQTvExplicit tvs)+    <+> case ks of+      Nothing -> mempty+      Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x++ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"++--------------------------------------------------------------------------------+-- * Types and contexts+--------------------------------------------------------------------------------+++ppBang :: HsSrcBang -> Html+ppBang (HsSrcBang _ _ SrcStrict) = toHtml "!"+ppBang (HsSrcBang _ _ SrcLazy)   = toHtml "~"+ppBang _                         = noHtml+++tupleParens :: HsTupleSort -> [Html] -> Html+tupleParens HsUnboxedTuple = ubxParenList+tupleParens _              = parenList+++sumParens :: [Html] -> Html+sumParens = ubxSumList++--------------------------------------------------------------------------------+-- * Rendering of HsType+--------------------------------------------------------------------------------++ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html+ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)+ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)+ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)++ppLSigType ::  Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html+ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y)++ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html+ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts++ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html+ppType       unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts+ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts+ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts++ppSigType ::  Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html+ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts++ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html+ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty+ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>+                                                       ppLParendType unicode qual emptyCtxts ki+ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""++class RenderableBndrFlag flag where+  ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr flag DocNameI -> Html++instance RenderableBndrFlag () where+  ppHsTyVarBndr _       qual (UserTyVar _ _ (L _ name)) =+      ppDocName qual Raw False name+  ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) =+      parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>+              ppLKind unicode qual kind)++instance RenderableBndrFlag Specificity where+  ppHsTyVarBndr _       qual (UserTyVar _ SpecifiedSpec (L _ name)) =+      ppDocName qual Raw False name+  ppHsTyVarBndr _       qual (UserTyVar _ InferredSpec (L _ name)) =+      braces $ ppDocName qual Raw False name+  ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =+      parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>+              ppLKind unicode qual kind)+  ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =+      braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>+              ppLKind unicode qual kind)++ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html+ppLKind unicode qual y = ppKind unicode qual (unLoc y)++ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html+ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts++patSigContext :: LHsSigType DocNameI -> HideEmptyContexts+patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts+                      | otherwise = HideEmptyContexts+  where+    typ = sig_body (unLoc sig_typ)++    hasNonEmptyContext t =+      case unLoc t of+        HsForAllTy _ _ s -> hasNonEmptyContext s+        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True+        HsFunTy _ _ _ s    -> hasNonEmptyContext s+        _ -> False+    isFirstContextEmpty t =+      case unLoc t of+        HsForAllTy _ _ s -> isFirstContextEmpty s+        HsQualTy _ cxt _ -> null (unLoc cxt)+        HsFunTy _ _ _ s    -> isFirstContextEmpty s+        _ -> False+++-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in+-- the right 'HideEmptyContext' value)+ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html+ppPatSigType unicode qual typ =+  let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ++ppHsOuterTyVarBndrs :: RenderableBndrFlag flag+                    => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html+ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of+  HsOuterImplicit{} -> noHtml+  HsOuterExplicit{hso_bndrs = bndrs} ->+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot++ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html+ppForAllPart unicode qual tele = case tele of+  HsForAllVis { hsf_vis_bndrs = bndrs } ->+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) ++++    spaceHtml +++  arrow unicode+  HsForAllInvis { hsf_invis_bndrs = bndrs } ->+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot++ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts+  = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts++ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_mono_lty ty = ppr_mono_ty (unLoc ty)+++ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_mono_ty (HsForAllTy _ tele ty) unicode qual emptyCtxts+  = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts++ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts+  = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts++-- UnicodeSyntax alternatives+ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _+  | getOccString (getName name) == "(->)" = toHtml "(→)"++ppr_mono_ty (HsBangTy _ b ty) u q _ =+  ppBang b +++ ppLParendType u q HideEmptyContexts ty+ppr_mono_ty (HsTyVar _ prom (L _ name)) _ q _+  | isPromoted prom = promoQuote (ppDocName q Prefix True name)+  | otherwise = ppDocName q Prefix True name+ppr_mono_ty (HsStarTy _ isUni) u _ _ =+  toHtml (if u || isUni then "★" else "*")+ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =+  hsep [ ppr_mono_lty ty1 u q HideEmptyContexts+       , arr <+> ppr_mono_lty ty2 u q e+       ]+   where arr = case mult of+                 HsLinearArrow _ -> lollipop u+                 HsUnrestrictedArrow _ -> arrow u+                 HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u++ppr_mono_ty (HsTupleTy _ con tys) u q _ =+  tupleParens con (map (ppLType u q HideEmptyContexts) tys)+ppr_mono_ty (HsSumTy _ tys) u q _ =+  sumParens (map (ppLType u q HideEmptyContexts) tys)+ppr_mono_ty (HsKindSig _ ty kind) u q e =+  ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind+ppr_mono_ty (HsListTy _ ty)       u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts)+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =+  ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts+ppr_mono_ty (HsSpliceTy v _) _ _ _ = dataConCantHappen v+ppr_mono_ty (HsRecTy {})        _ _ _ = toHtml "{..}"+       -- Can now legally occur in ConDeclGADT, the output here is to provide a+       -- placeholder in the signature, which is followed by the field+       -- declarations.+ppr_mono_ty (XHsType {})        _ _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys+ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys++ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _+  = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts+         , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ]++ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _+  = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts+         , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts]++ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _+  = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts+  where+    ppr_op_prom+        | isPromoted prom+        = promoQuote ppr_op+        | otherwise+        = ppr_op+    ppr_op = ppLDocName qual Infix op++ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts+  = parens (ppr_mono_lty ty unicode qual emptyCtxts)+--  = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts)++ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts+  = ppr_mono_lty ty unicode qual emptyCtxts++ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_'+ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n++ppr_tylit :: HsTyLit DocNameI -> Html+ppr_tylit (HsNumTy _ n) = toHtml (show n)+ppr_tylit (HsStrTy _ s) = toHtml (show s)+ppr_tylit (HsCharTy _ c) = toHtml (show c)
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -19,7 +19,8 @@   docElement, docSection, docSection_, ) where -import Data.List+import Data.List (intersperse)+import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types@@ -30,8 +31,8 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC-import Name+import GHC hiding (anchor)+import GHC.Types.Name   parHtmlMarkup :: Qualification -> Bool@@ -43,36 +44,38 @@   markupAppend               = (+++),   markupIdentifier           = thecode . ppId insertAnchors,   markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,-  markupModule               = \m -> let (mdl,ref) = break (=='#') m-                                         -- Accomodate for old style-                                         -- foo\#bar anchors-                                         mdl' = case reverse mdl of-                                           '\\':_ -> init mdl-                                           _ -> mdl-                                     in ppModuleRef (mkModuleName mdl') ref,+  markupModule               = \(ModLink m lbl) ->+                                 let (mdl,ref) = break (=='#') m+                                       -- Accommodate for old style+                                       -- foo\#bar anchors+                                     mdl' = case reverse mdl of+                                              '\\':_ -> init mdl+                                              _ -> mdl+                                 in ppModuleRef lbl (mkModuleName mdl') ref,   markupWarning              = thediv ! [theclass "warning"],   markupEmphasis             = emphasize,   markupBold                 = strong,   markupMonospaced           = thecode,   markupUnorderedList        = unordList,-  markupOrderedList          = ordList,+  markupOrderedList          = makeOrdList,   markupDefList              = defList,   markupCodeBlock            = pre,   markupHyperlink            = \(Hyperlink url mLabel)                                -> if insertAnchors                                   then anchor ! [href url]-                                       << fromMaybe url mLabel-                                  else toHtml $ fromMaybe url mLabel,+                                       << fromMaybe (toHtml url) mLabel+                                  else fromMaybe (toHtml url) mLabel,   markupAName                = \aname                                -> if insertAnchors                                   then namedAnchor aname << ""                                   else noHtml,   markupPic                  = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),-  markupMathInline           = \mathjax -> toHtml ("\\(" ++ mathjax ++ "\\)"),-  markupMathDisplay          = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"),+  markupMathInline           = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\(" ++ mathjax ++ "\\)"),+  markupMathDisplay          = \mathjax -> thespan ! [theclass "mathjax"] << toHtml ("\\[" ++ mathjax ++ "\\]"),   markupProperty             = pre . toHtml,   markupExample              = examplesToHtml,-  markupHeader               = \(Header l t) -> makeHeader l t+  markupHeader               = \(Header l t) -> makeHeader l t,+  markupTable                = \(Table h r) -> makeTable h r   }   where     makeHeader :: Int -> Html -> Html@@ -84,7 +87,23 @@     makeHeader 6 mkup = h6 mkup     makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" +    makeTable :: [TableRow Html] -> [TableRow Html] -> Html+    makeTable hs bs = table (concatHtml (hs' ++ bs'))+      where+        hs' | null hs   = []+            | otherwise = [thead (concatHtml (map (makeTableRow th) hs))] +        bs' = [tbody (concatHtml (map (makeTableRow td) bs))]++    makeTableRow :: (Html -> Html) -> TableRow Html -> Html+    makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs))++    makeTableCell :: (Html -> Html) -> TableCell Html -> Html+    makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j')+      where+        i' = if i == 1 then [] else [ colspan i ]+        j' = if j == 1 then [] else [ rowspan j ]+     examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]      exampleToHtml (Example expression result) = htmlExample@@ -93,9 +112,12 @@         htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]         htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] +    makeOrdList :: HTML a => [(Int, a)] -> Html+    makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items+ -- | We use this intermediate type to transform the input 'Doc' tree -- in an arbitrary way before rendering, such as grouping some--- elements. This is effectivelly a hack to prevent the 'Doc' type+-- elements. This is effectively a hack to prevent the 'Doc' type -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id =@@ -153,20 +175,20 @@ -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content.-hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html-hackMarkup fmt' h' =+hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html+hackMarkup fmt' currPkg h' =   let (html, ms) = hackMarkup' fmt' h'-  in html +++ renderMeta fmt' (metaConcat ms)+  in html +++ renderMeta fmt' currPkg (metaConcat ms)   where-    hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id+    hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id                 -> (Html, [Meta])     hackMarkup' fmt h = case h of       UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])       CollapsingHeader (Header lvl titl) par n nm ->         let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n-            expanded = False-            col' = collapseControl id_ expanded "caption"-            instTable = (thediv ! collapseSection id_ expanded [] <<)+            col' = collapseControl id_ "subheading"+            summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand"+            instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents)             lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]             getHeader = fromMaybe caption (lookup lvl lvs)             subCaption = getHeader ! col' << markup fmt titl@@ -175,46 +197,51 @@                              (y, m') = hackMarkup' fmt d'                          in (markupAppend fmt x y, m ++ m') -renderMeta :: DocMarkup id Html -> Meta -> Html-renderMeta fmt (Meta { _version = Just x }) =+renderMeta :: DocMarkup id Html -> Maybe Package -> Meta -> Html+renderMeta fmt currPkg (Meta { _version = Just x, _package = pkg }) =   markupParagraph fmt . markupEmphasis fmt . toHtml $-    "Since: " ++ formatVersion x+    "Since: " ++ formatPkgMaybe pkg ++ formatVersion x   where     formatVersion v = concat . intersperse "." $ map show v-renderMeta _ _ = noHtml+    formatPkgMaybe (Just p) | Just p /= currPkg = p ++ "-"+    formatPkgMaybe _ = ""+renderMeta _ _ _ = noHtml  -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first.-markupHacked :: DocMarkup id Html+markupHacked :: DocMarkup (Wrap id) Html+             -> Maybe Package      -- this package              -> Maybe String              -> MDoc id              -> Html-markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten+markupHacked fmt currPkg n = hackMarkup fmt currPkg . toHack 0 n . flatten  -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers).  FIXME: Does this still apply?-docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See-                          -- comments on 'toHack' for details.+docToHtml :: Maybe String  -- ^ Name of the thing this doc is for. See+                           -- comments on 'toHack' for details.+          -> Maybe Package -- ^ Current package           -> Qualification -> MDoc DocName -> Html-docToHtml n qual = markupHacked fmt n . cleanup-  where fmt = parHtmlMarkup qual True (ppDocName qual Raw)+docToHtml n pkg qual = markupHacked fmt pkg n . cleanup+  where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw)  -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements.-docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'+docToHtmlNoAnchors :: Maybe String  -- ^ See 'toHack'+                   -> Maybe Package -- ^ Current package                    -> Qualification -> MDoc DocName -> Html-docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup-  where fmt = parHtmlMarkup qual False (ppDocName qual Raw)+docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup+  where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) -origDocToHtml :: Qualification -> MDoc Name -> Html-origDocToHtml qual = markupHacked fmt Nothing . cleanup-  where fmt = parHtmlMarkup qual True (const $ ppName Raw)+origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html+origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup+  where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw))  -rdrDocToHtml :: Qualification -> MDoc RdrName -> Html-rdrDocToHtml qual = markupHacked fmt Nothing . cleanup-  where fmt = parHtmlMarkup qual True (const ppRdrName)+rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html+rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup+  where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap))   docElement :: (Html -> Html) -> Html -> Html@@ -225,14 +252,17 @@   docSection :: Maybe Name -- ^ Name of the thing this doc is for+           -> Maybe Package -- ^ Current package            -> Qualification -> Documentation DocName -> Html-docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation+docSection n pkg qual =+  maybe noHtml (docSection_ n pkg qual) . combineDocumentation  -docSection_ :: Maybe Name -- ^ Name of the thing this doc is for+docSection_ :: Maybe Name    -- ^ Name of the thing this doc is for+            -> Maybe Package -- ^ Current package             -> Qualification -> MDoc DocName -> Html-docSection_ n qual =-  (docElement thediv <<) . docToHtml (getOccString <$> n) qual+docSection_ n pkg qual =+  (docElement thediv <<) . docToHtml (getOccString <$> n) pkg qual   cleanup :: MDoc a -> MDoc a@@ -247,8 +277,8 @@     unParagraph (DocParagraph d) = d     unParagraph doc              = doc -    fmtUnParagraphLists :: DocMarkup a (Doc a)+    fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a)     fmtUnParagraphLists = idMarkup {       markupUnorderedList = DocUnorderedList . map unParagraph,-      markupOrderedList   = DocOrderedList   . map unParagraph+      markupOrderedList   = DocOrderedList   . map (\(index, a) -> (index, unParagraph a))       }
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -15,7 +15,7 @@    divPackageHeader, divContent, divModuleHeader, divFooter,   divTableOfContents, divDescription, divSynopsis, divInterface,-  divIndex, divAlphabet, divModuleList,+  divIndex, divAlphabet, divPackageList, divModuleList,  divContentsList,    sectionName,   nonEmptySectionName,@@ -29,28 +29,30 @@   subArguments,   subAssociatedTypes,   subConstructors,+  subPatterns,   subEquations,   subFields,   subInstances, subOrphanInstances,   subInstHead, subInstDetails, subFamInstDetails,   subMethods,+  subDefaults,   subMinimal,    topDeclElem, declElem, ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils (makeAnchorId, nameAnchorId) import qualified Data.Map as Map-import Text.XHtml hiding ( name, title, p, quote )+import Text.XHtml hiding ( name, title, quote )+import Data.Maybe (fromMaybe) -import FastString            ( unpackFS )-import GHC-import Name (nameOccName)+import GHC.Data.FastString ( unpackFS )+import GHC hiding (anchor)+import GHC.Types.Name (nameOccName)  -------------------------------------------------------------------------------- -- * Sections of the document@@ -73,13 +75,13 @@ -- If it would have otherwise been empty, then give it the class ".empty". nonEmptySectionName :: Html -> Html nonEmptySectionName c-  | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml-  | otherwise  = paragraph ! [theclass "caption"]       $ c+  | isNoHtml c = thespan ! [theclass "caption empty"] $ spaceHtml+  | otherwise  = thespan ! [theclass "caption"]       $ c   divPackageHeader, divContent, divModuleHeader, divFooter,   divTableOfContents, divDescription, divSynopsis, divInterface,-  divIndex, divAlphabet, divModuleList+  divIndex, divAlphabet, divPackageList, divModuleList, divContentsList     :: Html -> Html  divPackageHeader    = sectionDiv "package-header"@@ -87,12 +89,14 @@ divModuleHeader     = sectionDiv "module-header" divFooter           = sectionDiv "footer" divTableOfContents  = sectionDiv "table-of-contents"+divContentsList     = sectionDiv "contents-list" divDescription      = sectionDiv "description" divSynopsis         = sectionDiv "synopsis" divInterface        = sectionDiv "interface" divIndex            = sectionDiv "index" divAlphabet         = sectionDiv "alphabet" divModuleList       = sectionDiv "module-list"+divPackageList      = sectionDiv "module-list"   --------------------------------------------------------------------------------@@ -127,89 +131,96 @@     subCaption = paragraph ! [theclass "caption"] << captionName  -subDlist :: Qualification -> [SubDecl] -> Maybe Html-subDlist _ [] = Nothing-subDlist qual decls = Just $ ulist << map subEntry decls+subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html+subDlist _ _ [] = Nothing+subDlist pkg qual decls = Just $ ulist << map subEntry decls   where     subEntry (decl, mdoc, subs) =       li <<         (define ! [theclass "src"] << decl +++-         docElement thediv << (fmap (docToHtml Nothing qual) mdoc +++ subs))+         docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs))  -subTable :: Qualification -> [SubDecl] -> Maybe Html-subTable _ [] = Nothing-subTable qual decls = Just $ table << aboves (concatMap subRow decls)+subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html+subTable _ _ [] = Nothing+subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls)   where     subRow (decl, mdoc, subs) =       (td ! [theclass "src"] << decl        <->-       docElement td << fmap (docToHtml Nothing qual) mdoc)+       docElement td << fmap (docToHtml Nothing pkg qual) mdoc)       : map (cell . (td <<)) subs   -- | Sub table with source information (optional).-subTableSrc :: Qualification -> LinksInfo -> Bool -> [(SubDecl,Located DocName)] -> Maybe Html-subTableSrc _ _  _ [] = Nothing-subTableSrc qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)+subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool+            -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html+subTableSrc _ _ _ _ [] = Nothing+subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)   where-    subRow ((decl, mdoc, subs),L loc dn) =+    subRow ((decl, mdoc, subs), mdl, L loc dn) =       (td ! [theclass "src clearfix"] <<         (thespan ! [theclass "inst-left"] << decl)-        <+> linkHtml loc dn+        <+> linkHtml loc mdl dn       <->-      docElement td << fmap (docToHtml Nothing qual) mdoc+      docElement td << fmap (docToHtml Nothing pkg qual) mdoc       )       : map (cell . (td <<)) subs-    linkHtml loc@(RealSrcSpan _) dn = links lnks loc splice dn-    linkHtml _ _ = noHtml +    linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html+    linkHtml loc@(RealSrcSpan _ _) mdl dn = links lnks loc splice mdl dn+    linkHtml _ _ _ = noHtml+ subBlock :: [Html] -> Maybe Html subBlock [] = Nothing subBlock hs = Just $ toHtml hs  -subArguments :: Qualification -> [SubDecl] -> Html-subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual+subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html+subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual   subAssociatedTypes :: [Html] -> Html subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock  -subConstructors :: Qualification -> [SubDecl] -> Html-subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual+subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html+subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual -subFields :: Qualification -> [SubDecl] -> Html-subFields qual = divSubDecls "fields" "Fields" . subDlist qual+subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html+subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual +subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html+subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual -subEquations :: Qualification -> [SubDecl] -> Html-subEquations qual = divSubDecls "equations" "Equations" . subTable qual +subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html+subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual --- | Generate sub table for instance declarations, with source-subInstances :: Qualification++-- | Generate collapsible sub table for instance declarations, with source+subInstances :: Maybe Package -> Qualification              -> String -- ^ Class name, used for anchor generation              -> LinksInfo -> Bool-             -> [(SubDecl,Located DocName)] -> Html-subInstances qual nm lnks splice = maybe noHtml wrap . instTable+             -> [(SubDecl, Maybe Module, Located DocName)] -> Html+subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable   where-    wrap = (subSection <<) . (subCaption +++)-    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice+    wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))+    instTable = subTableSrc pkg qual lnks splice     subSection = thediv ! [theclass "subs instances"]-    subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"+    hdr = h4 ! collapseControl id_ "instances" << "Instances"+    summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instances details"     id_ = makeAnchorId $ "i:" ++ nm  -subOrphanInstances :: Qualification+subOrphanInstances :: Maybe Package -> Qualification                    -> LinksInfo -> Bool-                   -> [(SubDecl,Located DocName)] -> Html-subOrphanInstances qual lnks splice  = maybe noHtml wrap . instTable+                   -> [(SubDecl, Maybe Module, Located DocName)] -> Html+subOrphanInstances pkg qual lnks splice  = maybe noHtml wrap . instTable   where     wrap = ((h1 << "Orphan instances") +++)-    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice-    id_ = makeAnchorId $ "orphans"+    instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice+    id_ = makeAnchorId "orphans"   subInstHead :: String -- ^ Instance unique id (for anchor generation)@@ -218,26 +229,30 @@ subInstHead iid hdr =     expander noHtml <+> hdr   where-    expander = thespan ! collapseControl (instAnchorId iid) False "instance"+    expander = thespan ! collapseControl (instAnchorId iid) "instance"   subInstDetails :: String -- ^ Instance unique id (for anchor generation)                -> [Html] -- ^ Associated type contents                -> [Html] -- ^ Method contents (pretty-printed signatures)+               -> Html   -- ^ Source module                -> Html-subInstDetails iid ats mets =-    subInstSection iid << (subAssociatedTypes ats <+> subMethods mets)+subInstDetails iid ats mets mdl =+    subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets)  subFamInstDetails :: String -- ^ Instance unique id (for anchor generation)                   -> Html   -- ^ Type or data family instance+                  -> Html   -- ^ Source module TODO: use this                   -> Html-subFamInstDetails iid fi =-    subInstSection iid << thediv ! [theclass "src"] << fi+subFamInstDetails iid fi mdl =+    subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi))  subInstSection :: String -- ^ Instance unique id (for anchor generation)                -> Html                -> Html-subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details"+subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents)+  where+    summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details"  instAnchorId :: String -> String instAnchorId iid = makeAnchorId $ "i:" ++ iid@@ -246,6 +261,9 @@ subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html+subDefaults = divSubDecls "default" "" . subBlock+ subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem @@ -259,13 +277,13 @@ -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html topDeclElem lnks loc splice names html =-    declElem << (html <+> (links lnks loc splice $ head names))+    declElem << (html <+> (links lnks loc splice Nothing $ head names))         -- FIXME: is it ok to simply take the first name?  -- | Adds a source and wiki link at the right hand side of the box. -- Name must be documented, otherwise we wouldn't get here.-links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html-links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice docName@(Documented n mdl) =+links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) =   srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#")   where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) @@ -289,12 +307,13 @@          -- For source links, we want to point to the original module,         -- because only that will have the source.-        -- TODO: do something about type instances. They will point to-        -- the module defining the type family, which is wrong.-        origMod = nameModule n-        origPkg = moduleUnitId origMod+        --+        -- 'mdl'' is a way of "overriding" the module. Without it, instances+        -- will point to the module defining the class/family, which is wrong.+        origMod = fromMaybe (nameModule n) mdl'+        origPkg = moduleUnit origMod          fname = case loc of-          RealSrcSpan l -> unpackFS (srcSpanFile l)+          RealSrcSpan l _ -> unpackFS (srcSpanFile l)           UnhelpfulSpan _ -> error "links: UnhelpfulSpan"-links _ _ _ _ = noHtml+links _ _ _ _ _ = noHtml
+ src/Haddock/Backends/Xhtml/Meta.hs view
@@ -0,0 +1,28 @@+module Haddock.Backends.Xhtml.Meta where++import Haddock.Utils.Json+import Haddock.Version++import Data.ByteString.Builder (hPutBuilder)+import System.FilePath ((</>))+import System.IO (withFile, IOMode (WriteMode))++-- | Everytime breaking changes to the Quckjump api+-- happen this needs to be modified.+quickjumpVersion :: Int+quickjumpVersion = 1++-- | Writes a json encoded file containing additional+-- information about the generated documentation. This+-- is useful for external tools (e.g., Hackage).+writeHaddockMeta :: FilePath -> Bool -> IO ()+writeHaddockMeta odir withQuickjump = do+  let+    meta_json :: Value+    meta_json = object (concat [+        [ "haddock_version"   .= String projectVersion ]+      , [ "quickjump_version" .= quickjumpVersion | withQuickjump ]+      ])++  withFile (odir </> "meta.json") WriteMode $ \h ->+    hPutBuilder h (encodeToBuilder meta_json)
src/Haddock/Backends/Xhtml/Names.hs view
@@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names (   ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,   ppBinder, ppBinderInfix, ppBinder',-  ppModule, ppModuleRef, ppIPName, linkId, Notation(..)+  ppModule, ppModuleRef, ppIPName, linkId, Notation(..),+  ppWrappedDocName, ppWrappedName, ) where  @@ -22,14 +23,14 @@ import Haddock.Types import Haddock.Utils -import Text.XHtml hiding ( name, title, p, quote )+import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M-import qualified Data.List as List+import Data.List ( stripPrefix ) -import GHC-import Name-import RdrName-import FastString (unpackFS)+import GHC hiding (LexicalFixity(..), anchor)+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Data.FastString (unpackFS)   -- | Indicator of how to render a 'DocName' into 'Html'@@ -49,14 +50,17 @@ ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS  -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html-ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName-+ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html+ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml+  where+    (mdl, occ) = unwrap x+    occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName  -- The Bool indicates if it is to be rendered in infix notation-ppLDocName :: Qualification -> Notation -> Located DocName -> Html+ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d + ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName =   case docName of@@ -68,6 +72,19 @@           ppQualifyName qual notation name (nameModule name)       | otherwise -> ppName notation name ++ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html+ppWrappedDocName qual notation insertAnchors docName = case docName of+  Unadorned n -> ppDocName qual notation insertAnchors n+  Parenthesized n -> ppDocName qual Prefix insertAnchors n+  Backticked n -> ppDocName qual Infix insertAnchors n++ppWrappedName :: Notation -> Wrap Name -> Html+ppWrappedName notation docName = case docName of+  Unadorned n -> ppName notation n+  Parenthesized n -> ppName Prefix n+  Backticked n -> ppName Infix n+ -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl =@@ -79,7 +96,7 @@         then ppName notation name         else ppFullQualName notation mdl name     RelativeQual localmdl ->-      case List.stripPrefix (moduleString localmdl) (moduleString mdl) of+      case stripPrefix (moduleString localmdl) (moduleString mdl) of         -- local, A.x -> x         Just []      -> ppName notation name         -- sub-module, A.B.x -> B.x@@ -147,17 +164,19 @@ linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html linkIdOcc mdl mbName insertAnchors =   if insertAnchors-  then anchor ! [href url]+  then anchor ! [href url, title ttl]   else id   where+    ttl = moduleNameString (moduleName mdl)     url = case mbName of       Nothing   -> moduleUrl mdl       Just name -> moduleNameUrl mdl name   linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html-linkIdOcc' mdl mbName = anchor ! [href url]+linkIdOcc' mdl mbName = anchor ! [href url, title ttl]   where+    ttl = moduleNameString mdl     url = case mbName of       Nothing   -> moduleHtmlFile' mdl       Just name -> moduleNameUrl' mdl name@@ -168,9 +187,12 @@                << toHtml (moduleString mdl)  -ppModuleRef :: ModuleName -> String -> Html-ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]-                      << toHtml (moduleNameString mdl)+ppModuleRef :: Maybe Html -> ModuleName -> String -> Html+ppModuleRef Nothing mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]+                              << toHtml (moduleNameString mdl)+ppModuleRef (Just lbl) mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]+                                 << lbl+     -- NB: The ref parameter already includes the '#'.     -- This function is only called from markupModule expanding a     -- DocModule, which doesn't seem to be ever be used.
src/Haddock/Backends/Xhtml/Themes.hs view
@@ -17,6 +17,7 @@     where  import Haddock.Options+import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL )  import Control.Monad (liftM) import Data.Char (toLower)@@ -58,7 +59,7 @@ standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)  --- | Default themes that are part of Haddock; added with --default-themes+-- | Default themes that are part of Haddock; added with @--built-in-themes@ -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme.@@ -176,13 +177,13 @@ cssFiles ts = nub $ concatMap themeFiles ts  -styleSheet :: Themes -> Html-styleSheet ts = toHtml $ zipWith mkLink rels ts+styleSheet :: BaseURL -> Themes -> Html+styleSheet base_url ts = toHtml $ zipWith mkLink rels ts   where     rels = "stylesheet" : repeat "alternate stylesheet"     mkLink aRel t =       thelink-        ! [ href (themeHref t),  rel aRel, thetype "text/css",+        ! [ href (withBaseURL base_url (themeHref t)),  rel aRel, thetype "text/css",             XHtml.title (themeName t)           ]         << noHtml
src/Haddock/Backends/Xhtml/Types.hs view
@@ -12,6 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types (   SourceURLs, WikiURLs,+  BaseURL,+  withBaseURL,   LinksInfo,   Splice,   Unicode,@@ -20,12 +22,21 @@  import Data.Map import GHC+import qualified System.FilePath as FilePath   -- the base, module and entity URLs for the source code and wiki links.-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map UnitId FilePath, Map UnitId FilePath)+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) +-- | base url for loading js, json, css resources.  The default is "."+--+type BaseURL = Maybe String++-- TODO: we shouldn't use 'FilePath.</>'+withBaseURL :: BaseURL -> String -> String+withBaseURL Nothing        uri = uri+withBaseURL (Just baseUrl) uri = baseUrl FilePath.</> uri  -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs)
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -20,12 +20,15 @@   (<+>), (<=>), char,   keyword, punctuate, -  braces, brackets, pabrackets, parens, parenList, ubxParenList,-  arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,+  braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,+  arrow, lollipop, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,+  multAnnotation,+  atSign,    hsep, vcat, -  collapseSection, collapseToggle, collapseControl,+  DetailsState(..), collapseDetails, thesummary,+  collapseToggle, collapseControl, ) where  @@ -36,9 +39,9 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC      ( SrcSpan(..), srcSpanStartLine, Name )-import Module   ( Module, ModuleName, moduleName, moduleNameString )-import Name     ( getOccString, nameOccName, isValOcc )+import GHC              ( SrcSpan(..), srcSpanStartLine, Name )+import GHC.Unit.Module ( Module, ModuleName, moduleName, moduleNameString )+import GHC.Types.Name   ( getOccString, nameOccName, isValOcc )   -- | Replace placeholder string elements with provided values.@@ -73,7 +76,7 @@     Nothing -> ""     Just span_ ->       case span_ of-      RealSrcSpan span__ ->+      RealSrcSpan span__ _ ->         show $ srcSpanStartLine span__       UnhelpfulSpan _ -> "" @@ -109,7 +112,7 @@  hsep :: [Html] -> Html hsep [] = noHtml-hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls+hsep htmls = foldr1 (<+>) htmls  -- | Concatenate a series of 'Html' values vertically, with linebreaks in between. vcat :: [Html] -> Html@@ -177,16 +180,24 @@ ubxParenList = ubxparens . hsep . punctuate comma  +ubxSumList :: [Html]  -> Html+ubxSumList = ubxparens . hsep . punctuate (toHtml " | ")++ ubxparens :: Html -> Html-ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"+ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"  -dcolon, arrow, darrow, forallSymbol :: Bool -> Html+dcolon, arrow, lollipop, darrow, forallSymbol, atSign :: Bool -> Html dcolon unicode = toHtml (if unicode then "∷" else "::") arrow  unicode = toHtml (if unicode then "→" else "->")+lollipop unicode = toHtml (if unicode then "⊸" else "%1 ->") darrow unicode = toHtml (if unicode then "⇒" else "=>") forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"+atSign unicode = toHtml (if unicode then "@" else "@") +multAnnotation :: Html+multAnnotation = toHtml "%"  dot :: Html dot = toHtml "."@@ -209,26 +220,22 @@ -- A section of HTML which is collapsible. -- --- | Attributes for an area that can be collapsed-collapseSection :: String -> Bool -> String -> [HtmlAttr]-collapseSection id_ state classes = [ identifier sid, theclass cs ]-  where cs = unwords (words classes ++ [pick state "show" "hide"])-        sid = "section." ++ id_+data DetailsState = DetailsOpen | DetailsClosed +collapseDetails :: String -> DetailsState -> Html -> Html+collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs)+  where openAttrs = case state of { DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] }++thesummary :: Html -> Html+thesummary = tag "summary"+ -- | Attributes for an area that toggles a collapsed area-collapseToggle :: String -> [HtmlAttr]-collapseToggle id_ = [ strAttr "onclick" js ]-  where js = "toggleSection('" ++ id_ ++ "')";+collapseToggle :: String -> String -> [HtmlAttr]+collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ]+  where cs = unwords (words classes ++ ["details-toggle"])  -- | Attributes for an area that toggles a collapsed area, -- and displays a control.-collapseControl :: String -> Bool -> String -> [HtmlAttr]-collapseControl id_ state classes =-  [ identifier cid, theclass cs ] ++ collapseToggle id_-  where cs = unwords (words classes ++ [pick state "collapser" "expander"])-        cid = "control." ++ id_---pick :: Bool -> a -> a -> a-pick True  t _ = t-pick False _ f = f+collapseControl :: String -> String -> [HtmlAttr]+collapseControl id_ classes = collapseToggle id_ cs+  where cs = unwords (words classes ++ ["details-toggle-control"])
src/Haddock/Convert.hs view
@@ -1,488 +1,986 @@--{-# LANGUAGE CPP, PatternGuards #-}--------------------------------------------------------------------------------- |--- Module      :  Haddock.Convert--- Copyright   :  (c) Isaac Dupree 2009,--- License     :  BSD-like------ Maintainer  :  haddock@projects.haskell.org--- Stability   :  experimental--- Portability :  portable------ Conversion between TyThing and HsDecl. This functionality may be moved into--- GHC at some point.-------------------------------------------------------------------------------module Haddock.Convert where--- Some other functions turned out to be useful for converting--- instance heads, which aren't TyThings, so just export everything.--import Bag ( emptyBag )-import BasicTypes ( TupleSort(..) )-import Class-import CoAxiom-import ConLike-import Data.Either (lefts, rights)-import DataCon-import FamInstEnv-import HsSyn-import Name-import NameSet ( emptyNameSet )-import RdrName ( mkVarUnqual )-import PatSyn-import SrcLoc ( Located, noLoc, unLoc )-import TcType ( tcSplitSigmaTy )-import TyCon-import Type-import TyCoRep-import TysPrim ( alphaTyVars, unliftedTypeKindTyConName )-import TysWiredIn ( listTyConName, starKindTyConName, unitTy )-import PrelNames ( hasKey, eqTyConKey, ipClassKey-                 , tYPETyConKey, ptrRepLiftedDataConKey, ptrRepUnliftedDataConKey )-import Unique ( getUnique )-import Util ( filterByList, filterOut )-import Var--import Haddock.Types-import Haddock.Interface.Specialize------ the main function here! yay!-tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name))-tyThingToLHsDecl t = case t of-  -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.-  -- Including built-in functions like seq.-  -- foreign-imported functions could be represented with ForD-  -- instead of SigD if we wanted...-  ---  -- in a future code version we could turn idVarDetails = foreign-call-  -- into a ForD instead of a SigD if we wanted.  Haddock doesn't-  -- need to care.-  AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i)--  -- type-constructors (e.g. Maybe) are complicated, put the definition-  -- later in the file (also it's used for class associated-types too.)-  ATyCon tc-    | Just cl <- tyConClass_maybe tc -- classes are just a little tedious-    -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)-           extractFamilyDecl (FamDecl d) = return $ noLoc d-           extractFamilyDecl _           =-             Left "tyThingToLHsDecl: impossible associated tycon"--           atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl]-           atFamDecls  = map extractFamilyDecl (rights atTyClDecls)-           tyClErrors = lefts atTyClDecls-           famDeclErrors = lefts atFamDecls-       in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl-         { tcdCtxt = synifyCtx (classSCTheta cl)-         , tcdLName = synifyName cl-         , tcdTyVars = synifyTyVars (classTyVars cl)-         , tcdFDs = map (\ (l,r) -> noLoc-                        (map (noLoc . getName) l, map (noLoc . getName) r) ) $-                         snd $ classTvsFds cl-         , tcdSigs = noLoc (MinimalSig mempty . noLoc . fmap noLoc $ classMinimalDef cl) :-                      map (noLoc . synifyTcIdSig DeleteTopLevelQuantification)-                        (classMethods cl)-         , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature-         -- class associated-types are a subset of TyCon:-         , tcdATs = rights atFamDecls-         , tcdATDefs = [] --ignore associated type defaults-         , tcdDocs = [] --we don't have any docs at this point-         , tcdFVs = placeHolderNamesTc }-    | otherwise-    -> synifyTyCon Nothing tc >>= allOK . TyClD--  -- type-constructors (e.g. Maybe) are complicated, put the definition-  -- later in the file (also it's used for class associated-types too.)-  ACoAxiom ax -> synifyAxiom ax >>= allOK--  -- a data-constructor alone just gets rendered as a function:-  AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]-    (synifySigWcType ImplicitizeForAll (dataConUserType dc)))--  AConLike (PatSynCon ps) ->-    allOK . SigD $ PatSynSig (synifyName ps) (synifyPatSynSigType ps)-  where-    withErrs e x = return (e, x)-    allOK x = return (mempty, x)--synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name-synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })-  = let name       = synifyName tc-        typats     = map (synifyType WithinType) args-        hs_rhs     = synifyType WithinType rhs-    in TyFamEqn { tfe_tycon = name-                , tfe_pats  = HsIB { hsib_body = typats-                                   , hsib_vars = map tyVarName tkvs }-                , tfe_rhs   = hs_rhs }--synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)-synifyAxiom ax@(CoAxiom { co_ax_tc = tc })-  | isOpenTypeFamilyTyCon tc-  , Just branch <- coAxiomSingleBranch_maybe ax-  = return $ InstD (TyFamInstD-                    (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch-                                   , tfid_fvs = placeHolderNamesTc }))--  | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc-  , getUnique ax' == getUnique ax   -- without the getUniques, type error-  = synifyTyCon (Just ax) tc >>= return . TyClD--  | otherwise-  = Left "synifyAxiom: closed/open family confusion"---- | Turn type constructors into type class declarations-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name)-synifyTyCon _coax tc-  | isFunTyCon tc || isPrimTyCon tc-  = return $-    DataDecl { tcdLName = synifyName tc-             , tcdTyVars =       -- tyConTyVars doesn't work on fun/prim, but we can make them up:-                         let mk_hs_tv realKind fakeTyVar-                                = noLoc $ KindedTyVar (noLoc (getName fakeTyVar))-                                                      (synifyKindSig realKind)-                         in HsQTvs { hsq_implicit = []   -- No kind polymorphism-                                   , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc)))-                                                                alphaTyVars --a, b, c... which are unfortunately all kind *-                                   , hsq_dependent = emptyNameSet }--           , tcdDataDefn = HsDataDefn { dd_ND = DataType  -- arbitrary lie, they are neither-                                                    -- algebraic data nor newtype:-                                      , dd_ctxt = noLoc []-                                      , dd_cType = Nothing-                                      , dd_kindSig = Just (synifyKindSig (tyConKind tc))-                                               -- we have their kind accurately:-                                      , dd_cons = []  -- No constructors-                                      , dd_derivs = Nothing }-           , tcdDataCusk = False-           , tcdFVs = placeHolderNamesTc }--synifyTyCon _coax tc-  | Just flav <- famTyConFlav_maybe tc-  = case flav of-      -- Type families-      OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily-      ClosedSynFamilyTyCon mb-        | Just (CoAxiom { co_ax_branches = branches }) <- mb-          -> mkFamDecl $ ClosedTypeFamily $ Just-            $ map (noLoc . synifyAxBranch tc) (fromBranches branches)-        | otherwise-          -> mkFamDecl $ ClosedTypeFamily $ Just []-      BuiltInSynFamTyCon {}-        -> mkFamDecl $ ClosedTypeFamily $ Just []-      AbstractClosedSynFamilyTyCon {}-        -> mkFamDecl $ ClosedTypeFamily Nothing-      DataFamilyTyCon {}-        -> mkFamDecl DataFamily-  where-    resultVar = famTcResVar tc-    mkFamDecl i = return $ FamDecl $-      FamilyDecl { fdInfo = i-                 , fdLName = synifyName tc-                 , fdTyVars = synifyTyVars (tyConTyVars tc)-                 , fdResultSig =-                       synifyFamilyResultSig resultVar (tyConResKind tc)-                 , fdInjectivityAnn =-                       synifyInjectivityAnn  resultVar (tyConTyVars tc)-                                       (familyTyConInjectivityInfo tc)-                 }--synifyTyCon coax tc-  | Just ty <- synTyConRhs_maybe tc-  = return $ SynDecl { tcdLName = synifyName tc-                     , tcdTyVars = synifyTyVars (tyConTyVars tc)-                     , tcdRhs = synifyType WithinType ty-                     , tcdFVs = placeHolderNamesTc }-  | otherwise =-  -- (closed) newtype and data-  let-  alg_nd = if isNewTyCon tc then NewType else DataType-  alg_ctx = synifyCtx (tyConStupidTheta tc)-  name = case coax of-    Just a -> synifyName a -- Data families are named according to their-                           -- CoAxioms, not their TyCons-    _ -> synifyName tc-  tyvars = synifyTyVars (tyConTyVars tc)-  kindSig = Just (tyConKind tc)-  -- The data constructors.-  ---  -- Any data-constructors not exported from the module that *defines* the-  -- type will not (cannot) be included.-  ---  -- Very simple constructors, Haskell98 with no existentials or anything,-  -- probably look nicer in non-GADT syntax.  In source code, all constructors-  -- must be declared with the same (GADT vs. not) syntax, and it probably-  -- is less confusing to follow that principle for the documentation as well.-  ---  -- There is no sensible infix-representation for GADT-syntax constructor-  -- declarations.  They cannot be made in source code, but we could end up-  -- with some here in the case where some constructors use existentials.-  -- That seems like an acceptable compromise (they'll just be documented-  -- in prefix position), since, otherwise, the logic (at best) gets much more-  -- complicated. (would use dataConIsInfix.)-  use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)-  consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)-  cons = rights consRaw-  -- "deriving" doesn't affect the signature, no need to specify any.-  alg_deriv = Nothing-  defn = HsDataDefn { dd_ND      = alg_nd-                    , dd_ctxt    = alg_ctx-                    , dd_cType   = Nothing-                    , dd_kindSig = fmap synifyKindSig kindSig-                    , dd_cons    = cons-                    , dd_derivs  = alg_deriv }- in case lefts consRaw of-  [] -> return $-        DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn-                 , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }-  dataConErrs -> Left $ unlines dataConErrs--synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity-                     -> Maybe (LInjectivityAnn Name)-synifyInjectivityAnn Nothing _ _            = Nothing-synifyInjectivityAnn _       _ NotInjective = Nothing-synifyInjectivityAnn (Just lhs) tvs (Injective inj) =-    let rhs = map (noLoc . tyVarName) (filterByList inj tvs)-    in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs--synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name-synifyFamilyResultSig  Nothing    kind =-   noLoc $ KindSig  (synifyKindSig kind)-synifyFamilyResultSig (Just name) kind =-   noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind))---- User beware: it is your responsibility to pass True (use_gadt_syntax)--- for any constructor that would be misrepresented by omitting its--- result-type.--- But you might want pass False in simple enough cases,--- if you think it looks better.-synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name)-synifyDataCon use_gadt_syntax dc =- let-  -- dataConIsInfix allegedly tells us whether it was declared with-  -- infix *syntax*.-  use_infix_syntax = dataConIsInfix dc-  use_named_field_syntax = not (null field_tys)-  name = synifyName dc-  -- con_qvars means a different thing depending on gadt-syntax-  (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc--  qvars = if use_gadt_syntax-          then synifyTyVars (univ_tvs ++ ex_tvs)-          else synifyTyVars ex_tvs--  -- skip any EqTheta, use 'orig'inal syntax-  ctx = synifyCtx theta--  linear_tys =-    zipWith (\ty bang ->-               let tySyn = synifyType WithinType ty-               in case bang of-                    (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn-                    bang' -> noLoc $ HsBangTy bang' tySyn)-            arg_tys (dataConSrcBangs dc)--  field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys-  con_decl_field fl synTy = noLoc $-    ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy-                 Nothing-  hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of-          (True,True) -> Left "synifyDataCon: contradiction!"-          (True,False) -> return $ RecCon (noLoc field_tys)-          (False,False) -> return $ PrefixCon linear_tys-          (False,True) -> case linear_tys of-                           [a,b] -> return $ InfixCon a b-                           _ -> Left "synifyDataCon: infix with non-2 args?"-  gadt_ty = HsIB [] (synifyType WithinType res_ty)- -- finally we get synifyDataCon's result!- in hs_arg_tys >>=-      \hat ->-        if use_gadt_syntax-           then return $ noLoc $-              ConDeclGADT { con_names = [name]-                          , con_type = gadt_ty-                          , con_doc =  Nothing }-           else return $ noLoc $-              ConDeclH98 { con_name = name-                         , con_qvars = Just qvars-                         , con_cxt   = Just ctx-                         , con_details =  hat-                         , con_doc =  Nothing }--synifyName :: NamedThing n => n -> Located Name-synifyName = noLoc . getName---synifyIdSig :: SynifyTypeState -> Id -> Sig Name-synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i))--synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name-synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i))--synifyCtx :: [PredType] -> LHsContext Name-synifyCtx = noLoc . map (synifyType WithinType)---synifyTyVars :: [TyVar] -> LHsQTyVars Name-synifyTyVars ktvs = HsQTvs { hsq_implicit = []-                           , hsq_explicit = map synifyTyVar ktvs-                           , hsq_dependent = emptyNameSet }--synifyTyVar :: TyVar -> LHsTyVarBndr Name-synifyTyVar tv-  | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))-  | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))-  where-    kind = tyVarKind tv-    name = getName tv----states of what to do with foralls:-data SynifyTypeState-  = WithinType-  -- ^ normal situation.  This is the safe one to use if you don't-  -- quite understand what's going on.-  | ImplicitizeForAll-  -- ^ beginning of a function definition, in which, to make it look-  --   less ugly, those rank-1 foralls are made implicit.-  | DeleteTopLevelQuantification-  -- ^ because in class methods the context is added to the type-  --   (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)-  --   which is rather sensible,-  --   but we want to restore things to the source-syntax situation where-  --   the defining class gets to quantify all its functions for free!---synifySigType :: SynifyTypeState -> Type -> LHsSigType Name--- The empty binders is a bit suspicious;--- what if the type has free variables?-synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty)--synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name--- Ditto (see synifySigType)-synifySigWcType s ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs (synifyType s ty))--synifyPatSynSigType :: PatSyn -> LHsSigType Name--- Ditto (see synifySigType)-synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)--synifyType :: SynifyTypeState -> Type -> LHsType Name-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv)-synifyType _ (TyConApp tc tys)-  -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)-  | tc `hasKey` tYPETyConKey-  , [TyConApp lev []] <- tys-  , lev `hasKey` ptrRepLiftedDataConKey-  = noLoc (HsTyVar (noLoc starKindTyConName))-  | tc `hasKey` tYPETyConKey-  , [TyConApp lev []] <- tys-  , lev `hasKey` ptrRepUnliftedDataConKey-  = noLoc (HsTyVar (noLoc unliftedTypeKindTyConName))-  -- Use non-prefix tuple syntax where possible, because it looks nicer.-  | Just sort <- tyConTuple_maybe tc-  , tyConArity tc == length tys-  = noLoc $ HsTupleTy (case sort of-                          BoxedTuple      -> HsBoxedTuple-                          ConstraintTuple -> HsConstraintTuple-                          UnboxedTuple    -> HsUnboxedTuple)-                       (map (synifyType WithinType) tys)-  -- ditto for lists-  | getName tc == listTyConName, [ty] <- tys =-     noLoc $ HsListTy (synifyType WithinType ty)-  -- ditto for implicit parameter tycons-  | tc `hasKey` ipClassKey-  , [name, ty] <- tys-  , Just x <- isStrLitTy name-  = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)-  -- and equalities-  | tc `hasKey` eqTyConKey-  , [ty1, ty2] <- tys-  = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)-  -- Most TyCons:-  | otherwise =-    foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))-      (noLoc $ HsTyVar $ noLoc (getName tc))-      (map (synifyType WithinType) $-       filterOut isCoercionTy tys)-synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1-synifyType _ (AppTy t1 t2) = let-  s1 = synifyType WithinType t1-  s2 = synifyType WithinType t2-  in noLoc $ HsAppTy s1 s2-synifyType _ (ForAllTy (Anon t1) t2) = let-  s1 = synifyType WithinType t1-  s2 = synifyType WithinType t2-  in noLoc $ HsFunTy s1 s2-synifyType s forallty@(ForAllTy _tv _ty) =-  let (tvs, ctx, tau) = tcSplitSigmaTy forallty-      sPhi = HsQualTy { hst_ctxt = synifyCtx ctx-                      , hst_body = synifyType WithinType tau }-  in case s of-    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau-    WithinType        -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs-                                            , hst_body  = noLoc sPhi }-    ImplicitizeForAll -> noLoc sPhi--synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t-synifyType s (CastTy t _) = synifyType s t-synifyType _ (CoercionTy {}) = error "synifyType:Coercion"--synifyPatSynType :: PatSyn -> LHsType Name-synifyPatSynType ps = let-  (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps-  req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]-               -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",-               -- i.e., an explicit empty context, which is what we need. This is not-               -- possible by taking theta = [], as that will print no context at all-             | otherwise = req_theta-  sForAll []  s = s-  sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs-                             , hst_body  = noLoc s }-  sQual theta s = HsQualTy   { hst_ctxt  = synifyCtx theta-                             , hst_body  = noLoc s }-  sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty-  in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau--synifyTyLit :: TyLit -> HsTyLit-synifyTyLit (NumTyLit n) = HsNumTy mempty n-synifyTyLit (StrTyLit s) = HsStrTy mempty s--synifyKindSig :: Kind -> LHsKind Name-synifyKindSig k = synifyType WithinType k--synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name-synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead-    { ihdClsName = getName cls-    , ihdKinds = map (unLoc . synifyType WithinType) ks-    , ihdTypes = map (unLoc . synifyType WithinType) ts-    , ihdInstType = ClassInst-        { clsiCtx = map (unLoc . synifyType WithinType) preds-        , clsiTyVars = synifyTyVars $ classTyVars cls-        , clsiSigs = map synifyClsIdSig $ classMethods cls-        , clsiAssocTys = do-            (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls-            pure $ mkPseudoFamilyDecl fam-        }-    }-  where-    (ks,ts) = partitionInvisibles (classTyCon cls) id types-    synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification---- Convert a family instance, this could be a type family or data family-synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)-synifyFamInst fi opaque = do-    ityp' <- ityp $ fi_flavor fi-    return InstHead-        { ihdClsName = fi_fam fi-        , ihdKinds = synifyTypes ks-        , ihdTypes = synifyTypes ts-        , ihdInstType = ityp'-        }-  where-    ityp SynFamilyInst | opaque = return $ TypeInst Nothing-    ityp SynFamilyInst =-        return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi-    ityp (DataFamilyInst c) =-        DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c-    (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi-    synifyTypes = map (unLoc. synifyType WithinType)+{-# LANGUAGE CPP           #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE BangPatterns  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Convert+-- Copyright   :  (c) Isaac Dupree 2009,+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Conversion between TyThing and HsDecl. This functionality may be moved into+-- GHC at some point.+-----------------------------------------------------------------------------+module Haddock.Convert (+  tyThingToLHsDecl,+  synifyInstHead,+  synifyFamInst,+  PrintRuntimeReps(..),+) where++import Control.DeepSeq (force)+import GHC.Data.Bag ( emptyBag )+import GHC.Types.Basic ( TupleSort(..), DefMethSpec(..), TopLevelFlag(..) )+import GHC.Types.SourceText (SourceText(..))+import GHC.Types.Fixity (LexicalFixity(..))+import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.FamInstEnv+import GHC.Core.PatSyn+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare( eqTypes )++import GHC.Hs+import GHC.Types.TyThing+import GHC.Types.Name+import GHC.Types.Name.Set    ( emptyNameSet )+import GHC.Types.Name.Reader ( mkVarUnqual )+import GHC.Builtin.Types.Prim ( alphaTyVars )+import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName+                  , unitTy, promotedNilDataCon, promotedConsDataCon )+import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey+                 , liftedDataConKey, boxedRepDataConKey )+import GHC.Types.Unique ( getUnique )+import GHC.Utils.Misc ( chkAppend, dropList, equalLength+                      , filterByList, filterOut )+import GHC.Utils.Panic.Plain ( assert )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.SrcLoc++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import Haddock.Types+import Haddock.Interface.Specialize+import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType )++import Data.Either (lefts, rights)+import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList )+import Data.Either                           ( partitionEithers )+++-- | Whether or not to default 'RuntimeRep' variables to 'LiftedRep'. Check+-- out Note [Defaulting RuntimeRep variables] in GHC.Iface.Type for the+-- motivation.+data PrintRuntimeReps = ShowRuntimeRep | HideRuntimeRep deriving Show++-- the main function here! yay!+tyThingToLHsDecl+  :: PrintRuntimeReps+  -> TyThing+  -> Either String ([String], (HsDecl GhcRn))+tyThingToLHsDecl prr t = case t of+  -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.+  -- Including built-in functions like seq.+  -- foreign-imported functions could be represented with ForD+  -- instead of SigD if we wanted...+  --+  -- in a future code version we could turn idVarDetails = foreign-call+  -- into a ForD instead of a SigD if we wanted.  Haddock doesn't+  -- need to care.+  AnId i -> allOK $ SigD noExtField (synifyIdSig prr ImplicitizeForAll [] i)++  -- type-constructors (e.g. Maybe) are complicated, put the definition+  -- later in the file (also it's used for class associated-types too.)+  ATyCon tc+    | Just cl <- tyConClass_maybe tc -- classes are just a little tedious+    -> let extractFamilyDecl :: TyClDecl a -> Either String (FamilyDecl a)+           extractFamilyDecl (FamDecl _ d) = return d+           extractFamilyDecl _           =+             Left "tyThingToLHsDecl: impossible associated tycon"++           cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn+             -- Without this signature, we trigger GHC#18932+           cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n+           cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn+              (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind++           -- | Convert a LHsTyVarBndr to an equivalent LHsType.+           hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn+           hsLTyVarBndrToType = fmap cvt++           extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn+           extractFamDefDecl fd rhs =+             TyFamInstDecl noAnn $ FamEqn+             { feqn_ext = noAnn+             , feqn_tycon = fdLName fd+             , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)}+             , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $+                           hsq_explicit $ fdTyVars fd+             , feqn_fixity = fdFixity fd+             , feqn_rhs = synifyType WithinType [] rhs }++           extractAtItem+             :: ClassATItem+             -> Either String (LFamilyDecl GhcRn, Maybe (LTyFamDefltDecl GhcRn))+           extractAtItem (ATI at_tc def) = do+             tyDecl <- synifyTyCon prr Nothing at_tc+             famDecl <- extractFamilyDecl tyDecl+             let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def+             pure (noLocA famDecl, defEqnTy)++           atTyClDecls = map extractAtItem (classATItems cl)+           (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls)+           vs = tyConVisibleTyVars (classTyCon cl)++       in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl+         { tcdCtxt = Just $ synifyCtx (classSCTheta cl)+         , tcdLayout = NoLayoutInfo+         , tcdLName = synifyNameN cl+         , tcdTyVars = synifyTyVars vs+         , tcdFixity = synifyFixity cl+         , tcdFDs = map (\ (l,r) -> noLocA+                        (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $+                         snd $ classTvsFds cl+         , tcdSigs = noLocA (MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA $ classMinimalDef cl) :+                      [ noLocA tcdSig+                      | clsOp <- classOpItems cl+                      , tcdSig <- synifyTcIdSig vs clsOp ]+         , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature+         -- class associated-types are a subset of TyCon:+         , tcdATs = atFamDecls+         , tcdATDefs = catMaybes atDefFamDecls+         , tcdDocs = [] --we don't have any docs at this point+         , tcdCExt = emptyNameSet }+    | otherwise+    -> synifyTyCon prr Nothing tc >>= allOK . TyClD noExtField++  -- type-constructors (e.g. Maybe) are complicated, put the definition+  -- later in the file (also it's used for class associated-types too.)+  ACoAxiom ax -> synifyAxiom ax >>= allOK++  -- a data-constructor alone just gets rendered as a function:+  AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc]+    (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc)))++  AConLike (PatSynCon ps) ->+    allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps)+  where+    withErrs e x = return (e, x)+    allOK x = return (mempty, x)++synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn+synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })+  = let name            = synifyNameN tc+        args_types_only = filterOutInvisibleTypes tc args+        typats          = map (synifyType WithinType []) args_types_only+        annot_typats    = zipWith3 annotHsType args_poly args_types_only typats+        hs_rhs          = synifyType WithinType [] rhs+        outer_bndrs     = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}+                                       -- TODO: this must change eventually+    in FamEqn { feqn_ext    = noAnn+              , feqn_tycon  = name+              , feqn_bndrs  = outer_bndrs+              , feqn_pats   = map HsValArg annot_typats+              , feqn_fixity = synifyFixity name+              , feqn_rhs    = hs_rhs }+  where+    args_poly = tyConArgsPolyKinded tc++synifyAxiom :: CoAxiom br -> Either String (HsDecl GhcRn)+synifyAxiom ax@(CoAxiom { co_ax_tc = tc })+  | isOpenTypeFamilyTyCon tc+  , Just branch <- coAxiomSingleBranch_maybe ax+  = return $ InstD noExtField+           $ TyFamInstD noExtField+           $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch }++  | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc+  , getUnique ax' == getUnique ax   -- without the getUniques, type error+  = synifyTyCon ShowRuntimeRep (Just ax) tc >>= return . TyClD noExtField++  | otherwise+  = Left "synifyAxiom: closed/open family confusion"++-- | Turn type constructors into data declarations, type families, or type synonyms+synifyTyCon+  :: PrintRuntimeReps+  -> Maybe (CoAxiom br)  -- ^ RHS of type synonym+  -> TyCon               -- ^ type constructor to convert+  -> Either String (TyClDecl GhcRn)+synifyTyCon prr _coax tc+  | isPrimTyCon tc+  = return $+    DataDecl { tcdLName = synifyNameN tc+             , tcdTyVars = HsQTvs  { hsq_ext = []   -- No kind polymorphism+                                   , hsq_explicit = zipWith mk_hs_tv+                                                            (map scaledThing tyVarKinds)+                                                            alphaTyVars --a, b, c... which are unfortunately all kind *+                                   }++           , tcdFixity = synifyFixity tc++           , tcdDataDefn = HsDataDefn { dd_ext = noExtField+                                      , dd_cons = DataTypeCons False []  -- No constructors; arbitrary lie, they are neither+                                                    -- algebraic data nor newtype:+                                      , dd_ctxt = Nothing+                                      , dd_cType = Nothing+                                      , dd_kindSig = synifyDataTyConReturnKind tc+                                               -- we have their kind accurately:+                                      , dd_derivs = [] }+           , tcdDExt = DataDeclRn False emptyNameSet }+  where+    -- tyConTyVars doesn't work on fun/prim, but we can make them up:+    mk_hs_tv realKind fakeTyVar+      | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar))+      | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind)++    conKind = defaultType prr (tyConKind tc)+    tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind++synifyTyCon _prr _coax tc+  | Just flav <- famTyConFlav_maybe tc+  = case flav of+      -- Type families+      OpenSynFamilyTyCon -> mkFamDecl OpenTypeFamily+      ClosedSynFamilyTyCon mb+        | Just (CoAxiom { co_ax_branches = branches }) <- mb+          -> mkFamDecl $ ClosedTypeFamily $ Just+            $ map (noLocA . synifyAxBranch tc) (fromBranches branches)+        | otherwise+          -> mkFamDecl $ ClosedTypeFamily $ Just []+      BuiltInSynFamTyCon {}+        -> mkFamDecl $ ClosedTypeFamily $ Just []+      AbstractClosedSynFamilyTyCon {}+        -> mkFamDecl $ ClosedTypeFamily Nothing+      DataFamilyTyCon {}+        -> mkFamDecl DataFamily+  where+    resultVar = tyConFamilyResVar_maybe tc+    mkFamDecl i = return $ FamDecl noExtField $+      FamilyDecl { fdExt = noAnn+                 , fdInfo = i+                 , fdTopLevel = TopLevel+                 , fdLName = synifyNameN tc+                 , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)+                 , fdFixity = synifyFixity tc+                 , fdResultSig =+                       synifyFamilyResultSig resultVar (tyConResKind tc)+                 , fdInjectivityAnn =+                       synifyInjectivityAnn  resultVar (tyConTyVars tc)+                                       (tyConInjectivityInfo tc)+                 }++synifyTyCon _prr coax tc+  | Just ty <- synTyConRhs_maybe tc+  = return $ SynDecl { tcdSExt   = emptyNameSet+                     , tcdLName  = synifyNameN tc+                     , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)+                     , tcdFixity = synifyFixity tc+                     , tcdRhs = synifyType WithinType [] ty }+  | otherwise = do+  -- (closed) newtype and data+  let alg_ctx = synifyCtx (tyConStupidTheta tc)+      name = case coax of+        Just a -> synifyNameN a -- Data families are named according to their+                           -- CoAxioms, not their TyCons+        _ -> synifyNameN tc+      tyvars = synifyTyVars (tyConVisibleTyVars tc)+      kindSig = synifyDataTyConReturnKind tc+      -- The data constructors.+      --+      -- Any data-constructors not exported from the module that *defines* the+      -- type will not (cannot) be included.+      --+      -- Very simple constructors, Haskell98 with no existentials or anything,+      -- probably look nicer in non-GADT syntax.  In source code, all constructors+      -- must be declared with the same (GADT vs. not) syntax, and it probably+      -- is less confusing to follow that principle for the documentation as well.+      --+      -- There is no sensible infix-representation for GADT-syntax constructor+      -- declarations.  They cannot be made in source code, but we could end up+      -- with some here in the case where some constructors use existentials.+      -- That seems like an acceptable compromise (they'll just be documented+      -- in prefix position), since, otherwise, the logic (at best) gets much more+      -- complicated. (would use dataConIsInfix.)+      use_gadt_syntax = isGadtSyntaxTyCon tc+  consRaw <- case partitionEithers $ synifyDataCon use_gadt_syntax <$> tyConDataCons tc of+      ([], consRaw) -> Right consRaw+      (errs, _) -> Left (unlines errs)+  cons <- case (isNewTyCon tc, consRaw) of+      (False, cons) -> Right (DataTypeCons False cons)+      (True, [con]) -> Right (NewTypeCon con)+      (True, _) -> Left "Newtype hasn't 1 constructor"++  let -- "deriving" doesn't affect the signature, no need to specify any.+      alg_deriv = []+      defn = HsDataDefn { dd_ext     = noExtField+                    , dd_ctxt    = Just alg_ctx+                    , dd_cType   = Nothing+                    , dd_kindSig = kindSig+                    , dd_cons    = cons+                    , dd_derivs  = alg_deriv }+  pure  DataDecl { tcdLName = name, tcdTyVars = tyvars+                 , tcdFixity = synifyFixity name+                 , tcdDataDefn = defn+                 , tcdDExt = DataDeclRn False emptyNameSet }++-- | In this module, every TyCon being considered has come from an interface+-- file. This means that when considering a data type constructor such as:+--+-- > data Foo (w :: *) (m :: * -> *) (a :: *)+--+-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are+-- also rendering the type variables of Foo, so if we synify the tyConKind of+-- Foo in full, we will end up displaying this in Haddock:+--+-- > data Foo (w :: *) (m :: * -> *) (a :: *)+-- >   :: * -> (* -> *) -> * -> *+--+-- Which is entirely wrong (#548). We only want to display the /return/ kind,+-- which this function obtains.+synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn)+synifyDataTyConReturnKind tc+  | isLiftedTypeKind ret_kind = Nothing -- Don't bother displaying :: *+  | otherwise                 = Just (synifyKindSig ret_kind)+  where ret_kind = tyConResKind tc++synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity+                     -> Maybe (LInjectivityAnn GhcRn)+synifyInjectivityAnn Nothing _ _            = Nothing+synifyInjectivityAnn _       _ NotInjective = Nothing+synifyInjectivityAnn (Just lhs) tvs (Injective inj) =+    let rhs = map (noLocA . tyVarName) (filterByList inj tvs)+    in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs++synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn+synifyFamilyResultSig  Nothing    kind+   | isLiftedTypeKind kind = noLocA $ NoSig noExtField+   | otherwise = noLocA $ KindSig  noExtField (synifyKindSig kind)+synifyFamilyResultSig (Just name) kind =+   noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))++-- User beware: it is your responsibility to pass True (use_gadt_syntax)+-- for any constructor that would be misrepresented by omitting its+-- result-type.+-- But you might want pass False in simple enough cases,+-- if you think it looks better.+synifyDataCon :: Bool -> DataCon -> Either String (LConDecl GhcRn)+synifyDataCon use_gadt_syntax dc =+ let+  -- dataConIsInfix allegedly tells us whether it was declared with+  -- infix *syntax*.+  use_infix_syntax = dataConIsInfix dc+  use_named_field_syntax = not (null field_tys)+  name = synifyNameN dc+  -- con_qvars means a different thing depending on gadt-syntax+  (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc+  user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors++  outer_bndrs | null user_tvbndrs+              = HsOuterImplicit { hso_ximplicit = [] }+              | otherwise+              = HsOuterExplicit { hso_xexplicit = noExtField+                                , hso_bndrs = map synifyTyVarBndr user_tvbndrs }++  -- skip any EqTheta, use 'orig'inal syntax+  ctx | null theta = Nothing+      | otherwise = Just $ synifyCtx theta++  linear_tys =+    zipWith (\ty bang ->+               let tySyn = synifyType WithinType [] (scaledThing ty)+               in case bang of+                    (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn+                    bang' -> noLocA $ HsBangTy noAnn bang' tySyn)+            arg_tys (dataConSrcBangs dc)++  field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys+  con_decl_field fl synTy = noLocA $+    ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ field_label $ flLabel fl)] synTy+                 Nothing++  mk_h98_arg_tys :: Either String (HsConDeclH98Details GhcRn)+  mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of+    (True,True) -> Left "synifyDataCon: contradiction!"+    (True,False) -> return $ RecCon (noLocA field_tys)+    (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)+    (False,True) -> case linear_tys of+                     [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)+                     _ -> Left "synifyDataCon: infix with non-2 args?"++  mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn+  mk_gadt_arg_tys+    | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok+    | otherwise              = PrefixConGADT (map hsUnrestricted linear_tys)++ -- finally we get synifyDataCon's result!+ in if use_gadt_syntax+       then do+         let hat = mk_gadt_arg_tys+         return $ noLocA $ ConDeclGADT+           { con_g_ext  = noAnn+           , con_names  = pure name+           , con_dcolon = noHsUniTok+           , con_bndrs  = noLocA outer_bndrs+           , con_mb_cxt = ctx+           , con_g_args = hat+           , con_res_ty = synifyType WithinType [] res_ty+           , con_doc    = Nothing }+       else do+         hat <- mk_h98_arg_tys+         return $ noLocA $ ConDeclH98+           { con_ext    = noAnn+           , con_name   = name+           , con_forall = False+           , con_ex_tvs = map (synifyTyVarBndr . (mkForAllTyBinder InferredSpec)) ex_tvs+           , con_mb_cxt = ctx+           , con_args   = hat+           , con_doc    = Nothing }++synifyNameN :: NamedThing n => n -> LocatedN Name+synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)++-- synifyName :: NamedThing n => n -> LocatedA Name+-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)++-- | Guess the fixity of a something with a name. This isn't quite right, since+-- a user can always declare an infix name in prefix form or a prefix name in+-- infix form. Unfortunately, that is not something we can usually reconstruct.+synifyFixity :: NamedThing n => n -> LexicalFixity+synifyFixity n | isSymOcc (getOccName n) = Infix+               | otherwise = Prefix++synifyIdSig+  :: PrintRuntimeReps -- ^ are we printing tyvars of kind 'RuntimeRep'?+  -> SynifyTypeState  -- ^ what to do with a 'forall'+  -> [TyVar]          -- ^ free variables in the type to convert+  -> Id               -- ^ the 'Id' from which to get the type signature+  -> Sig GhcRn+synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)+  where+    !n = force $ synifyNameN i+    t = defaultType prr (varType i)++-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going+-- to contain the synified 'ClassOpSig' as well (when appropriate) a default+-- 'ClassOpSig'.+synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]+synifyTcIdSig vs (i, dm) =+  [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] +++  [ ClassOpSig noAnn True [noLocA dn] (defSig dt)+  | Just (dn, GenericDM dt) <- [dm] ]+  where+    mainSig t = synifySigType DeleteTopLevelQuantification vs t+    defSig t = synifySigType ImplicitizeForAll vs t++synifyCtx :: [PredType] -> LHsContext GhcRn+synifyCtx ts = noLocA ( map (synifyType WithinType []) ts)+++synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn+synifyTyVars ktvs = HsQTvs { hsq_ext = []+                           , hsq_explicit = map synifyTyVar ktvs }++synifyTyVar :: TyVar -> LHsTyVarBndr () GhcRn+synifyTyVar = synify_ty_var emptyVarSet ()++synifyTyVarBndr :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn+synifyTyVarBndr = synifyTyVarBndr' emptyVarSet++synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn+synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv++-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind+-- signatures (even if they don't have the lifted type kind).+synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn+synify_ty_var no_kinds flag tv+  | isLiftedTypeKind kind || tv `elemVarSet` no_kinds+  = noLocA (UserTyVar noAnn flag (noLocA name))+  | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind))+  where+    kind = tyVarKind tv+    name = getName tv++-- | Annotate (with HsKingSig) a type if the first parameter is True+-- and if the type contains a free variable.+-- This is used to synify type patterns for poly-kinded tyvars in+-- synifying class and type instances.+annotHsType :: Bool   -- True <=> annotate+            -> Type -> LHsType GhcRn -> LHsType GhcRn+  -- tiny optimization: if the type is annotated, don't annotate again.+annotHsType _    _  hs_ty@(L _ (HsKindSig {})) = hs_ty+annotHsType True ty hs_ty+  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty+  = let ki    = typeKind ty+        hs_ki = synifyType WithinType [] ki+    in noLocA (HsKindSig noAnn hs_ty hs_ki)+annotHsType _    _ hs_ty = hs_ty++-- | For every argument type that a type constructor accepts,+-- report whether or not the argument is poly-kinded. This is used to+-- eventually feed into 'annotThType'.+tyConArgsPolyKinded :: TyCon -> [Bool]+tyConArgsPolyKinded tc =+     map (is_poly_ty . tyVarKind)      tc_vis_tvs+  ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs+  ++ repeat True+  where+    is_poly_ty :: Type -> Bool+    is_poly_ty ty = not $+                    isEmptyVarSet $+                    filterVarSet isTyVar $+                    tyCoVarsOfType ty++    tc_vis_tvs :: [TyVar]+    tc_vis_tvs = tyConVisibleTyVars tc++    tc_res_kind_vis_bndrs :: [PiTyBinder]+    tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc++--states of what to do with foralls:+data SynifyTypeState+  = WithinType+  -- ^ normal situation.  This is the safe one to use if you don't+  -- quite understand what's going on.+  | ImplicitizeForAll+  -- ^ beginning of a function definition, in which, to make it look+  --   less ugly, those rank-1 foralls (without kind annotations) are made+  --   implicit.+  | DeleteTopLevelQuantification+  -- ^ because in class methods the context is added to the type+  --   (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)+  --   which is rather sensible,+  --   but we want to restore things to the source-syntax situation where+  --   the defining class gets to quantify all its functions for free!+++synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn+-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)+-- is a bit suspicious; what if the type has free variables?+synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)++synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn+-- Ditto (see synifySigType)+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty))++synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn+-- Ditto (see synifySigType)+synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps)++-- | Depending on the first argument, try to default all type variables of kind+-- 'RuntimeRep' to 'LiftedType'.+defaultType :: PrintRuntimeReps -> Type -> Type+defaultType ShowRuntimeRep = id+defaultType HideRuntimeRep = defaultRuntimeRepVars++-- | Convert a core type into an 'HsType'.+synifyType+  :: SynifyTypeState  -- ^ what to do with a 'forall'+  -> [TyVar]          -- ^ free variables in the type to convert+  -> Type             -- ^ the type to convert+  -> LHsType GhcRn+synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv)+synifyType _ vs (TyConApp tc tys)+  = maybe_sig res_ty+  where+    res_ty :: LHsType GhcRn+    res_ty+      -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)+      | tc `hasKey` tYPETyConKey+      , [TyConApp rep [TyConApp lev []]] <- tys+      , rep `hasKey` boxedRepDataConKey+      , lev `hasKey` liftedDataConKey+      = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName))+      -- Use non-prefix tuple syntax where possible, because it looks nicer.+      | Just sort <- tyConTuple_maybe tc+      , tyConArity tc == tys_len+      = noLocA $ HsTupleTy noAnn+                          (case sort of+                              BoxedTuple      -> HsBoxedOrConstraintTuple+                              ConstraintTuple -> HsBoxedOrConstraintTuple+                              UnboxedTuple    -> HsUnboxedTuple)+                           (map (synifyType WithinType vs) vis_tys)+      | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)+      | Just dc <- isPromotedDataCon_maybe tc+      , isTupleDataCon dc+      , dataConSourceArity dc == length vis_tys+      = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)+      -- ditto for lists+      | getName tc == listTyConName, [ty] <- vis_tys =+         noLocA $ HsListTy noAnn (synifyType WithinType vs ty)+      | tc == promotedNilDataCon, [] <- vis_tys+      = noLocA $ HsExplicitListTy noExtField IsPromoted []+      | tc == promotedConsDataCon+      , [ty1, ty2] <- vis_tys+      = let hTy = synifyType WithinType vs ty1+        in case synifyType WithinType vs ty2 of+             tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy+                 -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')+                 | otherwise+                 -> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy+      -- ditto for implicit parameter tycons+      | tc `hasKey` ipClassKey+      , [name, ty] <- tys+      , Just x <- isStrLitTy name+      = noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)+      -- and equalities+      | tc `hasKey` eqTyConKey+      , [ty1, ty2] <- tys+      = noLocA $ HsOpTy noAnn+                       NotPromoted+                       (synifyType WithinType vs ty1)+                       (noLocA eqTyConName)+                       (synifyType WithinType vs ty2)+      -- and infix type operators+      | isSymOcc (nameOccName (getName tc))+      , ty1:ty2:tys_rest <- vis_tys+      = mk_app_tys (HsOpTy noAnn+                           prom+                           (synifyType WithinType vs ty1)+                           (noLocA $ getName tc)+                           (synifyType WithinType vs ty2))+                   tys_rest+      -- Most TyCons:+      | otherwise+      = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc))+                   vis_tys+      where+        !prom = if isPromotedDataCon tc then IsPromoted else NotPromoted+        mk_app_tys ty_app ty_args =+          foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)+                (noLocA ty_app)+                (map (synifyType WithinType vs) $+                 filterOut isCoercionTy ty_args)++    tys_len = length tys+    vis_tys = filterOutInvisibleTypes tc tys++    maybe_sig :: LHsType GhcRn -> LHsType GhcRn+    maybe_sig ty'+      | tyConAppNeedsKindSig False tc tys_len+      = let full_kind  = typeKind (mkTyConApp tc tys)+            full_kind' = synifyType WithinType vs full_kind+        in noLocA $ HsKindSig noAnn ty' full_kind'+      | otherwise = ty'++synifyType _ vs ty@(AppTy {}) = let+  (ty_head, ty_args) = splitAppTys ty+  ty_head' = synifyType WithinType vs ty_head+  ty_args' = map (synifyType WithinType vs) $+             filterOut isCoercionTy $+             filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args)+                          ty_args+  in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'++synifyType s vs funty@(FunTy af w t1 t2)+  | isInvisibleFunArg af = synifySigmaType s vs funty+  | otherwise            = noLocA $ HsFunTy noAnn w' s1 s2+  where+    s1 = synifyType WithinType vs t1+    s2 = synifyType WithinType vs t2+    w' = synifyMult vs w++synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =+  case argf of+    Required    -> synifyVisForAllType vs forallty+    Invisible _ -> synifySigmaType s vs forallty++synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t+synifyType s vs (CastTy t _) = synifyType s vs t+synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion"++-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'+synifyVisForAllType+  :: [TyVar]          -- ^ free variables in the type to convert+  -> Type             -- ^ the forall type to convert+  -> LHsType GhcRn+synifyVisForAllType vs ty =+  let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty++      sTvs = map synifyTyVarBndr tvs++      -- Figure out what the type variable order would be inferred in the+      -- absence of an explicit forall+      tvs' = orderedFVs (mkVarSet vs) [rho]++  in noLocA $ HsForAllTy { hst_tele    = mkHsForAllVisTele noAnn sTvs+                         , hst_xforall = noExtField+                         , hst_body    = synifyType WithinType (tvs' ++ vs) rho }++-- | Process a 'Type' which starts with an invisible @forall@ or a constraint+-- into an 'HsType'+synifySigmaType+  :: SynifyTypeState  -- ^ what to do with the 'forall'+  -> [TyVar]          -- ^ free variables in the type to convert+  -> Type             -- ^ the forall type to convert+  -> LHsType GhcRn+synifySigmaType s vs ty =+  let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty+      sPhi = HsQualTy { hst_ctxt = synifyCtx ctx+                      , hst_xqual = noExtField+                      , hst_body = synifyType WithinType (tvs' ++ vs) tau }++      sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs+                       , hst_xforall = noExtField+                       , hst_body  = noLocA sPhi }++      sTvs = map synifyTyVarBndr tvs++      -- Figure out what the type variable order would be inferred in the+      -- absence of an explicit forall+      tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])++  in case s of+    DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau++    -- Put a forall in if there are any type variables+    WithinType+      | not (null tvs) -> noLocA sTy+      | otherwise -> noLocA sPhi++    ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau++-- | Put a forall in if there are any type variables which require+-- explicit kind annotations or if the inferred type variable order+-- would be different.+implicitForAll+  :: [TyCon]          -- ^ type constructors that determine their args kinds+  -> [TyVar]          -- ^ free variables in the type to convert+  -> [InvisTVBinder]  -- ^ type variable binders in the forall+  -> ThetaType        -- ^ constraints right after the forall+  -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type+  -> Type             -- ^ inner type+  -> LHsType GhcRn+implicitForAll tycons vs tvs ctx synInner tau+  | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy+  | tvs' /= (binderVars tvs)           = noLocA sTy+  | otherwise                          = noLocA sPhi+  where+  sRho = synInner (tvs' ++ vs) tau+  sPhi | null ctx = unLoc sRho+       | otherwise+       = HsQualTy { hst_ctxt = synifyCtx ctx+                  , hst_xqual = noExtField+                  , hst_body = synInner (tvs' ++ vs) tau }+  sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs+                   , hst_xforall = noExtField+                   , hst_body = noLocA sPhi }++  no_kinds_needed = noKindTyVars tycons tau+  sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs++  -- Figure out what the type variable order would be inferred in the+  -- absence of an explicit forall+  tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])++++-- | Find the set of type variables whose kind signatures can be properly+-- inferred just from their uses in the type signature. This means the type+-- variable to has at least one fully applied use @f x1 x2 ... xn@ where:+--+--   * @f@ has a function kind where the arguments have the same kinds+--     as @x1 x2 ... xn@.+--+--   * @f@ has a function kind whose final return has lifted type kind+--+noKindTyVars+  :: [TyCon]  -- ^ type constructors that determine their args kinds+  -> Type     -- ^ type to inspect+  -> VarSet   -- ^ set of variables whose kinds can be inferred from uses in the type+noKindTyVars _ (TyVarTy var)+  | isLiftedTypeKind (tyVarKind var) = unitVarSet var+noKindTyVars ts ty+  | (f, xs) <- splitAppTys ty+  , not (null xs)+  = let args = map (noKindTyVars ts) xs+        func = case f of+                 TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var)+                             , map scaledThing xsKinds `eqTypes` map typeKind xs+                             , isLiftedTypeKind outKind+                             -> unitVarSet var+                 TyConApp t ks | t `elem` ts+                               , all noFreeVarsOfType ks+                               -> mkVarSet [ v | TyVarTy v <- xs ]+                 _ -> noKindTyVars ts f+    in unionVarSets (func : args)+noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t+noKindTyVars ts (FunTy _ w t1 t2) = noKindTyVars ts w `unionVarSet`+                                    noKindTyVars ts t1 `unionVarSet`+                                    noKindTyVars ts t2+noKindTyVars ts (CastTy t _) = noKindTyVars ts t+noKindTyVars _ _ = emptyVarSet++synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn+synifyMult vs t = case t of+                    OneTy  -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)+                    ManyTy -> HsUnrestrictedArrow noHsUniTok+                    ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok++++synifyPatSynType :: PatSyn -> LHsType GhcRn+synifyPatSynType ps =+  let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps+      ts = maybeToList (tyConAppTyCon_maybe res_ty)++      -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",+      -- i.e., an explicit empty context, which is what we need. This is not+      -- possible by taking theta = [], as that will print no context at all+      req_theta' | null req_theta+                 , not (null prov_theta && null ex_tvs)+                 = [unitTy]+                 | otherwise = req_theta++  in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta'+       (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))+       (mkScaledFunTys arg_tys res_ty)++synifyTyLit :: TyLit -> HsTyLit GhcRn+synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n+synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s+synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c++synifyKindSig :: Kind -> LHsKind GhcRn+synifyKindSig k = synifyType WithinType [] k++stripKindSig :: LHsType GhcRn -> LHsType GhcRn+stripKindSig (L _ (HsKindSig _ t _)) = t+stripKindSig t = t++synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn+synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead+    { ihdClsName = getName cls+    , ihdTypes = map unLoc annot_ts+    , ihdInstType = ClassInst+        { clsiCtx = map (unLoc . synifyType WithinType []) preds+        , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)+        , clsiSigs = map synifyClsIdSig $ classMethods cls+        , clsiAssocTys = do+            (Right (FamDecl _ fam)) <- map (synifyTyCon HideRuntimeRep Nothing)+                                           (classATs cls)+            pure $ mkPseudoFamilyDecl fam+        }+    }+  where+    cls_tycon = classTyCon cls+    ts  = filterOutInvisibleTypes cls_tycon types+    ts' = map (synifyType WithinType vs) ts+    annot_ts = zipWith3 annotHsType args_poly ts ts'+    args_poly = tyConArgsPolyKinded cls_tycon+    synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs++-- Convert a family instance, this could be a type family or data family+synifyFamInst :: FamInst -> Bool -> Either String (InstHead GhcRn)+synifyFamInst fi opaque = do+    ityp' <- ityp fam_flavor+    return InstHead+        { ihdClsName = fi_fam fi+        , ihdTypes = map unLoc annot_ts+        , ihdInstType = ityp'+        }+  where+    ityp SynFamilyInst | opaque = return $ TypeInst Nothing+    ityp SynFamilyInst =+        return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs+    ityp (DataFamilyInst c) =+        DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c+    fam_tc     = famInstTyCon fi+    fam_flavor = fi_flavor fi+    fam_lhs    = fi_tys fi+    fam_rhs    = fi_rhs fi++    eta_expanded_lhs+      -- eta-expand lhs types, because sometimes data/newtype+      -- instances are eta-reduced; See Trac #9692+      -- See Note [Eta reduction for data family axioms] in GHC.Tc.TyCl.Instance in GHC+      | DataFamilyInst rep_tc <- fam_flavor+      = let (_, rep_tc_args) = splitTyConApp fam_rhs+            etad_tyvars      = dropList rep_tc_args $ tyConTyVars rep_tc+            etad_tys         = mkTyVarTys etad_tyvars+            eta_exp_lhs      = fam_lhs `chkAppend` etad_tys+        in eta_exp_lhs+      | otherwise+      = fam_lhs++    ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs+    synifyTypes = map (synifyType WithinType [])+    ts' = synifyTypes ts+    annot_ts = zipWith3 annotHsType args_poly ts ts'+    args_poly = tyConArgsPolyKinded fam_tc++{-+Note [Invariant: Never expand type synonyms]++In haddock, we never want to expand a type synonym that may be presented to the+user, as we want to keep the link to the abstraction captured in the synonym.++All code in Haddock.Convert must make sure that this invariant holds.++See https://github.com/haskell/haddock/issues/879 for a bug where this+invariant didn't hold.+-}++-- | A version of 'TcType.tcSplitSigmaTy' that:+--+-- 1. Preserves type synonyms.+-- 2. Returns 'InvisTVBinder's instead of 'TyVar's.+--+-- See Note [Invariant: Never expand type synonyms]+tcSplitSigmaTyPreserveSynonyms :: Type -> ([InvisTVBinder], ThetaType, Type)+tcSplitSigmaTyPreserveSynonyms ty =+    case tcSplitForAllTysInvisPreserveSynonyms ty of+      (tvs, rho) -> case tcSplitPhiTyPreserveSynonyms rho of+        (theta, tau) -> (tvs, theta, tau)++-- | See Note [Invariant: Never expand type synonyms]+tcSplitSomeForAllTysPreserveSynonyms ::+  (ForAllTyFlag -> Bool) -> Type -> ([ForAllTyBinder], Type)+tcSplitSomeForAllTysPreserveSynonyms argf_pred ty = split ty ty []+  where+    split _ (ForAllTy tvb@(Bndr _ argf) ty') tvs+      | argf_pred argf  = split ty' ty' (tvb:tvs)+    split orig_ty _ tvs = (reverse tvs, orig_ty)++-- | See Note [Invariant: Never expand type synonyms]+tcSplitForAllTysReqPreserveSynonyms :: Type -> ([ReqTVBinder], Type)+tcSplitForAllTysReqPreserveSynonyms ty =+  let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleForAllTyFlag ty+      req_bndrs         = mapMaybe mk_req_bndr_maybe all_bndrs in+  assert ( req_bndrs `equalLength` all_bndrs)+    (req_bndrs, body)+  where+    mk_req_bndr_maybe :: ForAllTyBinder -> Maybe ReqTVBinder+    mk_req_bndr_maybe (Bndr tv argf) = case argf of+      Required    -> Just $ Bndr tv ()+      Invisible _ -> Nothing++-- | See Note [Invariant: Never expand type synonyms]+tcSplitForAllTysInvisPreserveSynonyms :: Type -> ([InvisTVBinder], Type)+tcSplitForAllTysInvisPreserveSynonyms ty =+  let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleForAllTyFlag ty+      inv_bndrs         = mapMaybe mk_inv_bndr_maybe all_bndrs in+  assert ( inv_bndrs `equalLength` all_bndrs)+    (inv_bndrs, body)+  where+    mk_inv_bndr_maybe :: ForAllTyBinder -> Maybe InvisTVBinder+    mk_inv_bndr_maybe (Bndr tv argf) = case argf of+      Invisible s -> Just $ Bndr tv s+      Required    -> Nothing++-- | See Note [Invariant: Never expand type synonyms]++-- | See Note [Invariant: Never expand type synonyms]+tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type)+tcSplitPhiTyPreserveSynonyms ty0 = split ty0 []+  where+    split ty ts+      = case tcSplitPredFunTyPreserveSynonyms_maybe ty of+          Just (pred_, ty') -> split ty' (pred_:ts)+          Nothing           -> (reverse ts, ty)++-- | See Note [Invariant: Never expand type synonyms]+tcSplitPredFunTyPreserveSynonyms_maybe :: Type -> Maybe (PredType, Type)+tcSplitPredFunTyPreserveSynonyms_maybe (FunTy af _ arg res)+  | isInvisibleFunArg af = Just (arg, res)+tcSplitPredFunTyPreserveSynonyms_maybe _ = Nothing
src/Haddock/GhcUtils.hs view
@@ -1,5 +1,14 @@-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE BangPatterns, FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- |@@ -17,141 +26,432 @@   import Control.Arrow-import Data.Function+import Data.Char ( isSpace )+import Data.Foldable ( toList, foldl' )+import Data.List.NonEmpty ( NonEmpty )+import Data.Maybe ( mapMaybe, fromMaybe )+import qualified Data.Set as Set -import Exception-import Outputable-import Name-import Lexeme-import Module-import RdrName (GlobalRdrEnv)-import GhcMonad (withSession)-import HscTypes-import UniqFM+import Haddock.Types( DocName, DocNameI, XRecCond )++import GHC.Utils.FV as FV+import GHC.Utils.Outputable ( Outputable )+import GHC.Utils.Panic ( panic )+import GHC.Driver.Ppr (showPpr )+import GHC.Types.Name+import GHC.Unit.Module import GHC-import Class+import GHC.Driver.Session+import GHC.Types.SrcLoc  ( advanceSrcLoc )+import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder+                         , tyVarKind, updateTyVarKind, isInvisibleForAllTyFlag )+import GHC.Types.Var.Set ( VarSet, emptyVarSet )+import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )+import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Core.Type     ( isRuntimeRepVar, binderVar )+import GHC.Builtin.Types( liftedRepTy ) +import           GHC.Data.StringBuffer ( StringBuffer )+import qualified GHC.Data.StringBuffer             as S +import           Data.ByteString ( ByteString )+import qualified Data.ByteString          as BS+import qualified Data.ByteString.Internal as BS++import GHC.HsToCore.Docs+ moduleString :: Module -> String moduleString = moduleNameString . moduleName  isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName --isVarSym :: OccName -> Bool-isVarSym = isLexVarSym . occNameFS--isConSym :: OccName -> Bool-isConSym = isLexConSym . occNameFS---getMainDeclBinder :: HsDecl name -> [name]-getMainDeclBinder (TyClD d) = [tcdName d]-getMainDeclBinder (ValD d) =-  case collectHsBindBinders d of-    []       -> []-    (name:_) -> [name]-getMainDeclBinder (SigD d) = sigNameNoLoc d-getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]-getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []-getMainDeclBinder _ = []---- Extract the source location where an instance is defined. This is used--- to correlate InstDecls with their Instance/CoAxiom Names, via the--- instanceMap.-getInstLoc :: InstDecl name -> SrcSpan-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)-getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l-getInstLoc (TyFamInstD (TyFamInstDecl-  -- Since CoAxioms' Names refer to the whole line for type family instances-  -- in particular, we need to dig a bit deeper to pull out the entire-  -- equation. This does not happen for data family instances, for some reason.-  { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l- -- Useful when there is a signature with multiple names, e.g. --   foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names.-filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)+filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)-filterSigNames p orig@(SpecSig n _ _)          = ifTrueJust (p $ unLoc n) orig-filterSigNames p orig@(InlineSig n _)          = ifTrueJust (p $ unLoc n) orig-filterSigNames p (FixSig (FixitySig ns ty)) =+filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p))+filterSigNames p orig@(SpecSig _ n _ _)          = ifTrueJust (p $ unLoc n) orig+filterSigNames p orig@(InlineSig _ n _)          = ifTrueJust (p $ unLoc n) orig+filterSigNames p (FixSig _ (FixitySig _ ns ty)) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (FixSig (FixitySig filtered ty))+    filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _)      = Just orig-filterSigNames p (TypeSig ns ty) =+filterSigNames p (TypeSig _ ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (TypeSig filtered ty)-filterSigNames p (ClassOpSig is_default ns ty) =+    filtered -> Just (TypeSig noAnn filtered ty)+filterSigNames p (ClassOpSig _ is_default ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (ClassOpSig is_default filtered ty)-filterSigNames _ _                           = Nothing+    filtered -> Just (ClassOpSig noAnn is_default filtered ty)+filterSigNames p (PatSynSig _ ns ty) =+  case filter (p . unLoc) ns of+    []       -> Nothing+    filtered -> Just (PatSynSig noAnn filtered ty)+filterSigNames _ _                             = Nothing  ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True  = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [name]-sigName (L _ sig) = sigNameNoLoc sig--sigNameNoLoc :: Sig name -> [name]-sigNameNoLoc (TypeSig      ns _)       = map unLoc ns-sigNameNoLoc (ClassOpSig _ ns _)       = map unLoc ns-sigNameNoLoc (PatSynSig    n _)        = [unLoc n]-sigNameNoLoc (SpecSig      n _ _)      = [unLoc n]-sigNameNoLoc (InlineSig    n _)        = [unLoc n]-sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns-sigNameNoLoc _                         = []+sigName :: LSig GhcRn -> [IdP GhcRn]+sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig  -- | Was this signature given by the user?-isUserLSig :: LSig name -> Bool-isUserLSig (L _(TypeSig {}))    = True-isUserLSig (L _(ClassOpSig {})) = True-isUserLSig _                    = False-+isUserLSig :: forall p. UnXRec p => LSig p -> Bool+isUserLSig = isUserSig . unXRec @p  isClassD :: HsDecl a -> Bool-isClassD (TyClD d) = isClassDecl d+isClassD (TyClD _ d) = isClassDecl d isClassD _ = False -isValD :: HsDecl a -> Bool-isValD (ValD _) = True-isValD _ = False+pretty :: Outputable a => DynFlags -> a -> String+pretty = showPpr +-- --------------------------------------------------------------------- -declATs :: HsDecl a -> [a]-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d-declATs _ = []+-- These functions are duplicated from the GHC API, as they must be+-- instantiated at DocNameI instead of (GhcPass _). +-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ DataConCantHappen, UnXRec n)+                => HsTyVarBndr flag n -> IdP n+hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name+hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name -pretty :: Outputable a => DynFlags -> a -> String-pretty = showPpr+hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName+hsTyVarNameI (UserTyVar _ _ (L _ n))     = n+hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n +hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName+hsLTyVarNameI = hsTyVarNameI . unLoc++getConNamesI :: ConDecl DocNameI -> NonEmpty (LocatedN DocName)+getConNamesI ConDeclH98  {con_name  = name}  = pure name+getConNamesI ConDeclGADT {con_names = names} = names++hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI+hsSigTypeI = sig_body . unLoc++mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn+-- Dubious, because the implicit binders are empty even+-- though the type might have free variables+mkEmptySigType lty@(L loc ty) = L loc $ case ty of+  HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }+             , hst_body = body }+    -> HsSig { sig_ext = noExtField+             , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField+                                           , hso_bndrs     = bndrs }+             , sig_body = body }+  _ -> HsSig { sig_ext   = noExtField+             , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}+             , sig_body = lty }++mkHsForAllInvisTeleI ::+  [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI+mkHsForAllInvisTeleI invis_bndrs =+  HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }++mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI+mkHsImplicitSigTypeI body =+  HsSig { sig_ext   = noExtField+        , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}+        , sig_body  = body }++getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI+-- The full type of a GADT data constructor We really only get this in+-- order to pretty-print it, and currently only in Haddock's code.  So+-- we are cavalier about locations and extensions, hence the+-- 'undefined's+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs+                            , con_mb_cxt = mcxt, con_g_args = args+                            , con_res_ty = res_ty })+ = noLocA (HsSig { sig_ext   = noExtField+                 , sig_bndrs = outer_bndrs+                 , sig_body  = theta_ty })+ where+   theta_ty | Just theta <- mcxt+            = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty })+            | otherwise+            = tau_ty++--  tau_ty :: LHsType DocNameI+   tau_ty = case args of+              RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty+              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)++   mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI+   mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b)++getGADTConType (ConDeclH98 {}) = panic "getGADTConType"+  -- Should only be called on ConDeclGADT++getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI]+getMainDeclBinderI (TyClD _ d) = [tcdNameI d]+getMainDeclBinderI (ValD _ d) =+  case collectHsBindBinders CollNoDictBinders d of+    []       -> []+    (name:_) -> [name]+getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d+getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []+getMainDeclBinderI _ = []++familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName+familyDeclLNameI (FamilyDecl { fdLName = n }) = n++tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName+tyClDeclLNameI (FamDecl { tcdFam = fd })     = familyDeclLNameI fd+tyClDeclLNameI (SynDecl { tcdLName = ln })   = ln+tyClDeclLNameI (DataDecl { tcdLName = ln })  = ln+tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln++tcdNameI :: TyClDecl DocNameI -> DocName+tcdNameI = unLoc . tyClDeclLNameI++addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn+-- Add the class context to a class-op signature+addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))+  = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))+  where+    go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))+       = L loc (HsSig { sig_ext = noExtField+                      , sig_bndrs = bndrs, sig_body = go_ty ty })++    go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))+       = L loc (HsForAllTy { hst_xforall = noExtField+                           , hst_tele = tele, hst_body = go_ty ty })+    go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))+       = L loc (HsQualTy { hst_xqual = noExtField+                         , hst_ctxt = add_ctxt ctxt, hst_body = ty })+    go_ty (L loc ty)+       = L loc (HsQualTy { hst_xqual = noExtField+                         , hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty })++    extra_pred = nlHsTyConApp NotPromoted Prefix cls (lHsQTyVarsToTypes tvs0)++    add_ctxt (L loc preds) = L loc (extra_pred : preds)++addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine++lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]+lHsQTyVarsToTypes tvs+  = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv)))+    | tv <- hsQTvExplicit tvs ]+++--------------------------------------------------------------------------------+-- * Making abstract declarations+--------------------------------------------------------------------------------++restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn+restrictTo names (L loc decl) = L loc $ case decl of+  TyClD x d | isDataDecl d  ->+    TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })+  TyClD x d | isClassDecl d ->+    TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d),+               tcdATs = restrictATs names (tcdATs d) })+  _ -> decl++restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn+restrictDataDefn names d = d { dd_cons = restrictDataDefnCons names (dd_cons d) }++restrictDataDefnCons :: [Name] -> DataDefnCons (LConDecl GhcRn) -> DataDefnCons (LConDecl GhcRn)+restrictDataDefnCons names = \ case+    DataTypeCons is_type_data cons -> DataTypeCons is_type_data (restrictCons names cons)+    NewTypeCon con -> maybe (DataTypeCons False []) NewTypeCon $ restrictCons names (Just con)++restrictCons :: MonadFail m => [Name] -> m (LConDecl GhcRn) -> m (LConDecl GhcRn)+restrictCons names decls = [ L p d | L p (Just d) <- fmap keep <$> decls ]+  where+    keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)+    keep d+      | any (`elem` names) (unLoc <$> getConNames d) =+        case d of+          ConDeclH98 { con_args = con_args' } -> case con_args' of+            PrefixCon {} -> Just d+            RecCon fields+              | all field_avail (unLoc fields) -> Just d+              | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc fields) })+              -- if we have *all* the field names available, then+              -- keep the record declaration.  Otherwise degrade to+              -- a constructor declaration.  This isn't quite right, but+              -- it's the best we can do.+            InfixCon _ _ -> Just d++          ConDeclGADT { con_g_args = con_args' } -> case con_args' of+            PrefixConGADT {} -> Just d+            RecConGADT fields _+              | all field_avail (unLoc fields) -> Just d+              | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })+              -- see above+      where+        field_avail :: LConDeclField GhcRn -> Bool+        field_avail (L _ (ConDeclField _ fs _ _))+            = all (\f -> foExt (unLoc f) `elem` names) fs++        field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ]++    keep _ = Nothing++restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn]+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))+++restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]+restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ]++ -------------------------------------------------------------------------------+-- * Parenthesization+-------------------------------------------------------------------------------++-- | Precedence level (inside the 'HsType' AST).+data Precedence+  = PREC_TOP  -- ^ precedence of 'type' production in GHC's parser++  | PREC_SIG  -- ^ explicit type signature++  | PREC_CTX  -- ^ Used for single contexts, eg. ctx => type+              -- (as opposed to (ctx1, ctx2) => type)++  | PREC_FUN  -- ^ precedence of 'btype' production in GHC's parser+              -- (used for LH arg of (->))++  | PREC_OP   -- ^ arg of any infix operator+              -- (we don't keep have fixity info)++  | PREC_CON  -- ^ arg of type application: always parenthesize unless atomic+  deriving (Eq, Ord)++-- | Add in extra 'HsParTy' where needed to ensure that what would be printed+-- out using 'ppr' has enough parentheses to be re-parsed properly.+--+-- We cannot add parens that may be required by fixities because we do not have+-- any fixity information to work with in the first place :(.+reparenTypePrec :: forall a. (XRecCond a)+                => Precedence -> HsType a -> HsType a+reparenTypePrec = go+  where++  -- Shorter name for 'reparenType'+  go :: Precedence -> HsType a -> HsType a+  go _ (HsBangTy x b ty)     = HsBangTy x b (reparenLType ty)+  go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)+  go _ (HsSumTy x tys)       = HsSumTy x (map reparenLType tys)+  go _ (HsListTy x ty)       = HsListTy x (reparenLType ty)+  go _ (HsRecTy x flds)      = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)+  go p (HsDocTy x ty d)      = HsDocTy x (goL p ty) d+  go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)+  go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)+  go p (HsKindSig x ty kind)+    = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind)+  go p (HsIParamTy x n ty)+    = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty)+  go p (HsForAllTy x tele ty)+    = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty)+  go p (HsQualTy x ctxt ty)+    = let p' [_] = PREC_CTX+          p' _   = PREC_TOP -- parens will get added anyways later...+          ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt+      in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)+  go p (HsFunTy x w ty1 ty2)+    = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)+  go p (HsAppTy x fun_ty arg_ty)+    = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)+  go p (HsAppKindTy x fun_ty arg_ki)+    = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)+  go p (HsOpTy x prom ty1 op ty2)+    = paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2)+  go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed+  go _ t@HsTyVar{} = t+  go _ t@HsStarTy{} = t+  go _ t@HsSpliceTy{} = t+  go _ t@HsTyLit{} = t+  go _ t@HsWildCardTy{} = t+  go _ t@XHsType{} = t++  -- Located variant of 'go'+  goL :: Precedence -> LHsType a -> LHsType a+  goL ctxt_prec = mapXRec @a (go ctxt_prec)++  -- Optionally wrap a type in parens+  paren :: Precedence            -- Precedence of context+        -> Precedence            -- Precedence of top-level operator+        -> HsType a -> HsType a  -- Wrap in parens if (ctxt >= op)+  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a+                          | otherwise            = id+++-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')+reparenType :: XRecCond a => HsType a -> HsType a+reparenType = reparenTypePrec PREC_TOP++-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')+reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a+reparenLType = mapXRec @a reparenType++-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')+reparenSigType :: forall a. ( XRecCond a )+               => HsSigType a -> HsSigType a+reparenSigType (HsSig x bndrs body) =+  HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)+reparenSigType v@XHsSigType{} = v++-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')+reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )+                       => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =+  HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v++-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')+reparenHsForAllTelescope :: forall a. (XRecCond a )+                         => HsForAllTelescope a -> HsForAllTelescope a+reparenHsForAllTelescope (HsForAllVis x bndrs) =+  HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)+reparenHsForAllTelescope (HsForAllInvis x bndrs) =+  HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)+reparenHsForAllTelescope v@XHsForAllTelescope{} = v++-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')+reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a+reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n+reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)+reparenTyVar v@XTyVarBndr{} = v++-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')+reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a+reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d+reparenConDeclField c@XConDeclField{} = c+++------------------------------------------------------------------------------- -- * Located -------------------------------------------------------------------------------  -unL :: Located a -> a+unL :: GenLocated l a -> a unL (L _ x) = x --reL :: a -> Located a+reL :: a -> GenLocated l a reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)+mapMA f (L al a) = L (locA al) <$> f a+ ------------------------------------------------------------------------------- -- * NamedThing instances -------------------------------------------------------------------------------  -instance NamedThing (TyClDecl Name) where+instance NamedThing (TyClDecl GhcRn) where   getName = tcdName  -------------------------------------------------------------------------------@@ -163,20 +463,19 @@   children :: a -> [Name]  -instance Parent (ConDecl Name) where+instance Parent (ConDecl GhcRn) where   children con =-    case getConDetails con of-      RecCon fields -> map (selectorFieldOcc . unL) $-                         concatMap (cd_fld_names . unL) (unL fields)-      _             -> []+    case getRecConArgs_maybe con of+      Nothing -> []+      Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) -instance Parent (TyClDecl Name) where+instance Parent (TyClDecl GhcRn) where   children d-    | isDataDecl  d = map unL $ concatMap (getConNames . unL)-                              $ (dd_cons . tcdDataDefn) $ d+    | isDataDecl  d = map unLoc $ concatMap (toList . getConNames . unLoc)+                                $ (dd_cons . tcdDataDefn) d     | isClassDecl d =-        map (unL . fdLName . unL) (tcdATs d) ++-        [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]+        map (unLoc . fdLName . unLoc) (tcdATs d) +++        [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]     | otherwise = []  @@ -185,26 +484,26 @@ family = getName &&& children  -familyConDecl :: ConDecl Name -> [(Name, [Name])]-familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)+familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]+familyConDecl d = zip (toList $ unLoc <$> getConNames d) (repeat $ children d)  -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively.-families :: TyClDecl Name -> [(Name, [Name])]+families :: TyClDecl GhcRn -> [(Name, [Name])] families d-  | isDataDecl  d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))+  | isDataDecl  d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d))   | isClassDecl d = [family d]   | otherwise     = []   -- | A mapping from child to parent-parentMap :: TyClDecl Name -> [(Name, Name)]+parentMap :: TyClDecl GhcRn -> [(Name, Name)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]   -- | The parents of a subordinate in a declaration-parents :: Name -> HsDecl Name -> [Name]-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]+parents :: Name -> HsDecl GhcRn -> [Name]+parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = []  @@ -220,28 +519,259 @@   return ()  --- | A variant of 'gbracket' where the return value from the first computation--- is not required.-gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c-gbracket_ before_ after thing = gbracket before_ (const after) (const thing)+-------------------------------------------------------------------------------+-- * DynFlags+------------------------------------------------------------------------------- --- Extract the minimal complete definition of a Name, if one exists-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)-minimalDef n = do-  mty <- lookupGlobalName n-  case mty of-    Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c-    _ -> return Nothing+-- TODO: use `setOutputDir` from GHC+setOutputDir :: FilePath -> DynFlags -> DynFlags+setOutputDir dir dynFlags =+  dynFlags { objectDir    = Just dir+           , hiDir        = Just dir+           , hieDir       = Just dir+           , stubDir      = Just dir+           , includePaths = addGlobalInclude (includePaths dynFlags) [dir]+           , dumpDir      = Just dir+           }  ---------------------------------------------------------------------------------- * DynFlags+-- * 'StringBuffer' and 'ByteString' -------------------------------------------------------------------------------+-- We get away with a bunch of these functions because 'StringBuffer' and+-- 'ByteString' have almost exactly the same structure. +-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really+-- relies on the internals of both 'ByteString' and 'StringBuffer'.+--+-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood)+stringBufferFromByteString :: ByteString -> StringBuffer+stringBufferFromByteString bs =+  let BS.PS fp off len = bs <> BS.pack [0,0,0]+  in S.StringBuffer { S.buf = fp, S.len = len - 3, S.cur = off } -setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags-setObjectDir  f d = d{ objectDir  = Just f}-setHiDir      f d = d{ hiDir      = Just f}-setStubDir    f d = d{ stubDir    = Just f, includePaths = f : includePaths d }-  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file-  -- \#included from the .hc file when compiling with -fvia-C.-setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f+-- | Take the first @n@ /bytes/ of the 'StringBuffer' and put them in a+-- 'ByteString'.+--+-- /O(1)/+takeStringBuffer :: Int -> StringBuffer -> ByteString+takeStringBuffer !n (S.StringBuffer fp _ cur) = BS.PS fp cur n++-- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second+-- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use+-- separate buffers.**+--+-- /O(1)/+splitStringBuffer :: StringBuffer -> StringBuffer -> ByteString+splitStringBuffer buf1 buf2 = takeStringBuffer n buf1+  where n = S.byteDiff buf1 buf2++-- | Split the 'StringBuffer' at the next newline (or the end of the buffer).+-- Also: initial position is passed in and the updated position is returned.+--+-- /O(n)/ (but /O(1)/ space)+spanLine :: RealSrcLoc -> StringBuffer -> (ByteString, RealSrcLoc, StringBuffer)+spanLine !loc !buf = go loc buf+  where++  go !l !b+    | not (S.atEnd b)+    = case S.nextChar b of+        ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b')+        (c,    b') -> go (advanceSrcLoc l c) b'+    | otherwise+    = (splitStringBuffer buf b, advanceSrcLoc l '\n', b)++-- | Given a start position and a buffer with that start position, split the+-- buffer at an end position.+--+-- /O(n)/ (but /O(1)/ space)+spanPosition :: RealSrcLoc   -- ^ start of buffeer+             -> RealSrcLoc   -- ^ position until which to take+             -> StringBuffer -- ^ buffer from which to take+             -> (ByteString, StringBuffer)+spanPosition !start !end !buf = go start buf+  where++  go !l !b+    | l < end+    , not (S.atEnd b)+    , (c, b') <- S.nextChar b+    = go (advanceSrcLoc l c) b'+    | otherwise+    = (splitStringBuffer buf b, b)++-- | Try to parse a line of CPP from the from of the buffer. A \"line\" of CPP+-- consists of+--+--   * at most 10 whitespace characters, including at least one newline+--   * a @#@ character+--   * keep parsing lines until you find a line not ending in @\\@.+--+-- This is chock full of heuristics about what a line of CPP is.+--+-- /O(n)/ (but /O(1)/ space)+tryCppLine :: RealSrcLoc -> StringBuffer -> Maybe (ByteString, RealSrcLoc, StringBuffer)+tryCppLine !loc !buf = spanSpace (S.prevChar buf '\n' == '\n') loc buf+  where++  -- Keep consuming space characters until we hit either a @#@ or something+  -- else. If we hit a @#@, start parsing CPP+  spanSpace !seenNl !l !b+    | S.atEnd b+    = Nothing+    | otherwise+    = case S.nextChar b of+        ('#' , b') | not (S.atEnd b')+                   , ('-', b'') <- S.nextChar b'+                   , ('}', _) <- S.nextChar b''+                   -> Nothing -- Edge case exception for @#-}@+                   | seenNl+                   -> Just (spanCppLine (advanceSrcLoc l '#') b') -- parse CPP+                   | otherwise+                   -> Nothing -- We didn't see a newline, so this can't be CPP!++        (c   , b') | isSpace c -> spanSpace (seenNl || c == '\n')+                                            (advanceSrcLoc l c) b'+                   | otherwise -> Nothing++  -- Consume a CPP line to its "end" (basically the first line that ends not+  -- with a @\@ character)+  spanCppLine !l !b+    | S.atEnd b+    = (splitStringBuffer buf b, l, b)+    | otherwise+    = case S.nextChar b of+        ('\\', b') | not (S.atEnd b')+                   , ('\n', b'') <- S.nextChar b'+                   -> spanCppLine (advanceSrcLoc (advanceSrcLoc l '\\') '\n') b''++        ('\n', b') -> (splitStringBuffer buf b', advanceSrcLoc l '\n', b')++        (c   , b') -> spanCppLine (advanceSrcLoc l c) b'++-------------------------------------------------------------------------------+-- * Names in a 'Type'+-------------------------------------------------------------------------------++-- | Given a 'Type', return a set of 'Name's coming from the 'TyCon's within+-- the type.+typeNames :: Type -> Set.Set Name+typeNames ty = go ty Set.empty+  where+    go :: Type -> Set.Set Name -> Set.Set Name+    go t acc =+      case t of+        TyVarTy {} -> acc+        AppTy t1 t2 ->  go t2 $ go t1 acc+        FunTy _ _ t1 t2 -> go t2 $ go t1 acc+        TyConApp tcon args -> foldl' (\s t' -> go t' s) (Set.insert (getName tcon) acc) args+        ForAllTy bndr t' -> go t' $ go (tyVarKind (binderVar bndr)) acc+        LitTy _ -> acc+        CastTy t' _ -> go t' acc+        CoercionTy {} -> acc++-------------------------------------------------------------------------------+-- * Free variables of a 'Type'+-------------------------------------------------------------------------------++-- | Get free type variables in a 'Type' in their order of appearance.+-- See [Ordering of implicit variables].+orderedFVs+  :: VarSet  -- ^ free variables to ignore+  -> [Type]  -- ^ types to traverse (in order) looking for free variables+  -> [TyVar] -- ^ free type variables, in the order they appear in+orderedFVs vs tys =+  reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet)+++-- See the "Free variables of types and coercions" section in 'TyCoRep', or+-- check out Note [Free variables of types]. The functions in this section+-- don't output type variables in the order they first appear in in the 'Type'.+--+-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type+-- of 'const :: a -> b -> a':+--+-- >>> import GHC.Types.Name+-- >>> import TyCoRep+-- >>> import GHC.Builtin.Types.Prim+-- >>> import GHC.Types.Var+-- >>> a = TyVarTy alphaTyVar+-- >>> b = TyVarTy betaTyVar+-- >>> constTy = mkFunTys [a, b] a+-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy)+-- ["b","a"]+--+-- However, we want to reuse the very optimized traversal machinery there, so+-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`.+-- All these do differently is traverse in a different order and ignore+-- coercion variables.++-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order+-- of  appearance.+tyCoFVsOfType' :: Type -> FV+tyCoFVsOfType' (TyVarTy v)        a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c+tyCoFVsOfType' (TyConApp _ tys)   a b c = tyCoFVsOfTypes' tys a b c+tyCoFVsOfType' (LitTy {})         a b c = emptyFV a b c+tyCoFVsOfType' (AppTy fun arg)    a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c+tyCoFVsOfType' (FunTy _ w arg res)  a b c = (tyCoFVsOfType' w `unionFV`+                                           tyCoFVsOfType' res `unionFV`+                                           tyCoFVsOfType' arg) a b c+tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty)  a b c+tyCoFVsOfType' (CastTy ty _)      a b c = (tyCoFVsOfType' ty) a b c+tyCoFVsOfType' (CoercionTy _ )    a b c = emptyFV a b c++-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order+-- of appearance.+tyCoFVsOfTypes' :: [Type] -> FV+tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc+tyCoFVsOfTypes' []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc++-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of+-- appearance.+tyCoFVsBndr' :: TyVarBinder -> FV -> FV+tyCoFVsBndr' (Bndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv)+++-------------------------------------------------------------------------------+-- * Defaulting RuntimeRep variables+-------------------------------------------------------------------------------++-- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to+-- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such+-- function working over `IfaceType`'s.+defaultRuntimeRepVars :: Type -> Type+defaultRuntimeRepVars = go emptyVarEnv+  where+    go :: TyVarEnv () -> Type -> Type+    go subs (ForAllTy (Bndr var flg) ty)+      | isRuntimeRepVar var+      , isInvisibleForAllTyFlag flg+      = let subs' = extendVarEnv subs var ()+        in go subs' ty+      | otherwise+      = ForAllTy (Bndr (updateTyVarKind (go subs) var) flg)+                 (go subs ty)++    go subs (TyVarTy tv)+      | tv `elemVarEnv` subs+      = liftedRepTy+      | otherwise+      = TyVarTy (updateTyVarKind (go subs) tv)++    go subs (TyConApp tc tc_args)+      = TyConApp tc (map (go subs) tc_args)++    go subs (FunTy af w arg res)+      = FunTy af (go subs w) (go subs arg) (go subs res)++    go subs (AppTy t u)+      = AppTy (go subs t) (go subs u)++    go subs (CastTy x co)+      = CastTy (go subs x) co++    go _ ty@(LitTy {}) = ty+    go _ ty@(CoercionTy {}) = ty++fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
src/Haddock/Interface.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE TupleSections     #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface@@ -28,35 +33,48 @@ -- using this environment. ----------------------------------------------------------------------------- module Haddock.Interface (-  processModules+    plugin+  , processModules ) where  -import Haddock.GhcUtils-import Haddock.InterfaceFile-import Haddock.Interface.Create-import Haddock.Interface.AttachInstances-import Haddock.Interface.Rename+import Haddock.GhcUtils (moduleString, pretty)+import Haddock.Interface.AttachInstances (attachInstances)+import Haddock.Interface.Create (createInterface1)+import Haddock.Interface.Rename (renameInterface)+import Haddock.InterfaceFile (InterfaceFile, ifInstalledIfaces, ifLinkEnv) import Haddock.Options hiding (verbosity) import Haddock.Types-import Haddock.Utils+import Haddock.Utils (Verbosity (..), normal, out, verbose) -import Control.Monad-import Data.List-import qualified Data.Map as Map+import Control.Monad (unless, when)+import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef)+import Data.List (foldl', isPrefixOf)+import Data.Maybe (mapMaybe)+import Data.Traversable (for)+import Text.Printf (printf)+import qualified Data.Map.Strict as Map import qualified Data.Set as Set-import Distribution.Verbosity-import System.Directory-import System.FilePath-import Text.Printf -import Digraph-import DynFlags hiding (verbosity)-import Exception import GHC hiding (verbosity)-import HscTypes-import FastString (unpackFS)+import GHC.Data.Graph.Directed+import GHC.Driver.Env+import GHC.Driver.Monad (modifySession, withTimingM)+import GHC.Driver.Session hiding (verbosity)+import GHC.HsToCore.Docs (getMainDeclBinder)+import GHC.Plugins+import GHC.Tc.Types (TcGblEnv (..), TcM)+import GHC.Tc.Utils.Env (tcLookupGlobal)+import GHC.Tc.Utils.Monad (getTopEnv)+import GHC.Unit.Module.Graph+import GHC.Utils.Error (withTiming) +#if defined(mingw32_HOST_OS)+import System.IO+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))+#endif+ -- | Create 'Interface's and a link environment by typechecking the list of -- modules using the GHC API and processing the resulting syntax trees. processModules@@ -68,144 +86,324 @@   -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming                                 -- environment processModules verbosity modules flags extIfaces = do+#if defined(mingw32_HOST_OS)+  -- Avoid internal error: <stderr>: hPutChar: invalid argument (invalid character)' non UTF-8 Windows+  liftIO $ hSetEncoding stdout $ mkLocaleEncoding TransliterateCodingFailure+  liftIO $ hSetEncoding stderr $ mkLocaleEncoding TransliterateCodingFailure+#endif +  dflags <- getDynFlags+   out verbosity verbose "Creating interfaces..."-  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces-                                   , iface <- ifInstalledIfaces ext ]-  interfaces <- createIfaces0 verbosity modules flags instIfaceMap ++  -- Map from a module to a corresponding installed interface+  let instIfaceMap :: InstIfaceMap+      instIfaceMap = Map.fromList+        [ (instMod iface, iface)+        | ext <- extIfaces+        , iface <- ifInstalledIfaces ext+        ]++  (interfaces, ms) <- createIfaces verbosity modules flags instIfaceMap+   let exportedNames =         Set.unions $ map (Set.fromList . ifaceExports) $         filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces       mods = Set.fromList $ map ifaceMod interfaces+   out verbosity verbose "Attaching instances..."-  interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap+  interfaces' <- {-# SCC attachInstances #-}+                 withTimingM "attachInstances" (const ()) $ do+                   attachInstances (exportedNames, mods) interfaces instIfaceMap ms    out verbosity verbose "Building cross-linking environment..."   -- Combine the link envs of the external packages into one   let extLinks  = Map.unions (map ifLinkEnv extIfaces)-      homeLinks = buildHomeLinks interfaces -- Build the environment for the home-                                            -- package+      homeLinks = buildHomeLinks interfaces' -- Build the environment for the home+                                             -- package       links     = homeLinks `Map.union` extLinks    out verbosity verbose "Renaming interfaces..."+   let warnings = Flag_NoWarnings `notElem` flags-  dflags <- getDynFlags-  let (interfaces'', msgs) =-         runWriter $ mapM (renameInterface dflags links warnings) interfaces'-  liftIO $ mapM_ putStrLn msgs+      ignoredSymbolSet = ignoredSymbols flags -  return (interfaces'', homeLinks)+  interfaces'' <-+    withTimingM "renameAllInterfaces" (const ()) $+      for interfaces' $ \i -> do+        withTimingM ("renameInterface: " <+> pprModuleName (moduleName (ifaceMod i))) (const ()) $+          renameInterface dflags ignoredSymbolSet links warnings (Flag_Hoogle `elem` flags) i +  return (interfaces'', homeLinks)  -------------------------------------------------------------------------------- -- * Module typechecking and Interface creation -------------------------------------------------------------------------------- +createIfaces+    :: Verbosity+    -- ^ Verbosity requested by the caller+    -> [String]+    -- ^ List of modules provided as arguments to Haddock (still in FilePath+    -- format)+    -> [Flag]+    -- ^ Command line flags which Hadddock was invoked with+    -> InstIfaceMap+    -- ^ Map from module to corresponding installed interface file+    -> Ghc ([Interface], ModuleSet)+    -- ^ Resulting interfaces+createIfaces verbosity modules flags instIfaceMap = do+  -- Initialize the IORefs for the interface map and the module set+  (ifaceMapRef, moduleSetRef) <- liftIO $ do+    m <- newIORef Map.empty+    s <- newIORef emptyModuleSet+    return (m, s) -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]-createIfaces0 verbosity modules flags instIfaceMap =-  -- Output dir needs to be set before calling depanal since depanal uses it to-  -- compute output file names that are stored in the DynFlags of the-  -- resulting ModSummaries.-  (if useTempDir then withTempOutputDir else id) $ do-    modGraph <- depAnalysis-    if needsTemplateHaskell modGraph then do-      modGraph' <- enableCompilation modGraph-      createIfaces verbosity flags instIfaceMap modGraph'-    else-      createIfaces verbosity flags instIfaceMap modGraph+  let+    haddockPlugin = plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef -  where-    useTempDir :: Bool-    useTempDir = Flag_NoTmpCompDir `notElem` flags+    installHaddockPlugin :: HscEnv -> HscEnv+    installHaddockPlugin hsc_env =+      let+        old_plugins = hsc_plugins hsc_env+        new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }+        hsc_env'    = hsc_env { hsc_plugins = new_plugins }+      in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env' +  -- Note that we would rather use withTempSession but as long as we+  -- have the separate attachInstances step we need to keep the session+  -- alive to be able to find all the instances.+  modifySession installHaddockPlugin -    withTempOutputDir :: Ghc a -> Ghc a-    withTempOutputDir action = do-      tmp <- liftIO getTemporaryDirectory-      x   <- liftIO getProcessID-      let dir = tmp </> ".haddock-" ++ show x-      modifySessionDynFlags (setOutputDir dir)-      withTempDir dir action+  targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules+  setTargets targets +  loadOk <- withTimingM "load" (const ()) $+    {-# SCC load #-} GHC.load LoadAllTargets -    depAnalysis :: Ghc ModuleGraph-    depAnalysis = do-      targets <- mapM (\f -> guessTarget f Nothing) modules-      setTargets targets-      depanal [] False+  case loadOk of+    Failed ->+      throwE "Cannot typecheck modules"+    Succeeded -> do+      modGraph <- GHC.getModuleGraph +      (ifaceMap, moduleSet) <- liftIO $ do+        m <- atomicModifyIORef' ifaceMapRef (Map.empty,)+        s <- atomicModifyIORef' moduleSetRef (Set.empty,)+        return (m, s) -    enableCompilation :: ModuleGraph -> Ghc ModuleGraph-    enableCompilation modGraph = do-      let enableComp d = let platform = targetPlatform d-                         in d { hscTarget = defaultObjectTarget platform }-      modifySessionDynFlags enableComp-      -- We need to update the DynFlags of the ModSummaries as well.-      let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }-      let modGraph' = map upd modGraph-      return modGraph'+      let+        -- We topologically sort the module graph including boot files,+        -- so it should be acylic (hopefully we failed much earlier if this is not the case)+        -- We then filter out boot modules from the resultant topological sort+        --+        -- We do it this way to make 'buildHomeLinks' a bit more stable+        -- 'buildHomeLinks' depends on the topological order of its input in order+        -- to construct its result. In particular, modules closer to the bottom of+        -- the dependency chain are to be prefered for link destinations.+        --+        -- If there are cycles in the graph, then this order is indeterminate+        -- (the nodes in the cycle can be ordered in any way).+        -- While 'topSortModuleGraph' does guarantee stability for equivalent+        -- module graphs, seemingly small changes in the ModuleGraph can have+        -- big impacts on the `LinkEnv` constructed.+        --+        -- For example, suppose+        --  G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).+        --+        -- Then suppose C.hs is changed to have a cyclic dependency on A+        --+        --  G2 = A.hs -> B.hs -> C.hs -> A.hs-boot+        --+        -- For G1, `C.hs` is preferred for link destinations. However, for G2,+        -- the topologically sorted order not taking into account boot files (so+        -- C -> A) is completely indeterminate.+        -- Using boot files to resolve cycles, we end up with the original order+        -- [C, B, A] (in decreasing order of preference for links)+        --+        -- This exact case came up in testing for the 'base' package, where there+        -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't+        -- include 'Prelude' on non-windows platforms. This lead to drastically different+        -- LinkEnv's (and failing haddockHtmlTests) across the platforms+        --+        -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)+        -- means that {-# SOURCE #-} imports no longer count towards re-ordering+        -- the preference of modules for linking.+        --+        -- i.e. if module A imports B, then B is preferred over A,+        -- but if module A {-# SOURCE #-} imports B, then we can't say the same.+        --+        go :: SCC ModuleGraphNode -> Maybe Module+        go (AcyclicSCC (ModuleNode _ ms))+          | NotBoot <- isBootSummary ms = Just $ ms_mod ms+          | otherwise = Nothing+        go (AcyclicSCC _) = Nothing+        go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files" +        ifaces :: [Interface]+        ifaces =+          [ Map.findWithDefault+              (error "haddock:iface")+              m+              ifaceMap+          | m <- mapMaybe go $ topSortModuleGraph False modGraph Nothing+          ] -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]-createIfaces verbosity flags instIfaceMap mods = do-  let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing-  out verbosity normal "Haddock coverage:"-  (ifaces, _) <- foldM f ([], Map.empty) sortedMods-  return (reverse ifaces)-  where-    f (ifaces, ifaceMap) modSummary = do-      x <- processModule verbosity modSummary flags ifaceMap instIfaceMap-      return $ case x of-        Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)-        Nothing    -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.+      return (ifaces, moduleSet)  -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)-processModule verbosity modsum flags modMap instIfaceMap = do-  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."-  tm <- loadModule =<< typecheckModule =<< parseModule modsum-  if not $ isBootSummary modsum then do-    out verbosity verbose "Creating interface..."-    (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap-    liftIO $ mapM_ putStrLn msg-    dflags <- getDynFlags-    let (haddockable, haddocked) = ifaceHaddockCoverage interface-        percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int-        modString = moduleString (ifaceMod interface)-        coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString-        header = case ifaceDoc interface of-          Documentation Nothing _ -> False-          _ -> True-        undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n-                                                            , expItemMbDoc = (Documentation Nothing _, _)-                                                            } <- ifaceExportItems interface ]-          where-            formatName :: SrcSpan -> HsDecl Name -> String-            formatName loc n = p (getMainDeclBinder n) ++ case loc of-              RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"-              _ -> ""+-- | A `Plugin` that hooks into GHC's compilation pipeline to generate Haddock+-- interfaces. Due to the plugin nature we benefit from GHC's capabilities to+-- parallelize the compilation process.+plugin+  :: Verbosity+  -- ^ Verbosity requested by the Haddock caller+  -> [Flag]+  -- ^ Command line flags which Hadddock was invoked with+  -> InstIfaceMap+  -- ^ Map from module to corresponding installed interface file+  -> IORef IfaceMap+  -- ^ The 'IORef' to write the interface map to+  -> IORef ModuleSet+  -- ^ The 'IORef' to write the module set to+  -> StaticPlugin -- the plugin to install with GHC+plugin verbosity flags instIfaceMap ifaceMapRef moduleSetRef =+  let+    processTypeCheckedResult :: ModSummary -> TcGblEnv -> TcM ()+    processTypeCheckedResult mod_summary tc_gbl_env+      -- Don't do anything for hs-boot modules+      | IsBoot <- isBootSummary mod_summary =+          pure ()+      | otherwise = do+          hsc_env <- getTopEnv+          ifaces <- liftIO $ readIORef ifaceMapRef -            p [] = ""-            p (x:_) = let n = pretty dflags x-                          ms = modString ++ "."-                      in if ms `isPrefixOf` n-                         then drop (length ms) n-                         else n+          (iface, modules) <-+            withTiming (hsc_logger hsc_env) "processModule1" (const ()) $+              processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env +          liftIO $ do+            atomicModifyIORef' ifaceMapRef $ \xs ->+              (Map.insert (ms_mod mod_summary) iface xs, ())++            atomicModifyIORef' moduleSetRef $ \xs ->+              (modules `unionModuleSet` xs, ())+  in+    StaticPlugin+      {+        spPlugin = PluginWithArgs+        {+          paPlugin = defaultPlugin+          {+            renamedResultAction = keepRenamedSource+          , typeCheckResultAction = \_ mod_summary tc_gbl_env -> do+              processTypeCheckedResult mod_summary tc_gbl_env+              pure tc_gbl_env+          }+        , paArguments = []+        }+      }++processModule1+  :: Verbosity+  -- ^ Verbosity requested by the Haddock caller+  -> [Flag]+  -- ^ Command line flags which Hadddock was invoked with+  -> IfaceMap+  -- ^ Map from module to corresponding interface, for the modules we have+  -- already processed+  -> InstIfaceMap+  -- ^ Map from module to corresponding installed interface file+  -> HscEnv+  -> ModSummary+  -> TcGblEnv+  -> TcM (Interface, ModuleSet)+processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do+  out verbosity verbose "Creating interface..."++  let+    TcGblEnv { tcg_rdr_env } = tc_gbl_env++    unit_state = hsc_units hsc_env++  !interface <- do+    logger <- getLogger+    {-# SCC createInterface #-}+      withTiming logger "createInterface" (const ()) $+        runIfM (fmap Just . tcLookupGlobal) $+          createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces++  -- We need to keep track of which modules were somehow in scope so that when+  -- Haddock later looks for instances, it also looks in these modules too.+  --+  -- See https://github.com/haskell/haddock/issues/469.+  let+    mods :: ModuleSet+    !mods = mkModuleSet+      [ nameModule name+      | gre <- globalRdrEnvElts tcg_rdr_env+      , let name = greMangledName gre+      , nameIsFromExternalPackage (hsc_home_unit hsc_env) name+      , isTcOcc (nameOccName name)   -- Types and classes only+      , unQualOK gre -- In scope unqualified+      ]++  dflags <- getDynFlags++  let+    (haddockable, haddocked) =+      ifaceHaddockCoverage interface++    percentage :: Int+    percentage = div (haddocked * 100) haddockable++    modString :: String+    modString = moduleString (ifaceMod interface)++    coverageMsg :: String+    coverageMsg =+      printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString++    header :: Bool+    header = case ifaceDoc interface of+      Documentation Nothing _ -> False+      _ -> True++    undocumentedExports :: [String]+    undocumentedExports =+      [ formatName (locA s) n+      | ExportDecl ExportD+          { expDDecl = L s n+          , expDMbDoc = (Documentation Nothing _, _)+          } <- ifaceExportItems interface+      ]+        where+          formatName :: SrcSpan -> HsDecl GhcRn -> String+          formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of+            RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" +++              show (srcSpanStartLine rss) ++ ")"+            _ -> ""++          p :: Outputable a => [a] -> String+          p [] = ""+          p (x:_) = let n = pretty dflags x+                        ms = modString ++ "."+                    in if ms `isPrefixOf` n+                       then drop (length ms) n+                       else n++  when (OptHide `notElem` ifaceOptions interface) $ do     out verbosity normal coverageMsg     when (Flag_NoPrintMissingDocs `notElem` flags           && not (null undocumentedExports && header)) $ do       out verbosity normal "  Missing documentation for:"       unless header $ out verbosity normal "    Module header"       mapM_ (out verbosity normal . ("    " ++)) undocumentedExports-    interface' <- liftIO $ evaluate interface-    return (Just interface')-  else-    return Nothing +  pure (interface, mods) + -------------------------------------------------------------------------------- -- * Building of cross-linking environment --------------------------------------------------------------------------------@@ -220,25 +418,17 @@ -- The interfaces are passed in in topologically sorted order, but we start -- by reversing the list so we can do a foldl. buildHomeLinks :: [Interface] -> LinkEnv-buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)+buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces)   where     upd old_env iface-      | OptHide    `elem` ifaceOptions iface = old_env+      | OptHide `elem` ifaceOptions iface =+          old_env       | OptNotHome `elem` ifaceOptions iface =-        foldl' keep_old old_env exported_names-      | otherwise = foldl' keep_new old_env exported_names+          foldl' keep_old old_env exported_names+      | otherwise =+          foldl' keep_new old_env exported_names       where-        exported_names = ifaceVisibleExports iface ++ map getName (ifaceInstances iface)+        exported_names = ifaceVisibleExports iface ++ map haddockClsInstName (ifaceInstances iface)         mdl            = ifaceMod iface         keep_old env n = Map.insertWith (\_ old -> old) n mdl env         keep_new env n = Map.insert n mdl env-------------------------------------------------------------------------------------- * Utils------------------------------------------------------------------------------------withTempDir :: (ExceptionMonad m) => FilePath -> m a -> m a-withTempDir dir = gbracket_ (liftIO $ createDirectory dir)-                            (liftIO $ removeDirectoryRecursive dir)
src/Haddock/Interface/AttachInstances.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface.AttachInstances@@ -11,113 +14,168 @@ -- Stability   :  experimental -- Portability :  portable ------------------------------------------------------------------------------module Haddock.Interface.AttachInstances (attachInstances) where+module Haddock.Interface.AttachInstances (attachInstances, instHead) where  -import Haddock.Types import Haddock.Convert-import Haddock.GhcUtils+import Haddock.GhcUtils (typeNames)+import Haddock.Types +import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>))-import Data.List+import Control.DeepSeq (force)+import Data.Foldable (foldl')+import Data.List (sortBy) import Data.Ord (comparing)-import Data.Function (on)-import Data.Maybe ( maybeToList, mapMaybe )-import qualified Data.Map as Map+import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )+import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Class-import DynFlags-import CoreSyn (isOrphan)-import ErrUtils-import FamInstEnv-import FastString+import GHC.Data.FastString (unpackFS)+import GHC.Core.Class+import GHC.Core.FamInstEnv import GHC-import GhcMonad (withSession)-import InstEnv-import MonadUtils (liftIO)-import Name-import Outputable (text, sep, (<+>))-import PrelNames-import SrcLoc-import TcRnDriver (tcRnGetInfo)-import TyCon-import TyCoRep-import TysPrim( funTyCon )-import Var hiding (varName)-#define FSLIT(x) (mkFastString# (x#))+import GHC.Core.InstEnv+import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Utils.Outputable (text, sep, (<+>))+import GHC.Types.SrcLoc+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Builtin.Types( unrestrictedFunTyConName )+import GHC.Types.Var hiding (varName)+import GHC.HsToCore.Docs  type ExportedNames = Set.Set Name type Modules = Set.Set Module type ExportInfo = (ExportedNames, Modules)  -- Also attaches fixities-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]-attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]+attachInstances expInfo ifaces instIfaceMap mods = do+  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'+  mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces   where+    mods' = Just (moduleSetElts mods)+     -- TODO: take an IfaceMap as input     ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] -    attach iface = do-      newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)+    attach index iface = do++      let getInstDoc = findInstDoc iface ifaceMap instIfaceMap+          getFixity = findFixity iface ifaceMap instIfaceMap++      newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity)                        (ifaceExportItems iface)-      let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface)+      let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface)       return $ iface { ifaceExportItems = newItems                      , ifaceOrphanInstances = orphanInstances                      } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]-attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =-  [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))-  | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]-  , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is-  , not $ isInstanceHidden expInfo cls tys+attachOrphanInstances+  :: ExportInfo+  -> (Name -> Maybe (MDoc Name))      -- ^ how to lookup the doc of an instance+  -> [HaddockClsInst]                 -- ^ a list of instances+  -> [DocInstance GhcRn]+attachOrphanInstances expInfo getInstDoc cls_instances =+  [ (synified, getInstDoc instName, (L (getSrcSpan instName) instName), Nothing)+  | let is =+          [ ( haddockClsInstHead i+            , haddockClsInstSynified i+            , haddockClsInstName i+            , haddockClsInstClsName i+            , haddockClsInstTyNames i+            )+          | i <- cls_instances, haddockClsInstIsOrphan i+          ]+  , (_, synified, instName, cls, tyNames) <- sortBy (comparing $ (\(ih,_,_,_,_) -> ih)) is+  , not $ isInstanceHidden expInfo cls tyNames   ]  -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap-                   -> ExportItem Name-                   -> Ghc (ExportItem Name)-attachToExportItem expInfo iface ifaceMap instIfaceMap export =+attachToExportItem+  :: NameEnv ([ClsInst], [FamInst])   -- ^ all instances (that we know of)+  -> ExportInfo+  -> (Name -> Maybe (MDoc Name))      -- ^ how to lookup the doc of an instance+  -> (Name -> Maybe Fixity)           -- ^ how to lookup a fixity+  -> ExportItem GhcRn+  -> Ghc (ExportItem GhcRn)+attachToExportItem index expInfo getInstDoc getFixity export =   case attachFixities export of-    e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do-      mb_info <- getAllInfo (tcdName d)-      insts <- case mb_info of-        Just (_, _, cls_instances, fam_instances) ->-          let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) )-                          | i <- sortBy (comparing instFam) fam_instances-                          , let n = getName i-                          , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap-                          , not $ isNameHidden expInfo (fi_fam i)-                          , not $ any (isTypeHidden expInfo) (fi_tys i)-                          , let opaque = isTypeHidden expInfo (fi_rhs i)-                          ]-              cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d)))-                          | let is = [ (instanceSig i, getName i) | i <- cls_instances ]-                          , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is-                          , not $ isInstanceHidden expInfo cls tys-                          ]+    ExportDecl e@(ExportD { expDDecl = L eSpan (TyClD _ d) }) -> do+      insts <-+        let mb_instances  = lookupNameEnv index (tcdName d)+            cls_instances = maybeToList mb_instances >>= fst+            fam_instances = maybeToList mb_instances >>= snd+            fam_insts = [ ( synFamInst+                          , getInstDoc n+                          , spanNameE n synFamInst (L (locA eSpan) (tcdName d))+                          , mb_mdl+                          )+                        | i <- sortBy (comparing instFam) fam_instances+                        , let n = getName i+                        , not $ isNameHidden expInfo (fi_fam i)+                        , not $ any (isTypeHidden expInfo) (fi_tys i)+                        , let opaque = isTypeHidden expInfo (fi_rhs i)+                        , let synFamInst = synifyFamInst i opaque+                        , let !mb_mdl = force $ nameModule_maybe n+                        ]+            cls_insts = [ ( synClsInst+                          , getInstDoc n+                          , spanName n synClsInst (L (locA eSpan) (tcdName d))+                          , mb_mdl+                          )+                        | let is = [ (instanceSig i, getName i) | i <- cls_instances ]+                        , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is+                        , not $ isInstanceHidden+                                  expInfo+                                  (getName cls)+                                  (foldl' (\acc t -> acc `Set.union` typeNames t) Set.empty tys)+                        , let synClsInst = synifyInstHead i+                        , let !mb_mdl = force $ nameModule_maybe n+                        ]               -- fam_insts but with failing type fams filtered out-              cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ]-              famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ]-          in do-            dfs <- getDynFlags-            let mkBug = (text "haddock-bug:" <+>) . text-            liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)-            return $ cls_insts ++ cleanFamInsts-        Nothing -> return []-      return $ e { expItemInstances = insts }+            cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]+            famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]+        in do+          let mkBug = (text "haddock-bug:" <+>) . text+          putMsgM (sep $ map mkBug famInstErrs)+          return $ cls_insts ++ cleanFamInsts+      return $ ExportDecl e { expDInstances = insts }     e -> return e   where-    attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =-      nubBy ((==) `on` fst) $ expItemFixities e ++-      [ (n',f) | n <- getMainDeclBinder d-              , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]-              , n' <- n : subs-              , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]-      ] }+    attachFixities+        ( ExportDecl+          ( e@ExportD+              { expDDecl = L _ d+              , expDPats = patsyns+              , expDSubDocs = subDocs+              }+          )+        )+      = ExportDecl e+          { expDFixities = fixities+          }+      where+        fixities :: [(Name, Fixity)]+        !fixities = force . Map.toList $ foldl' f Map.empty all_names +        f :: Map.Map Name Fixity -> Name -> Map.Map Name Fixity+        f !fs n = Map.alter (<|> getFixity n) n fs++        patsyn_names :: [Name]+        patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns++        all_names :: [Name]+        all_names =+             getMainDeclBinder emptyOccEnv d+          ++ map fst subDocs+          ++ patsyn_names+     attachFixities e = e+     -- spanName: attach the location to the name that is the same file as the instance location     spanName s (InstHead { ihdClsName = clsn }) (L instL instn) =         let s1 = getSrcSpan s@@ -131,60 +189,48 @@       let L l r = spanName s ok linst       in L l (Right r) --instLookup :: (InstalledInterface -> Map.Map Name a) -> Name-            -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a-instLookup f name iface ifaceMap instIfaceMap =-  case Map.lookup name (f $ toInstalledIface iface) of-    res@(Just _) -> res-    Nothing -> do-      let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap-      iface' <- Map.lookup (nameModule name) ifaceMaps-      Map.lookup name (f iface')+-- | Lookup the doc associated with a certain instance+findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name)+findInstDoc iface ifaceMap instIfaceMap = \name ->+  (Map.lookup name . ifaceDocMap $ iface) <|>+  (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|>+  (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap) --- | Like GHC's getInfo but doesn't cut things out depending on the--- interative context, which we don't set sufficiently anyway.-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))-getAllInfo name = withSession $ \hsc_env -> do-   (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name-   return r+-- | Lookup the fixity associated with a certain name+findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity+findFixity iface ifaceMap instIfaceMap = \name ->+  (Map.lookup name . ifaceFixMap $ iface) <|>+  (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|>+  (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap)   -------------------------------------------------------------------------------- -- Collecting and sorting instances -------------------------------------------------------------------------------- ---- | Simplified type for sorting types, ignoring qualification (not visible--- in Haddock output) and unifying special tycons with normal ones.--- For the benefit of the user (looks nice and predictable) and the--- tests (which prefer output to be deterministic).-data SimpleType = SimpleType Name [SimpleType]-                | SimpleTyLit TyLit-                  deriving (Eq,Ord)---instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], SName, [SimpleType]) instHead (_, _, cls, args)-  = (map argCount args, className cls, map simplify args)+  = (map argCount args, SName (className cls), map simplify args)  argCount :: Type -> Int-argCount (AppTy t _) = argCount t + 1+argCount (AppTy t _)     = argCount t + 1 argCount (TyConApp _ ts) = length ts-argCount (ForAllTy (Anon _) _ ) = 2-argCount (ForAllTy _ t) = argCount t-argCount (CastTy t _) = argCount t+argCount (FunTy _ _ _ _) = 2+argCount (ForAllTy _ t)  = argCount t+argCount (CastTy t _)    = argCount t argCount _ = 0  simplify :: Type -> SimpleType-simplify (ForAllTy (Anon t1) t2) = SimpleType funTyConName [simplify t1, simplify t2]+simplify (FunTy _ _ t1 t2)  = SimpleType (SName unrestrictedFunTyConName) [simplify t1, simplify t2] simplify (ForAllTy _ t) = simplify t simplify (AppTy t1 t2) = SimpleType s (ts ++ maybeToList (simplify_maybe t2))   where (SimpleType s ts) = simplify t1-simplify (TyVarTy v) = SimpleType (tyVarName v) []-simplify (TyConApp tc ts) = SimpleType (tyConName tc)+simplify (TyVarTy v) = SimpleType (SName (tyVarName v)) []+simplify (TyConApp tc ts) = SimpleType (SName (tyConName tc))                                        (mapMaybe simplify_maybe ts)-simplify (LitTy l) = SimpleTyLit l+simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n+simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s)+simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c simplify (CastTy ty _) = simplify ty simplify (CoercionTy _) = error "simplify:Coercion" @@ -193,18 +239,11 @@ simplify_maybe ty              = Just (simplify ty)  -- Used for sorting-instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)+instFam :: FamInst -> ([Int], SName, [SimpleType], Int, SimpleType) instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }-  = (map argCount ts, n, map simplify ts, argCount t, simplify t)+  = (map argCount ts, SName n, map simplify ts, argCount t, simplify t)  -funTyConName :: Name-funTyConName = mkWiredInName gHC_PRIM-                        (mkOccNameFS tcName FSLIT("(->)"))-                        funTyConKey-                        (ATyCon funTyCon)       -- Relevant TyCon-                        BuiltInSyntax- -------------------------------------------------------------------------------- -- Filtering hidden instances --------------------------------------------------------------------------------@@ -221,29 +260,21 @@  -- | We say that an instance is «hidden» iff its class or any (part) -- of its type(s) is hidden.-isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool-isInstanceHidden expInfo cls tys =+isInstanceHidden :: ExportInfo -> Name -> Set.Set Name -> Bool+isInstanceHidden expInfo cls tyNames =     instClassHidden || instTypeHidden   where     instClassHidden :: Bool-    instClassHidden = isNameHidden expInfo $ getName cls+    instClassHidden = isNameHidden expInfo cls      instTypeHidden :: Bool-    instTypeHidden = any (isTypeHidden expInfo) tys+    instTypeHidden = any (isNameHidden expInfo) tyNames  isTypeHidden :: ExportInfo -> Type -> Bool isTypeHidden expInfo = typeHidden   where     typeHidden :: Type -> Bool-    typeHidden t =-      case t of-        TyVarTy {} -> False-        AppTy t1 t2 -> typeHidden t1 || typeHidden t2-        TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args-        ForAllTy bndr ty -> typeHidden (binderType bndr) || typeHidden ty-        LitTy _ -> False-        CastTy ty _ -> typeHidden ty-        CoercionTy {} -> False+    typeHidden t = any nameHidden $ typeNames t      nameHidden :: Name -> Bool     nameHidden = isNameHidden expInfo
src/Haddock/Interface/Create.hs view
@@ -1,900 +1,1276 @@-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}-{-# OPTIONS_GHC -Wwarn #-}--------------------------------------------------------------------------------- |--- Module      :  Haddock.Interface.Create--- Copyright   :  (c) Simon Marlow      2003-2006,---                    David Waern       2006-2009,---                    Mateusz Kowalczyk 2013--- License     :  BSD-like------ Maintainer  :  haddock@projects.haskell.org--- Stability   :  experimental--- Portability :  portable-------------------------------------------------------------------------------module Haddock.Interface.Create (createInterface) where--import Documentation.Haddock.Doc (metaDocAppend)-import Haddock.Types-import Haddock.Options-import Haddock.GhcUtils-import Haddock.Utils-import Haddock.Convert-import Haddock.Interface.LexParseRn-import Haddock.Backends.Hyperlinker.Types-import Haddock.Backends.Hyperlinker.Ast as Hyperlinker-import Haddock.Backends.Hyperlinker.Parser as Hyperlinker--import qualified Data.Map as M-import Data.Map (Map)-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Ord-import Control.Applicative-import Control.Arrow (second)-import Control.DeepSeq-import Control.Monad-import Data.Function (on)--import qualified Packages-import qualified Module-import qualified SrcLoc-import GHC-import HscTypes-import Name-import Bag-import RdrName-import TcRnTypes-import FastString (concatFS)-import BasicTypes ( StringLiteral(..) )-import qualified Outputable as O-import HsDecls ( getConDetails )---- | Use a 'TypecheckedModule' to produce an 'Interface'.--- To do this, we need access to already processed modules in the topological--- sort. That's what's in the 'IfaceMap'.-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface-createInterface tm flags modMap instIfaceMap = do--  let ms             = pm_mod_summary . tm_parsed_module $ tm-      mi             = moduleInfo tm-      L _ hsm        = parsedSource tm-      !safety        = modInfoSafe mi-      mdl            = ms_mod ms-      dflags         = ms_hspp_opts ms-      !instances     = modInfoInstances mi-      !fam_instances = md_fam_insts md-      !exportedNames = modInfoExports mi--      (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm--  -- The renamed source should always be available to us, but it's best-  -- to be on the safe side.-  (group_, mayExports, mayDocHeader) <--    case renamedSource tm of-      Nothing -> do-        liftErrMsg $ tell [ "Warning: Renamed source is not available." ]-        return (emptyRnGroup, Nothing, Nothing)-      Just (x, _, y, z) -> return (x, y, z)--  opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl-  let opts-        | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0-        | otherwise = opts0--  (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader--  let declsWithDocs = topDecls group_-      fixMap = mkFixMap group_-      (decls, _) = unzip declsWithDocs-      localInsts = filter (nameIsLocalOrFrom mdl) $  map getName instances-                                                  ++ map getName fam_instances-      -- Locations of all TH splices-      splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]--      maps@(!docMap, !argMap, !subMap, !declMap, _) =-        mkMaps dflags gre localInsts declsWithDocs--  let exports0 = fmap (reverse . map unLoc) mayExports-      exports-        | OptIgnoreExports `elem` opts = Nothing-        | otherwise = exports0-      warningMap = mkWarningMap dflags warnings gre exportedNames--  let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))--  exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls-                   maps fixMap splices exports instIfaceMap dflags--  let !visibleNames = mkVisibleNames maps exportItems opts--  -- Measure haddock documentation coverage.-  let prunedExportItems0 = pruneExportItems exportItems-      !haddockable = 1 + length exportItems -- module + exports-      !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0-      !coverage = (haddockable, haddocked)--  -- Prune the export list to just those declarations that have-  -- documentation, if the 'prune' option is on.-  let prunedExportItems'-        | OptPrune `elem` opts = prunedExportItems0-        | otherwise = exportItems-      !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'--  let !aliases =-        mkAliasMap dflags $ tm_renamed_source tm-      modWarn = moduleWarning dflags gre warnings--  tokenizedSrc <- mkMaybeTokenizedSrc flags tm--  return $! Interface {-    ifaceMod             = mdl-  , ifaceOrigFilename    = msHsFilePath ms-  , ifaceInfo            = info-  , ifaceDoc             = Documentation mbDoc modWarn-  , ifaceRnDoc           = Documentation Nothing Nothing-  , ifaceOptions         = opts-  , ifaceDocMap          = docMap-  , ifaceArgMap          = argMap-  , ifaceRnDocMap        = M.empty-  , ifaceRnArgMap        = M.empty-  , ifaceExportItems     = prunedExportItems-  , ifaceRnExportItems   = []-  , ifaceExports         = exportedNames-  , ifaceVisibleExports  = visibleNames-  , ifaceDeclMap         = declMap-  , ifaceSubMap          = subMap-  , ifaceFixMap          = fixMap-  , ifaceModuleAliases   = aliases-  , ifaceInstances       = instances-  , ifaceFamInstances    = fam_instances-  , ifaceOrphanInstances   = [] -- Filled in `attachInstances`-  , ifaceRnOrphanInstances = [] -- Filled in `renameInterface`-  , ifaceHaddockCoverage = coverage-  , ifaceWarningMap      = warningMap-  , ifaceTokenizedSrc    = tokenizedSrc-  }--mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName-mkAliasMap dflags mRenamedSource =-  case mRenamedSource of-    Nothing -> M.empty-    Just (_,impDecls,_,_) ->-      M.fromList $-      mapMaybe (\(SrcLoc.L _ impDecl) -> do-        alias <- ideclAs impDecl-        return $-          (lookupModuleDyn dflags-             (fmap Module.fsToUnitId $-              fmap sl_fs $ ideclPkgQual impDecl)-             (case ideclName impDecl of SrcLoc.L _ name -> name),-           alias))-        impDecls---- similar to GHC.lookupModule-lookupModuleDyn ::-  DynFlags -> Maybe UnitId -> ModuleName -> Module-lookupModuleDyn _ (Just pkgId) mdlName =-  Module.mkModule pkgId mdlName-lookupModuleDyn dflags Nothing mdlName =-  case Packages.lookupModuleInAllPackages dflags mdlName of-    (m,_):_ -> m-    [] -> Module.mkModule Module.mainUnitId mdlName------------------------------------------------------------------------------------- Warnings----------------------------------------------------------------------------------mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap-mkWarningMap dflags warnings gre exps = case warnings of-  NoWarnings  -> M.empty-  WarnAll _   -> M.empty-  WarnSome ws ->-    let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ-              , let n = gre_name elt, n `elem` exps ]-    in M.fromList $ map (second $ parseWarning dflags gre) ws'--moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)-moduleWarning _ _ NoWarnings = Nothing-moduleWarning _ _ (WarnSome _) = Nothing-moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w--parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name-parseWarning dflags gre w = force $ case w of-  DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg)-  WarningTxt    _ msg -> format "Warning: "    (concatFS $ map (sl_fs . unLoc) msg)-  where-    format x xs = DocWarning . DocParagraph . DocAppend (DocString x)-                  . processDocString dflags gre $ HsDocString xs------------------------------------------------------------------------------------- Doc options------ Haddock options that are embedded in the source file-----------------------------------------------------------------------------------mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]-mkDocOpts mbOpts flags mdl = do-  opts <- case mbOpts of-    Just opts -> case words $ replace ',' ' ' opts of-      [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []-      xs -> liftM catMaybes (mapM parseOption xs)-    Nothing -> return []-  hm <- if Flag_HideModule (moduleString mdl) `elem` flags-        then return $ OptHide : opts-        else return opts-  if Flag_ShowExtensions (moduleString mdl) `elem` flags-    then return $ OptShowExtensions : hm-    else return hm---parseOption :: String -> ErrMsgM (Maybe DocOption)-parseOption "hide"            = return (Just OptHide)-parseOption "prune"           = return (Just OptPrune)-parseOption "ignore-exports"  = return (Just OptIgnoreExports)-parseOption "not-home"        = return (Just OptNotHome)-parseOption "show-extensions" = return (Just OptShowExtensions)-parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing-------------------------------------------------------------------------------------- Maps------------------------------------------------------------------------------------type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)---- | Create 'Maps' by looping through the declarations. For each declaration,--- find its names, its subordinates, and its doc strings. Process doc strings--- into 'Doc's.-mkMaps :: DynFlags-       -> GlobalRdrEnv-       -> [Name]-       -> [(LHsDecl Name, [HsDocString])]-       -> Maps-mkMaps dflags gre instances decls =-  let (a, b, c, d) = unzip4 $ map mappings decls-  in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)-  where-    f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b-    f = M.fromListWith (<>) . concat--    f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)-    f' = M.fromListWith metaDocAppend . concat--    mappings :: (LHsDecl Name, [HsDocString])-             -> ( [(Name, MDoc Name)]-                , [(Name, Map Int (MDoc Name))]-                , [(Name, [Name])]-                , [(Name,  [LHsDecl Name])]-                )-    mappings (ldecl, docStrs) =-      let L l decl = ldecl-          declDoc :: [HsDocString] -> Map Int HsDocString-                  -> (Maybe (MDoc Name), Map Int (MDoc Name))-          declDoc strs m =-            let doc' = processDocStrings dflags gre strs-                m' = M.map (processDocStringParas dflags gre) m-            in (doc', m')-          (doc, args) = declDoc docStrs (typeDocs decl)-          subs :: [(Name, [HsDocString], Map Int HsDocString)]-          subs = subordinates instanceMap decl-          (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs-          ns = names l decl-          subNs = [ n | (n, _, _) <- subs ]-          dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]-          am = [ (n, args) | n <- ns ] ++ zip subNs subArgs-          sm = [ (n, subNs) | n <- ns ]-          cm = [ (n, [ldecl]) | n <- ns ++ subNs ]-      in seqList ns `seq`-          seqList subNs `seq`-          doc `seq`-          seqList subDocs `seq`-          seqList subArgs `seq`-          (dm, am, sm, cm)--    instanceMap :: Map SrcSpan Name-    instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]--    names :: SrcSpan -> HsDecl Name -> [Name]-    names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].-      where loc = case d of-              TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs-              _ -> getInstLoc d-    names _ decl = getMainDeclBinder decl---- Note [2]:---------------- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.--- That should work for normal user-written instances (from looking at GHC--- sources). We can assume that commented instances are user-written.--- This lets us relate Names (from ClsInsts) to comments (associated--- with InstDecls).-------------------------------------------------------------------------------------- Declarations-------------------------------------------------------------------------------------- | Get all subordinate declarations inside a declaration, and their docs.-subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]-subordinates instMap decl = case decl of-  InstD (ClsInstD d) -> do-    DataFamInstDecl { dfid_tycon = L l _-                    , dfid_defn = def    } <- unLoc <$> cid_datafam_insts d-    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def--  InstD (DataFamInstD d)  -> dataSubs (dfid_defn d)-  TyClD d | isClassDecl d -> classSubs d-          | isDataDecl  d -> dataSubs (tcdDataDefn d)-  _ -> []-  where-    classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd-                   , name <- getMainDeclBinder d, not (isValD d)-                   ]-    dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)]-    dataSubs dd = constrs ++ fields-      where-        cons = map unL $ (dd_cons dd)-        constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)-                  | c <- cons, cname <- getConNames c ]-        fields  = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)-                  | RecCon flds <- map getConDetails cons-                  , L _ (ConDeclField ns _ doc) <- (unLoc flds)-                  , L _ n <- ns ]---- | Extract function argument docs from inside types.-typeDocs :: HsDecl Name -> Map Int HsDocString-typeDocs d =-  let docs = go 0 in-  case d of-    SigD (TypeSig _ ty)   -> docs (unLoc (hsSigWcType ty))-    SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty))-    ForD (ForeignImport _ ty _ _)   -> docs (unLoc (hsSigType ty))-    TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)-    _ -> M.empty-  where-    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)-    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)-    go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty-    go n (HsFunTy _ ty) = go (n+1) (unLoc ty)-    go n (HsDocTy _ (L _ doc)) = M.singleton n doc-    go _ _ = M.empty----- | All the sub declarations of a class (that we handle), ordered by--- source location, with documentation attached if it exists.-classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls-  where-    decls = docs ++ defs ++ sigs ++ ats-    docs  = mkDecls tcdDocs DocD class_-    defs  = mkDecls (bagToList . tcdMeths) ValD class_-    sigs  = mkDecls tcdSigs SigD class_-    ats   = mkDecls tcdATs (TyClD . FamDecl) class_----- | The top-level declarations of a module that we care about,--- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]-topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup---- | Extract a map of fixity declarations only-mkFixMap :: HsGroup Name -> FixMap-mkFixMap group_ = M.fromList [ (n,f)-                             | L _ (FixitySig ns f) <- hs_fixds group_,-                               L _ n <- ns ]----- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.-ungroup :: HsGroup Name -> [LHsDecl Name]-ungroup group_ =-  mkDecls (tyClGroupConcat . hs_tyclds) TyClD  group_ ++-  mkDecls hs_derivds             DerivD group_ ++-  mkDecls hs_defds               DefD   group_ ++-  mkDecls hs_fords               ForD   group_ ++-  mkDecls hs_docs                DocD   group_ ++-  mkDecls hs_instds              InstD  group_ ++-  mkDecls (typesigs . hs_valds)  SigD   group_ ++-  mkDecls (valbinds . hs_valds)  ValD   group_-  where-    typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs-    typesigs _ = error "expected ValBindsOut"--    valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds-    valbinds _ = error "expected ValBindsOut"----- | Take a field of declarations from a data structure and create HsDecls--- using the given constructor-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]----- | Sort by source location-sortByLoc :: [Located a] -> [Located a]-sortByLoc = sortBy (comparing getLoc)-------------------------------------------------------------------------------------- Filtering of declarations------ We filter out declarations that we don't intend to handle later.-------------------------------------------------------------------------------------- | Filter out declarations that we don't handle in Haddock-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterDecls = filter (isHandled . unL . fst)-  where-    isHandled (ForD (ForeignImport {})) = True-    isHandled (TyClD {}) = True-    isHandled (InstD {}) = True-    isHandled (SigD d) = isUserLSig (reL d)-    isHandled (ValD _) = True-    -- we keep doc declarations to be able to get at named docs-    isHandled (DocD _) = True-    isHandled _ = False----- | Go through all class declarations and filter their sub-declarations-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x-                      | x@(L loc d, doc) <- decls ]-  where-    filterClass (TyClD c) =-      TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c }-    filterClass _ = error "expected TyClD"-------------------------------------------------------------------------------------- Collect docs------ To be able to attach the right Haddock comment to the right declaration,--- we sort the declarations by their SrcLoc and "collect" the docs for each--- declaration.-------------------------------------------------------------------------------------- | Collect docs and attach them to the right declarations.-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]-collectDocs = go Nothing []-  where-    go Nothing _ [] = []-    go (Just prev) docs [] = finished prev docs []-    go prev docs (L _ (DocD (DocCommentNext str)) : ds)-      | Nothing <- prev = go Nothing (str:docs) ds-      | Just decl <- prev = finished decl docs (go Nothing [str] ds)-    go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds-    go Nothing docs (d:ds) = go (Just d) docs ds-    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)--    finished decl docs rest = (decl, reverse docs) : rest----- | Build the list of items that will become the documentation, from the--- export list.  At this point, the list of ExportItems is in terms of--- original names.------ We create the export items even if the module is hidden, since they--- might be useful when creating the export items for other modules.-mkExportItems-  :: IfaceMap-  -> Module             -- this module-  -> WarningMap-  -> GlobalRdrEnv-  -> [Name]             -- exported names (orig)-  -> [LHsDecl Name]-  -> Maps-  -> FixMap-  -> [SrcSpan]          -- splice locations-  -> Maybe [IE Name]-  -> InstIfaceMap-  -> DynFlags-  -> ErrMsgGhc [ExportItem Name]-mkExportItems-  modMap thisMod warnings gre exportedNames decls-  maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =-  case optExports of-    Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls-    Just exports -> liftM concat $ mapM lookupExport exports-  where-    lookupExport (IEVar (L _ x))         = declWith x-    lookupExport (IEThingAbs (L _ t))    = declWith t-    lookupExport (IEThingAll (L _ t))    = declWith t-    lookupExport (IEThingWith (L _ t) _ _ _) = declWith t-    lookupExport (IEModuleContents (L _ m)) =-      moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices-    lookupExport (IEGroup lev docStr)  = return $-      return . ExportGroup lev "" $ processDocString dflags gre docStr--    lookupExport (IEDoc docStr)        = return $-      return . ExportDoc $ processDocStringParas dflags gre docStr--    lookupExport (IEDocNamed str)      = liftErrMsg $-      findNamedDoc str [ unL d | d <- decls ] >>= return . \case-        Nothing -> []-        Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc--    declWith :: Name -> ErrMsgGhc [ ExportItem Name ]-    declWith t =-      case findDecl t of-        ([L l (ValD _)], (doc, _)) -> do-          -- Top-level binding without type signature-          export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap-          return [export]-        (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->-          let declNames = getMainDeclBinder (unL decl)-          in case () of-            _-              -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how-              -- to handle them yet. We should really give an warning message also, and filter the-              -- name out in mkVisibleNames...-              | t `elem` declATs (unL decl)        -> return []--              -- We should not show a subordinate by itself if any of its-              -- parents is also exported. See note [1].-              | t `notElem` declNames,-                Just p <- find isExported (parents t $ unL decl) ->-                do liftErrMsg $ tell [-                     "Warning: " ++ moduleString thisMod ++ ": " ++-                     pretty dflags (nameOccName t) ++ " is exported separately but " ++-                     "will be documented under " ++ pretty dflags (nameOccName p) ++-                     ". Consider exporting it together with its parent(s)" ++-                     " for code clarity." ]-                   return []--              -- normal case-              | otherwise -> case decl of-                  -- A single signature might refer to many names, but we-                  -- create an export item for a single name only.  So we-                  -- modify the signature to contain only that single name.-                  L loc (SigD sig) ->-                    -- fromJust is safe since we already checked in guards-                    -- that 't' is a name declared in this declaration.-                    let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig-                    in return [ mkExportDecl t newDecl docs_ ]--                  L loc (TyClD cl@ClassDecl{}) -> do-                    mdef <- liftGhcToErrMsgGhc $ minimalDef t-                    let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef-                    return [ mkExportDecl t-                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]--                  _ -> return [ mkExportDecl t decl docs_ ]--        -- Declaration from another package-        ([], _) -> do-          mayDecl <- hiDecl dflags t-          case mayDecl of-            Nothing -> return [ ExportNoDecl t [] ]-            Just decl ->-              -- We try to get the subs and docs-              -- from the installed .haddock file for that package.-              case M.lookup (nameModule t) instIfaceMap of-                Nothing -> do-                   liftErrMsg $ tell-                      ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]-                   let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]-                   return [ mkExportDecl t decl (noDocForDecl, subs_) ]-                Just iface ->-                   return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]--        _ -> return []---    mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name-    mkExportDecl name decl (doc, subs) = decl'-      where-        decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False-        mdl = nameModule name-        subs' = filter (isExported . fst) subs-        sub_names = map fst subs'-        fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]---    isExported = (`elem` exportedNames)---    findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))-    findDecl n-      | m == thisMod, Just ds <- M.lookup n declMap =-          (ds, lookupDocs n warnings docMap argMap subMap)-      | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =-          (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))-      | otherwise = ([], (noDocForDecl, []))-      where-        m = nameModule n---hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))-hiDecl dflags t = do-  mayTyThing <- liftGhcToErrMsgGhc $ lookupName t-  case mayTyThing of-    Nothing -> do-      liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]-      return Nothing-    Just x -> case tyThingToLHsDecl x of-      Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing-      Right (m, t') -> liftErrMsg (tell $ map bugWarn m)-                      >> return (Just $ noLoc t')-    where-      warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>-                   O.comma O.<+> O.quotes (O.ppr t) O.<+>-                   O.text "-- Please report this on Haddock issue tracker!"-      bugWarn = O.showSDoc dflags . warnLine---- | This function is called for top-level bindings without type signatures.--- It gets the type signature from GHC and that means it's not going to--- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the--- declaration and use it instead - 'nLoc' here.-hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool-                -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)-hiValExportItem dflags name nLoc doc splice fixity = do-  mayDecl <- hiDecl dflags name-  case mayDecl of-    Nothing -> return (ExportNoDecl name [])-    Just decl -> return (ExportDecl (fixSpan decl) doc [] [] fixities splice)-  where-    fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t-    fixities = case fixity of-      Just f  -> [(name, f)]-      Nothing -> []----- | Lookup docs for a declaration from maps.-lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap-           -> (DocForDecl Name, [(Name, DocForDecl Name)])-lookupDocs n warnings docMap argMap subMap =-  let lookupArgDoc x = M.findWithDefault M.empty x argMap in-  let doc = (lookupDoc n, lookupArgDoc n) in-  let subs = M.findWithDefault [] n subMap in-  let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in-  (doc, subDocs)-  where-    lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)----- | Return all export items produced by an exported module. That is, we're--- interested in the exports produced by \"module B\" in such a scenario:------ > module A (module B) where--- > import B (...) hiding (...)------ There are three different cases to consider:------ 1) B is hidden, in which case we return all its exports that are in scope in A.--- 2) B is visible, but not all its exports are in scope in A, in which case we---    only return those that are.--- 3) B is visible and all its exports are in scope, in which case we return---    a single 'ExportModule' item.-moduleExports :: Module           -- ^ Module A-              -> ModuleName       -- ^ The real name of B, the exported module-              -> DynFlags         -- ^ The flags used when typechecking A-              -> WarningMap-              -> GlobalRdrEnv     -- ^ The renaming environment used for A-              -> [Name]           -- ^ All the exports of A-              -> [LHsDecl Name]   -- ^ All the declarations in A-              -> IfaceMap         -- ^ Already created interfaces-              -> InstIfaceMap     -- ^ Interfaces in other packages-              -> Maps-              -> FixMap-              -> [SrcSpan]        -- ^ Locations of all TH splices-              -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items-moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices-  | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls-  | otherwise =-    case M.lookup m ifaceMap of-      Just iface-        | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)-        | otherwise -> return [ ExportModule m ]--      Nothing -> -- We have to try to find it in the installed interfaces-                 -- (external packages).-        case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of-          Just iface -> return [ ExportModule (instMod iface) ]-          Nothing -> do-            liftErrMsg $-              tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++-                    "documentation for exported module: " ++ pretty dflags expMod]-            return []-  where-    m = mkModule unitId expMod-    unitId = moduleUnitId thisMod----- Note [1]:---------------- It is unnecessary to document a subordinate by itself at the top level if--- any of its parents is also documented. Furthermore, if the subordinate is a--- record field or a class method, documenting it under its parent--- indicates its special status.------ A user might expect that it should show up separately, so we issue a--- warning. It's a fine opportunity to also tell the user she might want to--- export the subordinate through the parent export item for clarity.------ The code removes top-level subordinates also when the parent is exported--- through a 'module' export. I think that is fine.------ (For more information, see Trac #69)---fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]-                   -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =-  liftM catMaybes $ mapM mkExportItem (expandSig decls)-  where-    -- A type signature can have multiple names, like:-    --   foo, bar :: Types..-    ---    -- We go through the list of declarations and expand type signatures, so-    -- that every type signature has exactly one name!-    expandSig :: [LHsDecl name] -> [LHsDecl name]-    expandSig = foldr f []-      where-        f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]-        f (L l (SigD (TypeSig    names t)))   xs = foldr (\n acc -> L l (SigD (TypeSig      [n] t)) : acc) xs names-        f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names-        f x xs = x : xs--    mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))-    mkExportItem (L _ (DocD (DocGroup lev docStr))) = do-      return . Just . ExportGroup lev "" $ processDocString dflags gre docStr-    mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do-      return . Just . ExportDoc $ processDocStringParas dflags gre docStr-    mkExportItem (L l (ValD d))-      | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =-          -- Top-level binding without type signature.-          let (doc, _) = lookupDocs name warnings docMap argMap subMap in-          fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap)-      | otherwise = return Nothing-    mkExportItem decl@(L l (InstD d))-      | Just name <- M.lookup (getInstLoc d) instMap =-        let (doc, subs) = lookupDocs name warnings docMap argMap subMap in-        return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))-    mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do-      mdef <- liftGhcToErrMsgGhc $ minimalDef name-      let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . noLoc . fmap noLoc) mdef-      expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name-    mkExportItem decl@(L l d)-      | name:_ <- getMainDeclBinder d = expDecl decl l name-      | otherwise = return Nothing--    fixities name subs = [ (n,f) | n <- name : map fst subs-                                 , Just f <- [M.lookup n fixMap] ]--    expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))-      where (doc, subs) = lookupDocs name warnings docMap argMap subMap----- | Sometimes the declaration we want to export is not the "main" declaration:--- it might be an individual record selector or a class method.  In these--- cases we have to extract the required declaration (and somehow cobble--- together a type signature for it...).-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name-extractDecl name mdl decl-  | name `elem` getMainDeclBinder (unLoc decl) = decl-  | otherwise  =-    case unLoc decl of-      TyClD d@ClassDecl {} ->-        let matches = [ lsig-                      | lsig <- tcdSigs d-                      , ClassOpSig False _ _ <- pure $ unLoc lsig-                        -- Note: exclude `default` declarations (see #505)-                      , name `elem` sigName lsig-                      ]-            -- TODO: document fixity-        in case matches of-          [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)-                      L pos sig = addClassContext n tyvar_names s0-                  in L pos (SigD sig)-          _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:"-                                         O.$$ O.nest 4 (O.ppr d)-                                         O.$$ O.text "Matches:"-                                         O.$$ O.nest 4 (O.ppr matches))-      TyClD d@DataDecl {} ->-        let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))-        in SigD <$> extractRecSel name mdl n tyvar_tys (dd_cons (tcdDataDefn d))-      InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n-                                          , dfid_pats = HsIB { hsib_body = tys }-                                          , dfid_defn = defn }) ->-        SigD <$> extractRecSel name mdl n tys (dd_cons defn)-      InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->-        let matches = [ d | L _ d <- insts-                          -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)-                          , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d))-                          , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)-                          , L _ n <- ns-                          , selectorFieldOcc n == name-                      ]-        in case matches of-          [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)-          _ -> error "internal: extractDecl (ClsInstD)"-      _ -> error "internal: extractDecl"--extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]-              -> LSig Name-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"--extractRecSel nm mdl t tvs (L _ con : rest) =-  case getConDetails con of-    RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->-      L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))-    _ -> extractRecSel nm mdl t tvs rest- where-  matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]-  matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds-                                 , L l n <- ns, selectorFieldOcc n == nm ]-  data_ty-    -- ResTyGADT _ ty <- con_res con = ty-    | ConDeclGADT{} <- con = hsib_body $ con_type con-    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs---- | Keep export items with docs.-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]-pruneExportItems = filter hasDoc-  where-    hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d-    hasDoc _ = True---mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]-mkVisibleNames (_, _, _, _, instMap) exports opts-  | OptHide `elem` opts = []-  | otherwise = let ns = concatMap exportName exports-                in seqList ns `seq` ns-  where-    exportName e@ExportDecl {} = name ++ subs-      where subs = map fst (expItemSubDocs e)-            name = case unLoc $ expItemDecl e of-              InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap-              decl    -> getMainDeclBinder decl-    exportName ExportNoDecl {} = [] -- we don't count these as visible, since-                                    -- we don't want links to go to them.-    exportName _ = []--seqList :: [a] -> ()-seqList [] = ()-seqList (x : xs) = x `seq` seqList xs--mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule-                    -> ErrMsgGhc (Maybe [RichToken])-mkMaybeTokenizedSrc flags tm-    | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of-        Just src -> do-            tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src-            return $ Just tokens-        Nothing -> do-            liftErrMsg . tell . pure $ concat-                [ "Warning: Cannot hyperlink module \""-                , moduleNameString . ms_mod_name $ summary-                , "\" because renamed source is not available"-                ]-            return Nothing-    | otherwise = return Nothing-  where-    summary = pm_mod_summary . tm_parsed_module $ tm--mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]-mkTokenizedSrc ms src =-    Hyperlinker.enrich src . Hyperlinker.parse <$> rawSrc-  where-    rawSrc = readFile $ msHsFilePath ms---- | Find a stand-alone documentation comment by its name.-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)-findNamedDoc name = search-  where-    search [] = do-      tell ["Cannot find documentation for: $" ++ name]-      return Nothing-    search (DocD (DocCommentNamed name' doc) : rest)-      | name == name' = return (Just doc)+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wwarn #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Interface.Create+-- Copyright   :  (c) Simon Marlow      2003-2006,+--                    David Waern       2006-2009,+--                    Mateusz Kowalczyk 2013+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- This module provides a single function 'createInterface',+-- which creates a Haddock 'Interface' from the typechecking+-- results 'TypecheckedModule' from GHC.+-----------------------------------------------------------------------------+module Haddock.Interface.Create (IfM, runIfM, createInterface1) where++import Documentation.Haddock.Doc (metaDocAppend)+import Haddock.Backends.Hoogle (outWith)+import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl, synifyInstHead)+import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents,+                         pretty, restrictTo, sigName, unL, typeNames)+import Haddock.Interface.AttachInstances (instHead)+import Haddock.Interface.LexParseRn+import Haddock.Options (Flag (..), modulePackageInfo)+import Haddock.Types+import Haddock.Utils (replace)++import Control.Applicative ((<|>))+import Control.DeepSeq+import Control.Monad.State.Strict+import Data.Bitraversable (bitraverse)+import Data.Foldable (toList)+import Data.List (find, foldl')+import qualified Data.IntMap as IM+import Data.IntMap (IntMap)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList)+import qualified Data.Set as Set+import Data.Traversable (for)++import GHC hiding (lookupName)+import GHC.Core (isOrphan)+import GHC.Core.Class (ClassMinimalDef, classMinimalDef)+import GHC.Core.ConLike (ConLike (..))+import GHC.Core.InstEnv+import GHC.Data.FastString (unpackFS)+import GHC.Driver.Ppr (showSDoc, showSDocForUser)+import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps)+import GHC.IORef (readIORef)+import GHC.Stack (HasCallStack)+import GHC.Tc.Types hiding (IfM)+import GHC.Tc.Utils.Monad (finalSafeMode)+import GHC.Types.Avail hiding (avail)+import qualified GHC.Types.Avail as Avail+import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv)+import GHC.Types.Name.Env (lookupNameEnv)+import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv)+import GHC.Types.Name.Set (elemNameSet, mkNameSet)+import GHC.Types.SourceFile (HscSource (..))+import GHC.Types.SourceText (SourceText (..), sl_fs)+import GHC.Unit.Types+import qualified GHC.Types.SrcLoc as SrcLoc+import qualified GHC.Unit.Module as Module+import GHC.Unit.Module.ModSummary (msHsFilePath)+import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)+import qualified GHC.Utils.Outputable as O+import GHC.Utils.Panic (pprPanic)+import GHC.Unit.Module.Warnings+import GHC.Types.Unique.Map++createInterface1+  :: MonadIO m+  => [Flag]+  -> UnitState+  -> ModSummary+  -> TcGblEnv+  -> IfaceMap+  -> InstIfaceMap+  -> IfM m Interface+createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do++  let+    ModSummary+      {+        -- Cached flags from OPTIONS, INCLUDE and LANGUAGE+        -- pragmas in the modules source code. Used to infer+        -- safety of module.+        ms_hspp_opts+      , ms_location = ModLocation+        {+          ml_hie_file+        }+      } = mod_sum++    !ml_hie_file' = force ml_hie_file++    TcGblEnv+      {+        tcg_mod+      , tcg_src+      , tcg_semantic_mod+      , tcg_rdr_env+      , tcg_exports+      , tcg_insts+      , tcg_fam_insts+      , tcg_warns++      -- Renamed source+      , tcg_rn_imports+      , tcg_rn_exports+      , tcg_rn_decls++      , tcg_th_docs+      , tcg_doc_hdr+      } = tc_gbl_env++    dflags = ms_hspp_opts++    is_sig = tcg_src == HsigFile++    (pkg_name_fs, _) =+      modulePackageInfo unit_state flags (Just tcg_mod)++    pkg_name :: Maybe Package+    pkg_name =+      let+        unpack (PackageName name) = unpackFS name+      in+        fmap unpack pkg_name_fs++    fixities :: FixMap+    fixities = case tcg_rn_decls of+      Nothing -> mempty+      Just dx -> mkFixMap dx++    -- Locations of all the TH splices+    loc_splices :: [SrcSpan]+    loc_splices = case tcg_rn_decls of+      Nothing -> []+      Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ]++  decls <- case tcg_rn_decls of+    Nothing -> do+      warn "Warning: Renamed source is not available"+      pure []+    Just dx -> pure (topDecls dx)++  -- Derive final options to use for haddocking this module+  doc_opts <- mkDocOpts (haddockOptions ms_hspp_opts) flags tcg_mod++  let+    -- All elements of an explicit export list, if present+    export_list :: Maybe [(IE GhcRn, Avails)]+    export_list+      | OptIgnoreExports `elem` doc_opts  =+          Nothing+      | Just rn_exports <- tcg_rn_exports =+          Just [ (ie, avail) | (L _ ie, avail) <- rn_exports ]+      | otherwise =+          Nothing++    -- All the exported Names of this module.+    exported_names :: [Name]+    !exported_names = force $+      concatMap availNamesWithSelectors tcg_exports++    -- Module imports of the form `import X`. Note that there is+    -- a) no qualification and+    -- b) no import list+    imported_modules :: Map ModuleName [ModuleName]+    imported_modules+      | Just{} <- export_list =+          unrestrictedModuleImports (map unLoc tcg_rn_imports)+      | otherwise =+          M.empty++    -- TyThings that have instances defined in this module+    local_instances :: [Name]+    local_instances =+      [ name+      | name <- map getName tcg_insts ++ map getName tcg_fam_insts+      , nameIsLocalOrFrom tcg_semantic_mod name+      ]++  -- Infer module safety+  safety   <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env)++  -- The docs added via Template Haskell's putDoc+  thDocs@ExtractedTHDocs { ethd_mod_header = thMbDocStr } <-+    liftIO $ extractTHDocs <$> readIORef tcg_th_docs++  -- Process the top-level module header documentation.+  (!info, !header_doc) <- force <$> processModuleHeader dflags pkg_name+    tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr))++  -- Warnings on declarations in this module+  decl_warnings <- mkWarningMap dflags tcg_warns tcg_rdr_env exported_names++  -- Warning on the module header+  mod_warning <- moduleWarning dflags tcg_rdr_env tcg_warns++  let+    -- Warnings in this module and transitive warnings from dependent modules+    warnings :: Map Name (Doc Name)+    warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))++  maps@(!docs, !arg_docs, !decl_map, _) <-+    mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs++  export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod+    warnings tcg_rdr_env exported_names (map fst decls) maps fixities+    imported_modules loc_splices export_list tcg_exports inst_ifaces dflags++  let+    visible_names :: [Name]+    !visible_names = force $ mkVisibleNames maps export_items doc_opts++    -- Measure haddock documentation coverage.+    pruned_export_items :: [ExportItem GhcRn]+    pruned_export_items = pruneExportItems export_items++    !haddockable = 1 + length export_items -- module + exports+    !haddocked = (if isJust tcg_doc_hdr then 1 else 0) + length pruned_export_items++    coverage :: (Int, Int)+    !coverage = (haddockable, haddocked)++    aliases :: Map Module ModuleName+    aliases = mkAliasMap unit_state tcg_rn_imports++    insts :: [HaddockClsInst]+    !insts = force $ map (fromClsInst (Flag_Hoogle `elem` flags) dflags unit_state) tcg_insts++  return $! Interface+    {+      ifaceMod               = tcg_mod+    , ifaceIsSig             = is_sig+    , ifaceOrigFilename      = msHsFilePath mod_sum+    , ifaceHieFile           = Just ml_hie_file'+    , ifaceInfo              = info+    , ifaceDoc               = Documentation header_doc mod_warning+    , ifaceRnDoc             = Documentation Nothing Nothing+    , ifaceOptions           = doc_opts+    , ifaceDocMap            = docs+    , ifaceArgMap            = arg_docs+    , ifaceExportItems       = if OptPrune `elem` doc_opts then+                                 pruned_export_items else export_items+    , ifaceRnExportItems     = [] -- Filled in renameInterfaceRn+    , ifaceExports           = exported_names+    , ifaceVisibleExports    = visible_names+    , ifaceDeclMap           = decl_map+    , ifaceFixMap            = fixities+    , ifaceModuleAliases     = aliases+    , ifaceInstances         = insts+    , ifaceOrphanInstances   = [] -- Filled in attachInstances+    , ifaceRnOrphanInstances = [] -- Filled in renameInterfaceRn+    , ifaceHaddockCoverage   = coverage+    , ifaceWarningMap        = warnings+    , ifaceDynFlags          = dflags+    }+++-- | Given all of the @import M as N@ declarations in a package,+-- create a mapping from the module identity of M, to an alias N+-- (if there are multiple aliases, we pick the last one.)  This+-- will go in 'ifaceModuleAliases'.+mkAliasMap :: UnitState -> [LImportDecl GhcRn] -> M.Map Module ModuleName+mkAliasMap st impDecls =+  M.fromList $+  mapMaybe (\(SrcLoc.L _ impDecl) -> do+    SrcLoc.L _ alias <- ideclAs impDecl+    return+      (lookupModuleDyn st+         -- TODO: This is supremely dodgy, because in general the+         -- UnitId isn't going to look anything like the package+         -- qualifier (even with old versions of GHC, the+         -- IPID would be p-0.1, but a package qualifier never+         -- has a version number it.  (Is it possible that in+         -- Haddock-land, the UnitIds never have version numbers?+         -- I, ezyang, have not quite understand Haddock's package+         -- identifier model.)+         --+         -- Additionally, this is simulating some logic GHC already+         -- has for deciding how to qualify names when it outputs+         -- them to the user.  We should reuse that information;+         -- or at least reuse the renamed imports, which know what+         -- they import!+         (ideclPkgQual impDecl)+         (case ideclName impDecl of SrcLoc.L _ name -> name),+       alias))+    impDecls++-- We want to know which modules are imported without any qualification. This+-- way we can display module reexports more compactly. This mapping also looks+-- through aliases:+--+-- module M (module X) where+--   import M1 as X+--   import M2 as X+--+-- With our mapping we know that we can display exported modules M1 and M2.+--+unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName]+unrestrictedModuleImports idecls =+  M.map (map (unLoc . ideclName))+  $ M.filter (all isInteresting) impModMap+  where+    impModMap =+      M.fromListWith (++) (concatMap moduleMapping idecls)++    moduleMapping idecl =+      concat [ [ (unLoc (ideclName idecl), [idecl]) ]+             , [ (unLoc mod_name, [idecl])+               | Just mod_name <- [ideclAs idecl]+               ]+             ]++    isInteresting idecl =+      case ideclImportList idecl of+        -- i) no subset selected+        Nothing             -> True+        -- ii) an import with a hiding clause+        -- without any names+        Just (EverythingBut, L _ []) -> True+        -- iii) any other case of qualification+        _                   -> False++-- Similar to GHC.lookupModule+-- ezyang: Not really...+lookupModuleDyn ::+  UnitState -> PkgQual -> ModuleName -> Module+lookupModuleDyn st pkg_qual mdlName = case pkg_qual of+  OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName+  ThisPkg uid  -> Module.mkModule (RealUnit (Definite uid)) mdlName+  NoPkgQual    -> case lookupModuleInAllUnits st mdlName of+    (m,_):_ -> m+    [] -> Module.mkModule Module.mainUnit mdlName++-- | Prune a 'ClsInst' down to a 'HaddockClsInst'. The goal is to remove as much+-- unnecessary information from the 'ClsInst' as possible by precomputing the+-- information we eventually want from it.+fromClsInst+  :: Bool+  -- ^ Was Hoogle output requested?+  -> DynFlags+  -- ^ GHC session dynflags+  -> UnitState+  -- ^ GHC session dynflags+  -> ClsInst+  -- ^ Class instance to convert+  -> HaddockClsInst+  -- ^ Resulting Haddock class instance+fromClsInst doHoogle dflags unitState inst =+    HaddockClsInst+      { haddockClsInstPprHoogle =+          if doHoogle then Just (ppInstance inst) else Nothing+      , haddockClsInstName = getName inst+      , haddockClsInstClsName = getName cls+      , haddockClsInstIsOrphan = isOrphan $ is_orphan inst+      , haddockClsInstSynified = synifyInstHead instSig+      , haddockClsInstHead = instHead instSig+      , haddockClsInstTyNames =+          foldl' (\ns t -> ns `Set.union` typeNames t) Set.empty tys+      }+  where+    instSig :: ([TyVar], [Type], Class, [Type])+    instSig@(_,_,cls,tys) = instanceSig inst++    ppInstance :: ClsInst -> String+    ppInstance i =+        dropComment $ outWith (showSDocForUser dflags unitState alwaysQualify) i'+      where+        -- As per #168, we don't want safety information about the class+        -- in Hoogle output. The easiest way to achieve this is to set the+        -- safety information to a state where the Outputable instance+        -- produces no output which means no overlap and unsafe (or [safe]+        -- is generated).+        i' = i { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText+                                        , isSafeOverlap = False } }++        dropComment :: String -> String+        dropComment (' ':'-':'-':' ':_) = []+        dropComment (x:xs) = x : dropComment xs+        dropComment [] = []+++-------------------------------------------------------------------------------+-- Warnings+-------------------------------------------------------------------------------++mkWarningMap+  :: MonadIO m+  => DynFlags+  -> Warnings a+  -> GlobalRdrEnv+  -> [Name]+  -> IfM m WarningMap+mkWarningMap dflags warnings gre exps = case warnings of+  NoWarnings  -> pure M.empty+  WarnAll _   -> pure M.empty+  WarnSome ws ->+    let ws' = [ (n, w)+              | (occ, w) <- ws+              , elt <- lookupGlobalRdrEnv gre occ+              , let n = greMangledName elt, n `elem` exps ]+    in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'++moduleWarning+  :: MonadIO m+  => DynFlags+  -> GlobalRdrEnv+  -> Warnings a+  -> IfM m (Maybe (Doc Name))+moduleWarning _ _ NoWarnings = pure Nothing+moduleWarning _ _ (WarnSome _) = pure Nothing+moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w++parseWarning+  :: MonadIO m+  => DynFlags+  -> GlobalRdrEnv+  -> WarningTxt a+  -> IfM m (Doc Name)+parseWarning dflags gre w = case w of+  DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)+  WarningTxt    _ msg -> format "Warning: "    (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)+  where+    format x bs = DocWarning . DocParagraph . DocAppend (DocString x)+                  <$> processDocStringFromString dflags gre bs+++-------------------------------------------------------------------------------+-- Doc options+--+-- Haddock options that are embedded in the source file+-------------------------------------------------------------------------------++mkDocOpts :: MonadIO m => Maybe String -> [Flag] -> Module -> IfM m [DocOption]+mkDocOpts mbOpts flags mdl = do+  opts <- case mbOpts of+    Just opts -> case words $ replace ',' ' ' opts of+      [] -> warn "No option supplied to DOC_OPTION/doc_option" >> return []+      xs -> fmap catMaybes (mapM parseOption xs)+    Nothing -> return []+  pure (foldl go opts flags)+  where+    mdlStr = moduleString mdl++    -- Later flags override earlier ones+    go os m | m == Flag_HideModule mdlStr     = OptHide : os+            | m == Flag_ShowModule mdlStr     = filter (/= OptHide) os+            | m == Flag_ShowAllModules        = filter (/= OptHide) os+            | m == Flag_IgnoreAllExports      = OptIgnoreExports : os+            | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os+            | otherwise                       = os++parseOption :: MonadIO m => String -> IfM m (Maybe DocOption)+parseOption "hide"            = return (Just OptHide)+parseOption "prune"           = return (Just OptPrune)+parseOption "ignore-exports"  = return (Just OptIgnoreExports)+parseOption "not-home"        = return (Just OptNotHome)+parseOption "show-extensions" = return (Just OptShowExtensions)+parseOption other = warn ("Unrecognised option: " ++ other) >> return Nothing++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------+++type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap)++-- | Create 'Maps' by looping through the declarations. For each declaration,+-- find its names, its subordinates, and its doc strings. Process doc strings+-- into 'Doc's.+mkMaps+  :: MonadIO m+  => DynFlags+  -> Maybe Package  -- this package+  -> GlobalRdrEnv+  -> [Name]+  -> [(LHsDecl GhcRn, [HsDoc GhcRn])]+  -> ExtractedTHDocs -- ^ Template Haskell putDoc docs+  -> IfM m Maps+mkMaps dflags pkgName gre instances decls thDocs = do+  (a, b, c) <- unzip3 <$> traverse mappings decls+  (th_a, th_b) <- thMappings+  pure ( force $+           th_a `M.union` f' (map (nubByName fst) a)+       , force $+           fmap intmap2mapint $+             th_b `unionArgMaps` (f (filterMapping (not . IM.null) b))+       , f c+       , instanceMap+       )+  where+    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b+    f = M.fromListWith (<>) . concat++    f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)+    f' = M.fromListWith metaDocAppend . concat++    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]+    filterMapping p = map (filter (p . snd))++    -- Convert IntMap -> IntMap+    -- TODO: should ArgMap eventually be switched over to IntMap?+    intmap2mapint = M.fromList . IM.toList++    -- | Extract the mappings from template haskell.+    -- No DeclMap/InstMap is needed since we already have access to the+    -- doc strings+    thMappings+      :: MonadIO m+      => IfM m (Map Name (MDoc Name), Map Name (IntMap (MDoc Name)))+    thMappings = do+      let ExtractedTHDocs+            _+            declDocs+            argDocs+            instDocs = thDocs+          ds2mdoc :: MonadIO m => (HsDoc GhcRn) -> IfM m (MDoc Name)+          ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString++      let cvt = M.fromList . nonDetEltsUniqMap++      declDocs' <- mapM ds2mdoc (cvt declDocs)+      argDocs'  <- mapM (mapM ds2mdoc) (cvt argDocs)+      instDocs' <- mapM ds2mdoc (cvt instDocs)+      return (declDocs' <> instDocs', argDocs')+++    mappings+      :: MonadIO m+      => (LHsDecl GhcRn, [HsDoc GhcRn])+      -> IfM m+         ( [(Name, MDoc Name)]+         , [(Name, IntMap (MDoc Name))]+         , [(Name, DeclMapEntry)]+         )+    mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do+      let docStrs = map hsDocString hs_docStrs+          declDoc+            :: MonadIO m+            => [HsDocString]+            -> IntMap HsDocString+            -> IfM m (Maybe (MDoc Name), IntMap (MDoc Name))+          declDoc strs m = do+            doc' <- processDocStrings dflags pkgName gre strs+            m'   <- traverse (processDocStringParas dflags pkgName gre) m+            pure (doc', m')++      (!doc, !args) <- force <$> declDoc docStrs (fmap hsDocString (declTypeDocs decl))++      let+          subs :: [(Name, [HsDocString], IntMap HsDocString)]+          subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im))+                  $ subordinates emptyOccEnv instanceMap decl++      (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs++      let+          ns = names l decl+          subNs = [ n | (n, _, _) <- subs ]+          dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]+          am = [ (n, args) | n <- ns ] ++ zip subNs subArgs+          cm = [ (n, toDeclMapEntry ldecl) | n <- ns ++ subNs ]++      seqList ns `seq`+        seqList subNs `seq`+        doc `seq`+        seqList subDocs `seq`+        seqList subArgs `seq`+        pure (dm, am, cm)+    mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], [])++    instanceMap :: Map RealSrcSpan Name+    instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]++    names :: RealSrcSpan -> HsDecl GhcRn -> [Name]+    names _ (InstD _ d) = maybeToList (SrcLoc.lookupSrcSpan loc instanceMap) -- See note [2].+      where loc = case d of+              -- The CoAx's loc is the whole line, but only for TFs. The+              -- workaround is to dig into the family instance declaration and+              -- get the identifier with the right location.+              TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')+              _ -> getInstLoc d+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].+    names _ decl = getMainDeclBinder emptyOccEnv decl++-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two+-- maps with values for the same key merge the inner map as well.+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.++unionArgMaps :: forall b . Map Name (IntMap b)+             -> Map Name (IntMap b)+             -> Map Name (IntMap b)+unionArgMaps a b = M.foldrWithKey go b a+  where+    go :: Name -> IntMap b+            -> Map Name (IntMap b) -> Map Name (IntMap b)+    go n newArgMap acc+      | Just oldArgMap <- M.lookup n acc =+          M.insert n (newArgMap `IM.union` oldArgMap) acc+      | otherwise = M.insert n newArgMap acc++-- Note [2]:+------------+-- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried+-- inside them. That should work for normal user-written instances (from+-- looking at GHC sources). We can assume that commented instances are+-- user-written. This lets us relate Names (from ClsInsts) to comments+-- (associated with InstDecls and DerivDecls).++--------------------------------------------------------------------------------+-- Declarations+--------------------------------------------------------------------------------++-- | Extract a map of fixity declarations only+mkFixMap :: HsGroup GhcRn -> FixMap+mkFixMap group_ =+  M.fromList [ (n,f)+             | L _ (FixitySig _ ns f) <- hsGroupTopLevelFixitySigs group_,+               L _ n <- ns ]+++-- | Build the list of items that will become the documentation, from the+-- export list.  At this point, the list of ExportItems is in terms of+-- original names.+--+-- We create the export items even if the module is hidden, since they+-- might be useful when creating the export items for other modules.+mkExportItems+  :: MonadIO m+  => Bool               -- is it a signature+  -> IfaceMap+  -> Maybe Package      -- this package+  -> Module             -- this module+  -> Module             -- semantic module+  -> WarningMap+  -> GlobalRdrEnv+  -> [Name]             -- exported names (orig)+  -> [LHsDecl GhcRn]    -- renamed source declarations+  -> Maps+  -> FixMap+  -> M.Map ModuleName [ModuleName]+  -> [SrcSpan]          -- splice locations+  -> Maybe [(IE GhcRn, Avails)]+  -> Avails             -- exported stuff from this module+  -> InstIfaceMap+  -> DynFlags+  -> IfM m [ExportItem GhcRn]+mkExportItems+  is_sig modMap pkgName thisMod semMod warnings gre exportedNames decls+  maps fixMap unrestricted_imp_mods splices exportList allExports+  instIfaceMap dflags =+  case exportList of+    Nothing      -> do+      fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre+        exportedNames decls maps fixMap splices instIfaceMap dflags+        allExports+    Just exports -> fmap concat $ mapM lookupExport exports+  where+    lookupExport (IEGroup _ lev docStr, _) = do+      !doc <- force <$> processDocString dflags gre (hsDocString . unLoc $ docStr)+      return [ExportGroup lev "" doc]++    lookupExport (IEDoc _ docStr, _) = do+      !doc <- force <$> processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)+      return [ExportDoc doc]++    lookupExport (IEDocNamed _ str, _) =+      findNamedDoc str [ unL d | d <- decls ] >>= \case+        Nothing -> return  []+        Just docStr -> do+          !doc <- force <$> processDocStringParas dflags pkgName gre docStr+          return [ExportDoc doc]++    lookupExport (IEModuleContents _ (L _ mod_name), _)+      -- only consider exporting a module if we are sure we+      -- are really exporting the whole module and not some+      -- subset. We also look through module aliases here.+      | Just mods <- M.lookup mod_name unrestricted_imp_mods+      , not (null mods)+      = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods++    lookupExport (_, avails) = concat <$> traverse availExport (nubAvails avails)++    availExport avail =+      availExportItem is_sig modMap thisMod semMod warnings exportedNames+        maps fixMap splices instIfaceMap dflags avail+++-- Extract the minimal complete definition of a Name, if one exists+minimalDef :: Monad m => Name -> IfM m (Maybe ClassMinimalDef)+minimalDef n = do+  mty <- lookupName n+  case mty of+    Just (ATyCon (tyConClass_maybe -> Just c)) ->+      return . Just $ classMinimalDef c+    _ ->+      return Nothing+++availExportItem+  :: forall m+  .  MonadIO m+  => Bool               -- is it a signature+  -> IfaceMap+  -> Module             -- this module+  -> Module             -- semantic module+  -> WarningMap+  -> [Name]             -- exported names (orig)+  -> Maps+  -> FixMap+  -> [SrcSpan]          -- splice locations+  -> InstIfaceMap+  -> DynFlags+  -> AvailInfo+  -> IfM m [ExportItem GhcRn]+availExportItem is_sig modMap thisMod semMod warnings exportedNames+  (docMap, argMap, declMap, _) fixMap splices instIfaceMap+  dflags availInfo = declWith availInfo+  where+    declWith :: AvailInfo -> IfM m [ ExportItem GhcRn ]+    declWith avail = do+      let t = availName avail+      r    <- findDecl avail+      case r of+        (Just (EValD srcSpan), (doc, _)) -> do+          -- Since the DeclMapEntry is an 'EValD', we know the declaration is a+          -- top-level binding without a type signature. We get type information+          -- for the binding from the GHC interface file using the+          -- 'hiValExportItem' function+          export <- hiValExportItem dflags t srcSpan doc (srcSpan `elem` splices) $ M.lookup t fixMap+          return [export]++        (Just (EOther d), docs_) ->+          let declNames = getMainDeclBinder emptyOccEnv (unL d)+          in case () of+            _+              -- If 't' is not the main declaration binder, then it is a+              -- subordinate name in the declaration. If any of its parents are+              -- also exported, we do not want to show its documentation by+              -- itself. See note [1].+              | t `notElem` declNames,+                Just p <- find isExported (parents t $ unL d) -> do+                  warn $+                     "Warning: " ++ moduleString thisMod ++ ": " +++                     pretty dflags (nameOccName t) ++ " is exported separately but " +++                     "will be documented under " ++ pretty dflags (nameOccName p) +++                     ". Consider exporting it together with its parent(s)" +++                     " for code clarity."+                  return []++              -- normal case+              | otherwise -> case d of+                  -- A single signature might refer to many names, but we+                  -- create an export item for a single name only.  So we+                  -- modify the signature to contain only that single name.+                  L loc (SigD _ sig) ->+                    -- fromJust is safe since we already checked in guards+                    -- that 't' is a name declared in this declaration.+                    let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig+                    in availExportDecl avail newDecl docs_++                  L loc (TyClD _ ClassDecl {..}) -> do+                    mdef <- minimalDef t+                    let sig = maybeToList $ fmap (noLocA . MinimalSig (noAnn, NoSourceText) . noLocA . fmap noLocA) mdef+                    availExportDecl avail+                      (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_++                  _ -> availExportDecl avail d docs_++        -- Declaration from another package+        (Nothing, _) -> do+          mayDecl <- hiDecl dflags t+          case mayDecl of+            Nothing -> return [ ExportNoDecl t [] ]+            Just decl ->+              -- We try to get the subs and docs+              -- from the installed .haddock file for that package.+              -- TODO: This needs to be more sophisticated to deal+              -- with signature inheritance+              case M.lookup (nameModule t) instIfaceMap of+                Nothing -> do+                  warn $ "Warning: Couldn't find .haddock for export " ++ pretty dflags t+                  let subs_ = availNoDocs avail+                  availExportDecl avail decl (noDocForDecl, subs_)+                Just iface ->+                  availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface))++    -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails+    availDecl :: Name -> LHsDecl GhcRn -> IfM m (LHsDecl GhcRn)+    availDecl declName parentDecl =+      case extractDecl declMap declName parentDecl of+        Right d -> pure d+        Left err -> do+          synifiedDeclOpt <- hiDecl dflags declName+          case synifiedDeclOpt of+            Just synifiedDecl -> pure synifiedDecl+            Nothing -> pprPanic "availExportItem" (O.text err)++    availExportDecl :: AvailInfo -> LHsDecl GhcRn+                    -> (DocForDecl Name, [(Name, DocForDecl Name)])+                    -> IfM m [ ExportItem GhcRn ]+    availExportDecl avail decl (doc, subs)+      | availExportsDecl avail = do+          extractedDecl <- availDecl (availName avail) decl++          -- bundled pattern synonyms only make sense if the declaration is+          -- exported (otherwise there would be nothing to bundle to)+          bundledPatSyns <- findBundledPatterns avail++          let+            !patSynNames = force $+              concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns++            !doc'  = force doc+            !subs' = force subs++            !restrictToNames = force $ fmap fst subs'++            !fixities = force+                [ (n, f)+                | n <- availName avail : fmap fst subs' ++ patSynNames+                , Just f <- [M.lookup n fixMap]+                ]++          return+            [ ExportDecl ExportD+                { expDDecl      = restrictTo restrictToNames extractedDecl+                , expDPats      = bundledPatSyns+                , expDMbDoc     = doc'+                , expDSubDocs   = subs'+                , expDInstances = []+                , expDFixities  = fixities+                , expDSpliced   = False+                }+            ]++      | otherwise = for subs $ \(sub, sub_doc) -> do+          extractedDecl <- availDecl sub decl++          let+            !fixities = force [ (sub, f) | Just f <- [M.lookup sub fixMap] ]+            !subDoc   = force sub_doc++          return $+            ExportDecl ExportD+              { expDDecl      = extractedDecl+              , expDPats      = []+              , expDMbDoc     = subDoc+              , expDSubDocs   = []+              , expDInstances = []+              , expDFixities  = fixities+              , expDSpliced   = False+              }++    exportedNameSet = mkNameSet exportedNames+    isExported n = elemNameSet n exportedNameSet++    findDecl :: AvailInfo -> IfM m (Maybe DeclMapEntry, (DocForDecl Name, [(Name, DocForDecl Name)]))+    findDecl avail+      | m == semMod =+          case M.lookup n declMap of+            Just d -> return (Just d, lookupDocs avail warnings docMap argMap)+            Nothing+              | is_sig -> do+                -- OK, so it wasn't in the local declaration map.  It could+                -- have been inherited from a signature.  Reconstitute it+                -- from the type.+                mb_r <- hiDecl dflags n+                case mb_r of+                    Nothing -> return (Nothing, (noDocForDecl, availNoDocs avail))+                    -- TODO: If we try harder, we might be able to find+                    -- a Haddock!  Look in the Haddocks for each thing in+                    -- requirementContext (unitState)+                    Just decl -> return (Just $ toDeclMapEntry decl, (noDocForDecl, availNoDocs avail))+              | otherwise ->+                return (Nothing, (noDocForDecl, availNoDocs avail))+      | Just iface <- M.lookup (semToIdMod (moduleUnit thisMod) m) modMap+      , Just d <- M.lookup n (ifaceDeclMap iface) =+          return (Just d, lookupDocs avail warnings+                            (ifaceDocMap iface)+                            (ifaceArgMap iface))+      | otherwise = return (Nothing, (noDocForDecl, availNoDocs avail))+      where+        n = availName avail+        m = nameModule n++    findBundledPatterns :: AvailInfo -> IfM m [(HsDecl GhcRn, DocForDecl Name)]+    findBundledPatterns avail = do+      patsyns <- for constructor_names $ \name -> do+        mtyThing <- lookupName name+        case mtyThing of+          Just (AConLike PatSynCon{}) -> do+            export_items <- declWith (Avail.avail name)+            pure [ (unLoc patsyn_decl, patsyn_doc)+                 | ExportDecl ExportD+                     { expDDecl  = patsyn_decl+                     , expDMbDoc = patsyn_doc+                     } <- export_items+                 ]+          _ -> pure []+      pure (concat patsyns)+      where+        constructor_names =+          filter isDataConName (availSubordinates avail)++availSubordinates :: AvailInfo -> [Name]+availSubordinates = map greNameMangledName . availSubordinateGreNames++availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)]+availNoDocs avail =+  zip (availSubordinates avail) (repeat noDocForDecl)++-- | Given a 'Module' from a 'Name', convert it into a 'Module' that+-- we can actually find in the 'IfaceMap'.+semToIdMod :: Unit -> Module -> Module+semToIdMod this_uid m+    | Module.isHoleModule m = mkModule this_uid (moduleName m)+    | otherwise             = m++hiDecl :: MonadIO m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn))+hiDecl dflags t = do+  mayTyThing <- lookupName t+  case mayTyThing of+    Nothing -> do+      warn $ "Warning: Not found in environment: " ++ pretty dflags t+      return Nothing+    Just x -> case tyThingToLHsDecl ShowRuntimeRep x of+      Left m -> (warn $ bugWarn m) >> return Nothing+      Right (m, t') -> mapM (warn . bugWarn) m >> return (Just $ noLocA t')+    where+      warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>+                   O.comma O.<+> O.quotes (O.ppr t) O.<+>+                   O.text "-- Please report this on Haddock issue tracker!"+      bugWarn = showSDoc dflags . warnLine++-- | This function is called for top-level bindings without type signatures.+-- It gets the type signature from GHC and that means it's not going to+-- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the+-- declaration and use it instead - 'nLoc' here.+hiValExportItem+  :: MonadIO m => DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool+  -> Maybe Fixity -> IfM m (ExportItem GhcRn)+hiValExportItem dflags name nLoc doc splice fixity = do+  mayDecl <- hiDecl dflags name+  case mayDecl of+    Nothing -> return (ExportNoDecl name [])+    Just decl -> return (ExportDecl $ ExportD (fixSpan decl) [] doc [] [] fixities splice)+  where+    fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t+    fixities = case fixity of+      Just f  -> [(name, f)]+      Nothing -> []+++-- | Lookup docs for a declaration from maps.+lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name+           -> (DocForDecl Name, [(Name, DocForDecl Name)])+lookupDocs avail warningMap docMap argMap =+  let n = availName avail in+  let lookupArgDoc x = M.findWithDefault M.empty x argMap in+  let doc = (lookupDoc n, lookupArgDoc n) in+  let subDocs = [ (s, (lookupDoc s, lookupArgDoc s))+                | s <- availSubordinates avail+                ] in+  (doc, subDocs)+  where+    lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warningMap)+++-- | Export the given module as `ExportModule`. We are not concerned with the+-- single export items of the given module.+moduleExport+  :: MonadIO m+  => Module           -- ^ Module A (identity, NOT semantic)+  -> DynFlags         -- ^ The flags used when typechecking A+  -> IfaceMap         -- ^ Already created interfaces+  -> InstIfaceMap     -- ^ Interfaces in other packages+  -> ModuleName       -- ^ The exported module+  -> IfM m [ExportItem GhcRn] -- ^ Resulting export items+moduleExport thisMod dflags ifaceMap instIfaceMap expMod =+    -- NB: we constructed the identity module when looking up in+    -- the IfaceMap.+    case M.lookup m ifaceMap of+      Just iface+        | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)+        | otherwise -> return [ ExportModule m ]++      Nothing -> -- We have to try to find it in the installed interfaces+                 -- (external packages).+        case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of+          Just iface -> return [ ExportModule (instMod iface) ]+          Nothing -> do+            warn $+              "Warning: " ++ pretty dflags thisMod ++ ": Could not find " +++              "documentation for exported module: " ++ pretty dflags expMod+            return []+  where+    m = mkModule (moduleUnit thisMod) expMod -- Identity module!++-- Note [1]:+------------+-- It is unnecessary to document a subordinate by itself at the top level if+-- any of its parents is also documented. Furthermore, if the subordinate is a+-- record field or a class method, documenting it under its parent+-- indicates its special status.+--+-- A user might expect that it should show up separately, so we issue a+-- warning. It's a fine opportunity to also tell the user she might want to+-- export the subordinate through the parent export item for clarity.+--+-- The code removes top-level subordinates also when the parent is exported+-- through a 'module' export. I think that is fine.+--+-- (For more information, see Trac #69)+++-- | Simplified variant of 'mkExportItems', where we can assume that+-- every locally defined declaration is exported; thus, we just+-- zip through the renamed declarations.++fullModuleContents+  :: MonadIO m+  => Bool               -- is it a signature+  -> IfaceMap+  -> Maybe Package      -- this package+  -> Module             -- this module+  -> Module             -- semantic module+  -> WarningMap+  -> GlobalRdrEnv      -- ^ The renaming environment+  -> [Name]             -- exported names (orig)+  -> [LHsDecl GhcRn]    -- renamed source declarations+  -> Maps+  -> FixMap+  -> [SrcSpan]          -- splice locations+  -> InstIfaceMap+  -> DynFlags+  -> Avails+  -> IfM m [ExportItem GhcRn]+fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNames+  decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do+  let availEnv = availsToNameEnv (nubAvails avails)+  (concat . concat) `fmap` (for decls $ \decl -> do+    case decl of+      (L _ (DocD _ (DocGroup lev docStr))) -> do+        !doc <- force <$> processDocString dflags gre (hsDocString . unLoc $ docStr)+        return [[ExportGroup lev "" doc]]+      (L _ (DocD _ (DocCommentNamed _ docStr))) -> do+        !doc <- force <$> processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)+        return [[ExportDoc doc]]+      (L _ (ValD _ valDecl))+        | name:_ <- collectHsBindBinders CollNoDictBinders valDecl+        , Just (EOther (L _ SigD{})) <- M.lookup name declMap+        -> return []+      _ ->+        for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do+          case lookupNameEnv availEnv nm of+            Just avail ->+              availExportItem is_sig modMap thisMod+                semMod warnings exportedNames maps fixMap+                splices instIfaceMap dflags avail+            Nothing -> pure [])++-- | Sometimes the declaration we want to export is not the "main" declaration:+-- it might be an individual record selector or a class method.  In these+-- cases we have to extract the required declaration (and somehow cobble+-- together a type signature for it...).+--+-- This function looks through the declarations in this module to try to find+-- the one with the right name.+extractDecl+  :: HasCallStack+  => DeclMap                   -- ^ all declarations in the file+  -> Name                      -- ^ name of the declaration to extract+  -> LHsDecl GhcRn             -- ^ parent declaration+  -> Either String (LHsDecl GhcRn)+extractDecl declMap name decl+  | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl+  | otherwise  =+    case unLoc decl of+      TyClD _ d@ClassDecl { tcdLName = L _ clsNm+                          , tcdSigs = clsSigs+                          , tcdATs = clsATs } ->+        let+          matchesMethod =+            [ lsig+            | lsig <- clsSigs+            , ClassOpSig _ False _ _ <- pure $ unLoc lsig+              -- Note: exclude `default` declarations (see #505)+            , name `elem` sigName lsig+            ]++          matchesAssociatedType =+            [ lfam_decl+            | lfam_decl <- clsATs+            , name == unLoc (fdLName (unLoc lfam_decl))+            ]++            -- TODO: document fixity+        in case (matchesMethod, matchesAssociatedType)  of+          ([s0], _) -> let tyvar_names = tyClDeclTyVars d+                           L pos sig = addClassContext clsNm tyvar_names s0+                       in pure (L pos (SigD noExtField sig))+          (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl)))++          ([], [])+            | Just (EOther famInstDecl) <- M.lookup name declMap+            -> extractDecl declMap name famInstDecl+          _ -> Left (concat [ "Ambiguous decl for ", getOccString name+                            , " in class ", getOccString clsNm ])++      TyClD _ d@DataDecl { tcdLName = L _ dataNm+                         , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do+        let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d)+        lsig <- if isDataConName name+                  then extractPatternSyn name dataNm ty_args (toList dataCons)+                  else extractRecSel name dataNm ty_args (toList dataCons)+        pure (SigD noExtField <$> lsig)++      TyClD _ FamDecl {}+        | isValName name+        , Just (EOther famInst) <- M.lookup name declMap+        -> extractDecl declMap name famInst+      InstD _ (DataFamInstD _ (DataFamInstDecl+                            (FamEqn { feqn_tycon = L _ n+                                    , feqn_pats  = tys+                                    , feqn_rhs   = defn }))) ->+        if isDataConName name+        then fmap (SigD noExtField) <$> extractPatternSyn name n tys (toList $ dd_cons defn)+        else fmap (SigD noExtField) <$> extractRecSel name n tys (toList $ dd_cons defn)+      InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })+        | isDataConName name ->+            let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts+                               , name `elem` map unLoc (concatMap (toList . getConNames . unLoc) (dd_cons dd))+                               ]+            in case matches of+                [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))+                _    -> Left "internal: extractDecl (ClsInstD)"+        | otherwise ->+            let matches = [ d' | L _ d'@(DataFamInstDecl d )+                                   <- insts+                                 -- , L _ ConDecl { con_details = RecCon rec } <- toList $ dd_cons (feqn_rhs d)+                               , Just rec <- toList $ getRecConArgs_maybe . unLoc <$> dd_cons (feqn_rhs d)+                               , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)+                               , L _ n <- ns+                               , foExt n == name+                          ]+            in case matches of+              [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)+              _ -> Left "internal: extractDecl (ClsInstD)"+      _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name)++extractPatternSyn :: Name -> Name+                  -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]+                  -> Either String (LSig GhcRn)+extractPatternSyn nm t tvs cons =+  case filter matches cons of+    [] -> Left . O.showSDocOneLine O.defaultSDocContext $+          O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t+    con:_ -> pure (extract <$> con)+ where+  matches :: LConDecl GhcRn -> Bool+  matches (L _ con) = nm `elem` (unLoc <$> getConNames con)+  extract :: ConDecl GhcRn -> Sig GhcRn+  extract con =+    let args =+          case con of+            ConDeclH98 { con_args = con_args' } -> case con_args' of+              PrefixCon _ args' -> map hsScaledThing args'+              RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields+              InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]+            ConDeclGADT { con_g_args = con_args' } -> case con_args' of+              PrefixConGADT args' -> map hsScaledThing args'+              RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields+        typ = longArrow args (data_ty con)+        typ' =+          case con of+            ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ)+            _ -> typ+        typ'' = noLocA (HsQualTy noExtField (noLocA []) typ')+    in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')++  longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn+  longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs++  data_ty con+    | ConDeclGADT{} <- con = con_res_ty con+    | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs+                    where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn+                          mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty+                          mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki+                          mkAppTyArg f (HsArgPar _) = HsParTy noAnn f++extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]+              -> Either String (LSig GhcRn)+extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"++extractRecSel nm t tvs (L _ con : rest) =+  case getRecConArgs_maybe con of+    Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->+      pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty))))))+    _ -> extractRecSel nm t tvs rest+ where+  matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]+  matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds+                                      , L l n <- ns, foExt n == nm ]+  data_ty+    -- ResTyGADT _ ty <- con_res con = ty+    | ConDeclGADT{} <- con = con_res_ty con+    | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs+                   where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn+                         mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty+                         mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki+                         mkAppTyArg f (HsArgPar _) = HsParTy noAnn f++-- | Keep export items with docs.+pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]+pruneExportItems = filter hasDoc+  where+    hasDoc (ExportDecl ExportD {expDMbDoc = (Documentation d _, _)}) = isJust d+    hasDoc _ = True+++mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name]+mkVisibleNames (_, _, _, instMap) exports opts+  | OptHide `elem` opts = []+  | otherwise = let ns = concatMap exportName exports+                in seqList ns `seq` ns+  where+    exportName (ExportDecl e@ExportD{}) = name ++ subs ++ patsyns+      where subs    = map fst (expDSubDocs e)+            patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expDPats e)+            name = case unLoc $ expDDecl e of+              InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap+              decl      -> getMainDeclBinder emptyOccEnv decl+    exportName ExportNoDecl {} = [] -- we don't count these as visible, since+                                    -- we don't want links to go to them.+    exportName _ = []++seqList :: [a] -> ()+seqList [] = ()+seqList (x : xs) = x `seq` seqList xs++-- | Find a stand-alone documentation comment by its name.+findNamedDoc :: MonadIO m => String -> [HsDecl GhcRn] -> IfM m (Maybe HsDocString)+findNamedDoc name = search+  where+    search [] = do+      -- TODO: Make sure this isn't duplicating messages+      warn $ "Cannot find documentation for: $" ++ name+      return Nothing+    search (DocD _ (DocCommentNamed name' doc) : rest)+      | name == name' = return (Just (hsDocString . unLoc $ doc))+       | otherwise = search rest     search (_other_decl : rest) = search rest
+ src/Haddock/Interface/Json.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE RecordWildCards #-}+module Haddock.Interface.Json (+    jsonInstalledInterface+  , jsonInterfaceFile+  , renderJson+  ) where++import GHC.Types.Fixity+import GHC.Utils.Json+import GHC.Unit.Module+import GHC.Types.Name+import GHC.Utils.Outputable++import Control.Arrow+import Data.Map (Map)+import qualified Data.Map as Map++import Haddock.Types+import Haddock.InterfaceFile++jsonInterfaceFile :: InterfaceFile -> JsonDoc+jsonInterfaceFile InterfaceFile{..} =+  jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv)+             , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces))+             ]++jsonInstalledInterface :: InstalledInterface -> JsonDoc+jsonInstalledInterface InstalledInterface{..} = jsonObject properties+  where+    properties =+      [ ("module"          , jsonModule instMod)+      , ("is_sig"          , jsonBool instIsSig)+      , ("info"            , jsonHaddockModInfo instInfo)+      , ("doc_map"         , jsonMap nameStableString jsonMDoc instDocMap)+      , ("arg_map"         , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap)+      , ("exports"         , jsonArray (map jsonName instExports))+      , ("visible_exports" , jsonArray (map jsonName instVisibleExports))+      , ("options"         , jsonArray (map (jsonString . show) instOptions))+      , ("fix_map"         , jsonMap nameStableString jsonFixity instFixMap)+      ]++jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc+jsonHaddockModInfo HaddockModInfo{..} =+  jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description)+             , ("copyright"   , jsonMaybe jsonString hmi_copyright)+             , ("maintainer"  , jsonMaybe jsonString hmi_maintainer)+             , ("stability"   , jsonMaybe jsonString hmi_stability)+             , ("protability" , jsonMaybe jsonString hmi_portability)+             , ("safety"      , jsonMaybe jsonString hmi_safety)+             , ("language"    , jsonMaybe (jsonString . show) hmi_language)+             , ("extensions"  , jsonArray (map (jsonString . show) hmi_extensions))+             ]++jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc+jsonMap f g = jsonObject . map (f *** g) . Map.toList++jsonMDoc :: MDoc Name -> JsonDoc+jsonMDoc MetaDoc{..} =+  jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))])+             , ("document",  jsonDoc _doc)+             ]++showModName :: Wrap (ModuleName, OccName) -> String+showModName = showWrapped (moduleNameString . fst)++showName :: Wrap Name -> String+showName = showWrapped nameStableString+++jsonDoc :: Doc Name -> JsonDoc++jsonDoc DocEmpty = jsonObject+    [ ("tag", jsonString "DocEmpty") ]++jsonDoc (DocAppend x y) = jsonObject+    [ ("tag", jsonString "DocAppend")+    , ("first", jsonDoc x)+    , ("second", jsonDoc y)+    ]++jsonDoc (DocString s) = jsonObject+    [ ("tag", jsonString "DocString")+    , ("string", jsonString s)+    ]++jsonDoc (DocParagraph x) = jsonObject+    [ ("tag", jsonString "DocParagraph")+    , ("document", jsonDoc x)+    ]++jsonDoc (DocIdentifier name) = jsonObject+    [ ("tag", jsonString "DocIdentifier")+    , ("name", jsonString (showName name))+    ]++jsonDoc (DocIdentifierUnchecked modName) = jsonObject+    [ ("tag", jsonString "DocIdentifierUnchecked")+    , ("modName", jsonString (showModName modName))+    ]++jsonDoc (DocModule (ModLink m _l)) = jsonObject+    [ ("tag", jsonString "DocModule")+    , ("string", jsonString m)+    ]++jsonDoc (DocWarning x) = jsonObject+    [ ("tag", jsonString "DocWarning")+    , ("document", jsonDoc x)+    ]++jsonDoc (DocEmphasis x) = jsonObject+    [ ("tag", jsonString "DocEmphasis")+    , ("document", jsonDoc x)+    ]++jsonDoc (DocMonospaced x) = jsonObject+    [ ("tag", jsonString "DocMonospaced")+    , ("document", jsonDoc x)+    ]++jsonDoc (DocBold x) = jsonObject+    [ ("tag", jsonString "DocBold")+    , ("document", jsonDoc x)+    ]++jsonDoc (DocUnorderedList xs) = jsonObject+    [ ("tag", jsonString "DocUnorderedList")+    , ("documents", jsonArray (fmap jsonDoc xs))+    ]++jsonDoc (DocOrderedList xs) = jsonObject+    [ ("tag", jsonString "DocOrderedList")+    , ("items", jsonArray (fmap jsonItem xs))+    ]+  where+    jsonItem (index, a) = jsonObject [("document", jsonDoc a), ("seq", jsonInt index)]++jsonDoc (DocDefList xys) = jsonObject+    [ ("tag", jsonString "DocDefList")+    , ("definitions", jsonArray (fmap jsonDef xys))+    ]+  where+    jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)]++jsonDoc (DocCodeBlock x) = jsonObject+    [ ("tag", jsonString "DocCodeBlock")+    , ("document", jsonDoc x)+    ]++jsonDoc (DocHyperlink hyperlink) = jsonObject+    [ ("tag", jsonString "DocHyperlink")+    , ("hyperlink", jsonHyperlink hyperlink)+    ]+  where+    jsonHyperlink Hyperlink{..} = jsonObject+        [ ("hyperlinkUrl", jsonString hyperlinkUrl)+        , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel)+        ]++jsonDoc (DocPic picture) = jsonObject+    [ ("tag", jsonString "DocPic")+    , ("picture", jsonPicture picture)+    ]+  where+    jsonPicture Picture{..} = jsonObject+        [ ("pictureUrl", jsonString pictureUri)+        , ("pictureLabel", jsonMaybe jsonString pictureTitle)+        ]++jsonDoc (DocMathInline s) = jsonObject+    [ ("tag", jsonString "DocMathInline")+    , ("string", jsonString s)+    ]++jsonDoc (DocMathDisplay s) = jsonObject+    [ ("tag", jsonString "DocMathDisplay")+    , ("string", jsonString s)+    ]++jsonDoc (DocAName s) = jsonObject+    [ ("tag", jsonString "DocAName")+    , ("string", jsonString s)+    ]++jsonDoc (DocProperty s) = jsonObject+    [ ("tag", jsonString "DocProperty")+    , ("string", jsonString s)+    ]++jsonDoc (DocExamples examples) = jsonObject+    [ ("tag", jsonString "DocExamples")+    , ("examples", jsonArray (fmap jsonExample examples))+    ]+  where+    jsonExample Example{..} = jsonObject+        [ ("exampleExpression", jsonString exampleExpression)+        , ("exampleResult", jsonArray (fmap jsonString exampleResult))+        ]++jsonDoc (DocHeader header) = jsonObject+    [ ("tag", jsonString "DocHeader")+    , ("header", jsonHeader header)+    ]+  where+    jsonHeader Header{..} = jsonObject+        [ ("headerLevel", jsonInt headerLevel)+        , ("headerTitle", jsonDoc headerTitle)+        ]++jsonDoc (DocTable table) = jsonObject+    [ ("tag", jsonString "DocTable")+    , ("table", jsonTable table)+    ]+  where+    jsonTable Table{..} = jsonObject+        [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows))+        , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows))+        ]++    jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells)++    jsonTableCell TableCell{..} = jsonObject+        [ ("tableCellColspan", jsonInt tableCellColspan)+        , ("tableCellRowspan", jsonInt tableCellRowspan)+        , ("tableCellContents", jsonDoc tableCellContents)+        ]+++jsonModule :: Module -> JsonDoc+jsonModule = JSString . moduleStableString++jsonName :: Name -> JsonDoc+jsonName = JSString . nameStableString++jsonFixity :: Fixity -> JsonDoc+jsonFixity (Fixity _ prec dir) =+  jsonObject [ ("prec"      , jsonInt prec)+             , ("direction" , jsonFixityDirection dir)+             ]++jsonFixityDirection :: FixityDirection -> JsonDoc+jsonFixityDirection InfixL = jsonString "infixl"+jsonFixityDirection InfixR = jsonString "infixr"+jsonFixityDirection InfixN = jsonString "infix"++renderJson :: JsonDoc -> SDoc+renderJson = renderJSON++jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc+jsonMaybe = maybe jsonNull++jsonString :: String -> JsonDoc+jsonString = JSString++jsonObject :: [(String, JsonDoc)] -> JsonDoc+jsonObject = JSObject++jsonArray :: [JsonDoc] -> JsonDoc+jsonArray = JSArray++jsonNull :: JsonDoc+jsonNull = JSNull++jsonInt :: Int -> JsonDoc+jsonInt = JSInt++jsonBool :: Bool -> JsonDoc+jsonBool = JSBool
src/Haddock/Interface/LexParseRn.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns     #-} {-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE BangPatterns #-}   ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface.LexParseRn@@ -13,68 +15,117 @@ ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn   ( processDocString+  , processDocStringFromString   , processDocStringParas   , processDocStrings   , processModuleHeader   ) where -import Data.IntSet (toList)-import Data.List+import Control.Arrow+import Control.Monad+import Control.Monad.State.Strict+import Data.Functor+import Data.List ((\\), maximumBy)+import Data.Ord+import qualified Data.Set as Set import Documentation.Haddock.Doc (metaDocConcat)-import DynFlags (languageExtensions)+import GHC.Driver.Session (languageExtensions) import qualified GHC.LanguageExtensions as LangExt-import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser import Haddock.Types-import Name-import Outputable ( showPpr )-import RdrName-import RnEnv (dataTcOccs)+import GHC.Data.EnumSet as EnumSet+import GHC.Driver.Ppr ( showPpr, showSDoc )+import GHC.Parser.PostProcess+import GHC.Types.Name+import GHC.Types.Avail ( availName )+import GHC.Types.Name.Reader+import GHC.Utils.Outputable (Outputable) -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]-                  -> Maybe (MDoc Name)-processDocStrings dflags gre strs =-  case metaDocConcat $ map (processDocStringParas dflags gre) strs of+processDocStrings+  :: MonadIO m+  => DynFlags+  -> Maybe Package+  -> GlobalRdrEnv+  -> [HsDocString]+  -> IfM m (Maybe (MDoc Name))+processDocStrings dflags pkg gre strs = do+  mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags pkg gre) strs+  case mdoc of     -- We check that we don't have any version info to render instead     -- of just checking if there is no comment: there may not be a     -- comment but we still want to pass through any meta data.-    MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing-    x -> Just x+    MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing+    x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name-processDocStringParas dflags gre (HsDocString fs) =-  overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)+processDocStringParas+  :: MonadIO m+  => DynFlags+  -> Maybe Package+  -> GlobalRdrEnv+  -> HsDocString+  -> IfM m (MDoc Name)+processDocStringParas dflags pkg gre hds =+    overDocF (rename dflags gre) (parseParas dflags pkg (renderHsDocString hds)) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name-processDocString dflags gre (HsDocString fs) =-  rename dflags gre $ parseString dflags (unpackFS fs)+processDocString+  :: MonadIO m+  => DynFlags+  -> GlobalRdrEnv+  -> HsDocString+  -> IfM m (Doc Name)+processDocString dflags gre hds =+    processDocStringFromString dflags gre (renderHsDocString hds) -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString-                    -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name))-processModuleHeader dflags gre safety mayStr = do+processDocStringFromString+  :: MonadIO m+  => DynFlags+  -> GlobalRdrEnv+  -> String+  -> IfM m (Doc Name)+processDocStringFromString dflags gre hds =+    rename dflags gre (parseString dflags hds)++processModuleHeader+  :: MonadIO m+  => DynFlags+  -> Maybe Package+  -> GlobalRdrEnv+  -> SafeHaskellMode+  -> Maybe HsDocString+  -> IfM m (HaddockModInfo Name, Maybe (MDoc Name))+processModuleHeader dflags pkgName gre safety mayStr = do   (hmi, doc) <-     case mayStr of       Nothing -> return failure-      Just (L _ (HsDocString fs)) -> do-        let str = unpackFS fs-            (hmi, doc) = parseModuleHeader dflags str-            !descr = rename dflags gre <$> hmi_description hmi-            hmi' = hmi { hmi_description = descr }-            doc' = overDoc (rename dflags gre) doc+      Just hds -> do+        let str = renderHsDocString hds+            (hmi, doc) = parseModuleHeader dflags pkgName str+        !descr <- case hmi_description hmi of+                    Just hmi_descr -> Just <$> rename dflags gre hmi_descr+                    Nothing        -> pure Nothing+        let hmi' = hmi { hmi_description = descr }+        doc'  <- overDocF (rename dflags gre) doc         return (hmi', Just doc')    let flags :: [LangExt.Extension]       -- We remove the flags implied by the language setting and we display the language instead-      flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)-  return (hmi { hmi_safety = Just $ showPpr dflags safety-              , hmi_language = language dflags-              , hmi_extensions = flags-              } , doc)+      flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)+  return+    (hmi { hmi_safety = Just $ showPpr dflags safety+         , hmi_language = language dflags+         , hmi_extensions = flags+         }+    , doc+    )   where     failure = (emptyHaddockModInfo, Nothing) +traverseSnd :: (Traversable t, Applicative f) => (a -> f b) -> t (x, a) -> f (t (x, b))+traverseSnd f = traverse (\(x, a) ->+                             (\b -> (x, b)) <$> f a)+ -- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the -- definitions and a parsed comment and we attempt to make sense of -- where the identifiers in the comment point to. We're in effect@@ -82,25 +133,45 @@ -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary.-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name+rename+  :: MonadIO m+  => DynFlags+  -> GlobalRdrEnv+  -> Doc NsRdrName+  -> IfM m (Doc Name) rename dflags gre = rn   where+    rn :: MonadIO m => Doc NsRdrName -> IfM m (Doc Name)     rn d = case d of-      DocAppend a b -> DocAppend (rn a) (rn b)-      DocParagraph doc -> DocParagraph (rn doc)-      DocIdentifier x -> do+      DocAppend a b -> DocAppend <$> rn a <*> rn b+      DocParagraph p -> DocParagraph <$> rn p+      DocIdentifier i -> do+        let NsRdrName ns x = unwrap i+            occ = rdrNameOcc x+            isValueName = isDataOcc occ || isVarOcc occ++        let valueNsChoices | isValueName = [x]+                           | otherwise   = [] -- is this ever possible?+            typeNsChoices  | isValueName = [setRdrNameSpace x tcName]+                           | otherwise   = [x]+         -- Generate the choices for the possible kind of thing this-        -- is.-        let choices = dataTcOccs x-        -- Try to look up all the names in the GlobalRdrEnv that match-        -- the names.-        let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices+        -- is. We narrow down the possibilities with the namespace (if+        -- there is one).+        let choices = case ns of+                        Value -> valueNsChoices+                        Type  -> typeNsChoices+                        None  -> valueNsChoices ++ typeNsChoices -        case names of+        -- Lookup any GlobalRdrElts that match the choices.+        case concatMap (\c -> lookupGRE_RdrName c gre) choices of           -- We found no names in the env so we start guessing.           [] ->             case choices of-              [] -> DocMonospaced (DocString (showPpr dflags x))+              -- The only way this can happen is if a value namespace was+              -- specified on something that cannot be a value.+              [] -> invalidValue dflags i+               -- There was nothing in the environment so we need to               -- pick some default from what's available to us. We               -- diverge here from the old way where we would default@@ -109,52 +180,133 @@               -- type constructor names (such as in #253). So now we               -- only get type constructor links if they are actually               -- in scope.-              a:_ -> outOfScope dflags a+              a:_ -> outOfScope dflags ns (i $> a)            -- There is only one name in the environment that matches so           -- use it.-          [a] -> DocIdentifier a-          -- But when there are multiple names available, default to-          -- type constructors: somewhat awfully GHC returns the-          -- values in the list positionally.-          a:b:_ | isTyConName a -> DocIdentifier a-                | otherwise -> DocIdentifier b+          [a] -> pure $ DocIdentifier (i $> greMangledName a) -      DocWarning doc -> DocWarning (rn doc)-      DocEmphasis doc -> DocEmphasis (rn doc)-      DocBold doc -> DocBold (rn doc)-      DocMonospaced doc -> DocMonospaced (rn doc)-      DocUnorderedList docs -> DocUnorderedList (map rn docs)-      DocOrderedList docs -> DocOrderedList (map rn docs)-      DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]-      DocCodeBlock doc -> DocCodeBlock (rn doc)-      DocIdentifierUnchecked x -> DocIdentifierUnchecked x-      DocModule str -> DocModule str-      DocHyperlink l -> DocHyperlink l-      DocPic str -> DocPic str-      DocMathInline str -> DocMathInline str-      DocMathDisplay str -> DocMathDisplay str-      DocAName str -> DocAName str-      DocProperty p -> DocProperty p-      DocExamples e -> DocExamples e-      DocEmpty -> DocEmpty-      DocString str -> DocString str-      DocHeader (Header l t) -> DocHeader $ Header l (rn t)+          -- There are multiple names available.+          gres -> ambiguous dflags i gres +      DocWarning dw -> DocWarning <$> rn dw+      DocEmphasis de -> DocEmphasis <$> rn de+      DocBold db -> DocBold <$> rn db+      DocMonospaced dm -> DocMonospaced <$> rn dm+      DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs+      DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs+      DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list+      DocCodeBlock dcb -> DocCodeBlock <$> rn dcb+      DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)+      DocModule (ModLink m l) -> DocModule . ModLink m <$> traverse rn l+      DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l+      DocPic str -> pure (DocPic str)+      DocMathInline str -> pure (DocMathInline str)+      DocMathDisplay str -> pure (DocMathDisplay str)+      DocAName str -> pure (DocAName str)+      DocProperty p -> pure (DocProperty p)+      DocExamples e -> pure (DocExamples e)+      DocEmpty -> pure (DocEmpty)+      DocString str -> pure (DocString str)+      DocHeader (Header l t) -> DocHeader . Header l <$> rn t+      DocTable t -> DocTable <$> traverse rn t+ -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently -- we simply monospace the identifier in most cases except when the -- identifier is qualified: if the identifier is qualified then we can--- still try to guess and generate anchors accross modules but the+-- still try to guess and generate anchors across modules but the -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'.-outOfScope :: DynFlags -> RdrName -> Doc a-outOfScope dflags x =-  case x of-    Unqual occ -> monospaced occ-    Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)-    Orig _ occ -> monospaced occ-    Exact name -> monospaced name  -- Shouldn't happen since x is out of scope+outOfScope :: MonadIO m => DynFlags -> Namespace -> Wrap RdrName -> IfM m (Doc a)+outOfScope dflags ns x =+    case unwrap x of+      Unqual occ -> warnAndMonospace (x $> occ)+      Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ)))+      Orig _ occ -> warnAndMonospace (x $> occ)+      Exact name -> warnAndMonospace (x $> name)  -- Shouldn't happen since x is out of scope   where-    monospaced a = DocMonospaced (DocString (showPpr dflags a))+    prefix =+      case ns of+        Value -> "the value "+        Type -> "the type "+        None -> ""++    warnAndMonospace :: (MonadIO m, Outputable a) => Wrap a -> IfM m (DocH mod id)+    warnAndMonospace a = do+      let a' = showWrapped (showPpr dflags) a++      -- If we have already warned for this identifier, don't warn again+      firstWarn <- Set.notMember a' <$> gets ifeOutOfScopeNames+      when firstWarn $ do+        warn $+          "Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" +++          "    If you qualify the identifier, haddock can try to link it anyway."+        modify' (\env -> env { ifeOutOfScopeNames = Set.insert a' (ifeOutOfScopeNames env) })++      pure (monospaced a')+    monospaced = DocMonospaced . DocString++-- | Handle ambiguous identifiers.+--+-- Prefers local names primarily and type constructors or class names secondarily.+--+-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class.+ambiguous+  :: MonadIO m+  => DynFlags+  -> Wrap NsRdrName+  -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.+  -> IfM m (Doc Name)+ambiguous dflags x gres = do+    let noChildren = map availName (gresToAvailInfo gres)+        dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren+        nameStr = showNsRdrName dflags x+        msg = "Warning: " ++ nameStr ++ " is ambiguous. It is defined\n" +++              concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map greMangledName gres) +++              "    You may be able to disambiguate the identifier by qualifying it or\n" +++              "    by specifying the type/value namespace explicitly.\n" +++              "    Defaulting to the one defined " ++ defnLoc dflt++    -- TODO: Once we have a syntax for namespace qualification (#667) we may also+    -- want to emit a warning when an identifier is a data constructor for a type+    -- of the same name, but not the only constructor.+    -- For example, for @data D = C | D@, someone may want to reference the @D@+    -- constructor.++    -- If we have already warned for this name, do not warn again+    firstWarn <- Set.notMember nameStr <$> gets ifeAmbiguousNames+    when (length noChildren > 1 && firstWarn) $ do+      warn msg+      modify' (\env -> env { ifeAmbiguousNames = Set.insert nameStr (ifeAmbiguousNames env) })++    pure (DocIdentifier (x $> dflt))+  where+    isLocalName (nameSrcLoc -> RealSrcLoc {}) = True+    isLocalName _ = False+    defnLoc = showSDoc dflags . pprNameDefnLoc++-- | Handle value-namespaced names that cannot be for values.+--+-- Emits a warning that the value-namespace is invalid on a non-value identifier.+invalidValue :: MonadIO m => DynFlags -> Wrap NsRdrName -> IfM m (Doc a)+invalidValue dflags x = do+    let nameStr = showNsRdrName dflags x++    -- If we have already warned for this name, do not warn again+    firstWarn <- Set.notMember nameStr <$> gets ifeInvalidValues+    when firstWarn $ do+      warn $+        "Warning: " ++ nameStr ++ " cannot be value, yet it is\n" +++        "    namespaced as such. Did you mean to specify a type namespace\n" +++        "    instead?"+      modify' (\env -> env { ifeInvalidValues = Set.insert nameStr (ifeInvalidValues env) })+    pure (DocMonospaced (DocString (showNsRdrName dflags x)))++-- | Printable representation of a wrapped and namespaced name+showNsRdrName :: DynFlags -> Wrap NsRdrName -> String+showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident+  where+    ident = showWrapped (showPpr dflags . rdrName)+    prefix = renderNs . namespace . unwrap
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE DeriveFunctor #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface.ParseModuleHeader@@ -11,12 +13,12 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus)+import Control.Applicative (Alternative (..))+import Control.Monad (ap) import Data.Char-import DynFlags+import GHC.Driver.Session import Haddock.Parser import Haddock.Types-import RdrName  -- ----------------------------------------------------------------------------- -- Parsing module headers@@ -24,36 +26,47 @@ -- NB.  The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted.-parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName)-parseModuleHeader dflags str0 =+parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName)+parseModuleHeader dflags pkgName str0 =    let-      getKey :: String -> String -> (Maybe String,String)-      getKey key str = case parseKey key str of-         Nothing -> (Nothing,str)-         Just (value,rest) -> (Just value,rest)+      kvs :: [(String, String)]+      str1 :: String -      (_moduleOpt,str1) = getKey "Module" str0-      (descriptionOpt,str2) = getKey "Description" str1-      (copyrightOpt,str3) = getKey "Copyright" str2-      (licenseOpt,str4) = getKey "License" str3-      (licenceOpt,str5) = getKey "Licence" str4-      (maintainerOpt,str6) = getKey "Maintainer" str5-      (stabilityOpt,str7) = getKey "Stability" str6-      (portabilityOpt,str8) = getKey "Portability" str7+      (kvs, str1) = maybe ([], str0) id $ runP fields str0 +      -- trim whitespaces+      trim :: String -> String+      trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse++      getKey :: String -> Maybe String+      getKey key = fmap trim (lookup key kvs)++      descriptionOpt = getKey "Description"+      copyrightOpt   = getKey "Copyright"+      licenseOpt     = getKey "License"+      licenceOpt     = getKey "Licence"+      spdxLicenceOpt = getKey "SPDX-License-Identifier"+      maintainerOpt  = getKey "Maintainer"+      stabilityOpt   = getKey "Stability"+      portabilityOpt = getKey "Portability"+    in (HaddockModInfo {           hmi_description = parseString dflags <$> descriptionOpt,           hmi_copyright = copyrightOpt,-          hmi_license = licenseOpt `mplus` licenceOpt,+          hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt,           hmi_maintainer = maintainerOpt,           hmi_stability = stabilityOpt,           hmi_portability = portabilityOpt,           hmi_safety = Nothing,           hmi_language = Nothing, -- set in LexParseRn           hmi_extensions = [] -- also set in LexParseRn-          }, parseParas dflags str8)+          }, parseParas dflags pkgName str1) --- | This function is how we read keys.+-------------------------------------------------------------------------------+-- Small parser to parse module header.+-------------------------------------------------------------------------------++-- | The below is a small parser framework how we read keys. -- -- all fields in the header are optional and have the form --@@ -72,78 +85,105 @@ -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment".-parseKey :: String -> String -> Maybe (String,String)-parseKey key toParse0 =-   do-      let-         (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) -         indentation = spaces0-      afterKey0 <- extractPrefix key toParse1-      let-         afterKey1 = extractLeadingSpaces afterKey0-      afterColon0 <- case snd afterKey1 of-         ':':afterColon -> return afterColon-         _ -> Nothing-      let-         (_,afterColon1) = extractLeadingSpaces afterColon0+-- | 'C' is a 'Char' carrying its column.+--+-- This let us make an indentation-aware parser, as we know current indentation.+-- by looking at the next character in the stream ('curInd').+--+-- Thus we can munch all spaces but only not-spaces which are indented.+--+data C = C {-# UNPACK #-} !Int Char -      return (scanKey True indentation afterColon1)-   where-      scanKey :: Bool -> String -> String -> (String,String)-      scanKey _       _           [] = ([],[])-      scanKey isFirst indentation str =-         let-            (nextLine,rest1) = extractNextLine str+newtype P a = P { unP :: [C] -> Maybe ([C], a) }+  deriving Functor -            accept = isFirst || sufficientIndentation || allSpaces+instance Applicative P where+    pure x = P $ \s -> Just (s, x)+    (<*>)  = ap -            sufficientIndentation = case extractPrefix indentation nextLine of-               Just (c:_) | isSpace c -> True-               _ -> False+instance Monad P where+    return = pure+    m >>= k = P $ \s0 -> do+        (s1, x) <- unP m s0+        unP (k x) s1 -            allSpaces = case extractLeadingSpaces nextLine of-               (_,[]) -> True-               _ -> False-         in-            if accept-               then-                  let-                     (scanned1,rest2) = scanKey False indentation rest1+instance Alternative P where+    empty   = P $ \_ -> Nothing+    a <|> b = P $ \s -> unP a s <|> unP b s -                     scanned2 = case scanned1 of-                        "" -> if allSpaces then "" else nextLine-                        _ -> nextLine ++ "\n" ++ scanned1-                  in-                     (scanned2,rest2)-               else-                  ([],str)+runP :: P a -> String -> Maybe a+runP p input = fmap snd (unP p input')+  where+    input' = concat+        [ zipWith C [0..] l ++ [C (length l) '\n']+        | l <- lines input+        ] -      extractLeadingSpaces :: String -> (String,String)-      extractLeadingSpaces [] = ([],[])-      extractLeadingSpaces (s@(c:cs))-         | isSpace c =-            let-               (spaces1,cs1) = extractLeadingSpaces cs-            in-               (c:spaces1,cs1)-         | otherwise = ([],s)+-------------------------------------------------------------------------------+--+------------------------------------------------------------------------------- -      extractNextLine :: String -> (String,String)-      extractNextLine [] = ([],[])-      extractNextLine (c:cs)-         | c == '\n' =-            ([],cs)-         | otherwise =-            let-               (line,rest) = extractNextLine cs-            in-               (c:line,rest)+curInd :: P Int+curInd = P $ \s -> Just . (,) s $ case s of+    []        -> 0+    C i _ : _ -> i -      -- comparison is case-insensitive.-      extractPrefix :: String -> String -> Maybe String-      extractPrefix [] s = Just s-      extractPrefix _ [] = Nothing-      extractPrefix (c1:cs1) (c2:cs2)-         | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2-         | otherwise = Nothing+rest :: P String+rest = P $ \cs -> Just ([], [ c | C _ c <- cs ])++munch :: (Int -> Char -> Bool) -> P String+munch p = P $ \cs ->+    let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs)+  where+    p' (C i c)+        | p i c  = Just c+        | otherwise = Nothing++munch1 :: (Int -> Char -> Bool) -> P String+munch1 p = P $ \s -> case s of+    [] -> Nothing+    (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs)+           | otherwise -> Nothing+  where+    p' (C i c)+        | p i c  = Just c+        | otherwise = Nothing++char :: Char -> P Char+char c = P $ \s -> case s of+    []                        -> Nothing+    (C _ c' : cs) | c == c'   -> Just (cs, c)+                  | otherwise -> Nothing++skipSpaces :: P ()+skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ())++takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])+takeWhileMaybe f = go where+    go xs0@[] = ([], xs0)+    go xs0@(x:xs) = case f x of+        Just y  -> let (ys, zs) = go xs in (y : ys, zs)+        Nothing -> ([], xs0)++-------------------------------------------------------------------------------+-- Fields+-------------------------------------------------------------------------------++field :: Int -> P (String, String)+field i = do+    fn <- munch1 $ \_ c -> isAlpha c || c == '-'+    skipSpaces+    _ <- char ':'+    skipSpaces+    val <- munch $ \j c -> isSpace c || j > i+    return (fn, val)++fields :: P ([(String, String)], String)+fields = do+    skipSpaces+    i  <- curInd+    fs <- many (field i)+    r  <- rest+    return (fs, r)+
src/Haddock/Interface/Rename.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ ---------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface.Rename@@ -15,285 +20,437 @@  import Data.Traversable (mapM) +import Haddock.Backends.Hoogle (ppExportD) import Haddock.GhcUtils import Haddock.Types -import Bag (emptyBag)+import GHC.Data.Bag (emptyBag) import GHC hiding (NoLink)-import Name+import GHC.Types.Name+import GHC.Types.Name.Reader (RdrName(Exact))+import GHC.Builtin.Types (eqTyCon_RDR)  import Control.Applicative+import Control.DeepSeq (force) import Control.Monad hiding (mapM)-import Data.List-import qualified Data.Map as Map hiding ( Map )+import Control.Monad.Reader+import Control.Monad.Writer.CPS+import Data.Foldable (traverse_)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set import Prelude hiding (mapM)---renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface-renameInterface dflags renamingEnv warnings iface =--  -- first create the local env, where every name exported by this module-  -- is mapped to itself, and everything else comes from the global renaming-  -- env-  let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)-        where fn env name = Map.insert name (ifaceMod iface) env--      -- rename names in the exported declarations to point to things that-      -- are closer to, or maybe even exported by, the current module.-      (renamedExportItems, missingNames1)-        = runRnFM localEnv (renameExportItems (ifaceExportItems iface))--      (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))+import GHC.Types.Basic ( TopLevelFlag(..) ) -      (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))+-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to+-- 'DocName'.+--+-- What this really boils down to is: for each 'Name', figure out which of the+-- modules that export the name is the preferred place to link to.+--+-- The renamed output gets written into fields in the Haddock interface record+-- that were previously left empty.+renameInterface+  :: DynFlags+  -- ^ GHC session dyn flags+  -> Map.Map (Maybe String) (Set.Set String)+  -- ^ Ignored symbols. A map from module names to unqualified names. Module+  -- 'Just M' mapping to name 'f' means that link warnings should not be+  -- generated for occurances of specifically 'M.f'. Module 'Nothing' mapping to+  -- name 'f' means that link warnings should not be generated for any 'f'.+  -> LinkEnv+  -- ^ Link environment. A map from 'Name' to 'Module', where name 'n' maps to+  -- module 'M' if 'M' is the preferred link destination for name 'n'.+  -> Bool+  -- ^ Are warnings enabled?+  -> Bool+  -- ^ Is Hoogle output enabled?+  -> Interface+  -- ^ The interface we are renaming.+  -> Ghc Interface+  -- ^ The renamed interface. Note that there is nothing really special about+  -- this being in the 'Ghc' monad. This could very easily be any 'MonadIO' or+  -- even pure, depending on the link warnings are reported.+renameInterface dflags ignoreSet renamingEnv warnings hoogle iface = do+    let (iface', warnedNames) =+          runRnM+            dflags+            mdl+            localLinkEnv+            warnName+            (hoogle && not (OptHide `elem` ifaceOptions iface))+            (renameInterfaceRn iface)+    reportMissingLinks mdl warnedNames+    return iface'+  where+    -- The current module+    mdl :: Module+    mdl = ifaceMod iface -      (renamedOrphanInstances, missingNames4)-        = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface))+    -- The local link environment, where every name exported by this module is+    -- mapped to the module itself, and everything else comes from the global+    -- renaming env+    localLinkEnv :: LinkEnv+    localLinkEnv = foldr f renamingEnv (ifaceVisibleExports iface)+      where f name !env = Map.insert name mdl env -      (finalModuleDoc, missingNames5)-        = runRnFM localEnv (renameDocumentation (ifaceDoc iface))+    -- The function used to determine whether we should warn about a name+    -- which we do not find in the renaming environment+    warnName name =+           -- Warnings must be enabled+           warnings -      -- combine the missing names and filter out the built-ins, which would-      -- otherwise always be missing.-      missingNames = nub $ filter isExternalName  -- XXX: isExternalName filters out too much-                    (missingNames1 ++ missingNames2 ++ missingNames3-                     ++ missingNames4 ++ missingNames5)+           -- Current module must not be hidden from Haddock+        && not (OptHide `elem` ifaceOptions iface) -      -- filter out certain built in type constructors using their string-      -- representation. TODO: use the Name constants from the GHC API.---      strings = filter (`notElem` ["()", "[]", "(->)"])---                (map pretty missingNames)-      strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames+           -- Must be an external name that is not built-in syntax, not a type+           -- variable, and not '~'+        && isExternalName name+        && not (isBuiltInSyntax name)+        && not (isTyVarName name)+        && Exact name /= eqTyCon_RDR -  in do-    -- report things that we couldn't link to. Only do this for non-hidden-    -- modules.-    unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $-      tell ["Warning: " ++ moduleString (ifaceMod iface) ++-            ": could not find link destinations for:\n"++-            unwords ("   " : strings) ]+           -- Must not be in the set of ignored symbols for the module or the+           -- unqualified ignored symbols+        && not (getOccString name `Set.member` ignoreSet')+      where+        -- The set of ignored symbols within the module this name is located+        -- in unioned with the set of globally ignored symbols+        ignoreSet' :: Set.Set String+        ignoreSet' =+          Set.union+            (Map.findWithDefault Set.empty (Just $ modString name) ignoreSet)+            (Map.findWithDefault Set.empty Nothing ignoreSet) -    return $ iface { ifaceRnDoc         = finalModuleDoc,-                     ifaceRnDocMap      = rnDocMap,-                     ifaceRnArgMap      = rnArgMap,-                     ifaceRnExportItems = renamedExportItems,-                     ifaceRnOrphanInstances = renamedOrphanInstances}+        modString :: Name -> String+        modString = moduleString . nameModule +-- | Output warning messages indicating that the renamer could not find link+-- destinations for the names in the given set as they occur in the given+-- module.+reportMissingLinks :: Module -> Set.Set Name -> Ghc ()+reportMissingLinks mdl names+    | Set.null names = return ()+    | otherwise =+        liftIO $ do+          putStrLn $ "Warning: " ++ moduleString mdl ++ ": could not find link destinations for: "+          traverse_ (putStrLn . ("\t- " ++) . qualifiedName) names+  where+    qualifiedName :: Name -> String+    qualifiedName name = moduleString (nameModule name) ++ "." ++ getOccString name  -------------------------------------------------------------------------------- -- Monad for renaming------ The monad does two things for us: it passes around the environment for--- renaming, and it returns a list of names which couldn't be found in--- the environment. -------------------------------------------------------------------------------- --newtype RnM a =-  RnM { unRn :: (Name -> (Bool, DocName))  -- name lookup function-             -> (a,[Name])-      }--instance Monad RnM where-  (>>=) = thenRn-  return = pure--instance Functor RnM where-  fmap f x = do a <- x; return (f a)--instance Applicative RnM where-  pure = returnRn-  (<*>) = ap+-- | A renaming monad which provides 'MonadReader' access to a renaming+-- environment, and 'MonadWriter' access to a 'Set' of names for which link+-- warnings should be generated, based on the renaming environment.+newtype RnM a = RnM { unRnM :: ReaderT RnMEnv (Writer (Set.Set Name)) a }+  deriving newtype (Functor, Applicative, Monad, MonadReader RnMEnv, MonadWriter (Set.Set Name)) -returnRn :: a -> RnM a-returnRn a   = RnM (const (a,[]))-thenRn :: RnM a -> (a -> RnM b) -> RnM b-m `thenRn` k = RnM (\lkp -> case unRn m lkp of-  (a,out1) -> case unRn (k a) lkp of-    (b,out2) -> (b,out1++out2))+-- | The renaming monad environment. Stores the linking environment (mapping+-- names to modules), the link warning predicate, and the current module.+data RnMEnv = RnMEnv+    { -- | The linking environment (map from names to modules)+      rnLinkEnv      :: LinkEnv -getLookupRn :: RnM (Name -> (Bool, DocName))-getLookupRn = RnM (\lkp -> (lkp,[]))+      -- | Link warning predicate (whether failing to find a link destination+      -- for a given name should result in a warning)+    , rnWarnName     :: (Name -> Bool) -outRn :: Name -> RnM ()-outRn name = RnM (const ((),[name]))+      -- | The current module+    , rnModuleString :: String -lookupRn :: Name -> RnM DocName-lookupRn name = do-  lkp <- getLookupRn-  case lkp name of-    (False,maps_to) -> do outRn name; return maps_to-    (True, maps_to) -> return maps_to+      -- | Should Hoogle output be generated for this module?+    , rnHoogleOutput :: Bool +      -- | GHC Session DynFlags, necessary for Hoogle output generation+    , rnDynFlags :: DynFlags+    } -runRnFM :: LinkEnv -> RnM a -> (a,[Name])-runRnFM env rn = unRn rn lkp+-- | Run the renamer action in a renaming environment built using the given+-- module, link env, and link warning predicate. Returns the renamed value along+-- with a set of 'Name's that were not renamed and should be warned for (i.e.+-- they satisfied the link warning predicate).+runRnM :: DynFlags -> Module -> LinkEnv -> (Name -> Bool) -> Bool -> RnM a -> (a, Set.Set Name)+runRnM dflags mdl linkEnv warnName hoogleOutput rn =+    runWriter $ runReaderT (unRnM rn) rnEnv   where-    lkp n = case Map.lookup n env of-      Nothing  -> (False, Undocumented n)-      Just mdl -> (True,  Documented n mdl)-+    rnEnv :: RnMEnv+    rnEnv = RnMEnv+      { rnLinkEnv      = linkEnv+      , rnWarnName     = warnName+      , rnModuleString = moduleString mdl+      , rnHoogleOutput = hoogleOutput+      , rnDynFlags     = dflags+      }  -------------------------------------------------------------------------------- -- Renaming -------------------------------------------------------------------------------- +-- | Rename an `Interface` in the renaming environment.+renameInterfaceRn :: Interface -> RnM Interface+renameInterfaceRn iface = do+  exportItems <- renameExportItems (ifaceExportItems iface)+  orphans     <- mapM renameDocInstance (ifaceOrphanInstances iface)+  finalModDoc <- renameDocumentation (ifaceDoc iface)+  pure $! iface+    { ifaceRnDoc             = finalModDoc -rename :: Name -> RnM DocName-rename = lookupRn+    -- The un-renamed export items are not used after renaming+    , ifaceRnExportItems     = exportItems+    , ifaceExportItems       = [] +    -- The un-renamed orphan instances are not used after renaming+    , ifaceRnOrphanInstances = orphans+    , ifaceOrphanInstances   = []+    } -renameL :: Located Name -> RnM (Located DocName)-renameL = mapM rename+-- | Lookup a 'Name' in the renaming environment.+lookupRn :: Name -> RnM DocName+lookupRn name = RnM $ do+    linkEnv <- asks rnLinkEnv+    case Map.lookup name linkEnv of+      Nothing  -> return $ Undocumented name+      Just mdl -> return $ Documented name mdl +-- | Rename a 'Name' in the renaming environment. This is very similar to+-- 'lookupRn', but tracks any names not found in the renaming environment if the+-- `rnWarnName` predicate is true.+renameName :: Name -> RnM DocName+renameName name = do+    warnName <- asks rnWarnName+    docName <- lookupRn name+    case docName of+      Undocumented _ -> do+        when (warnName name) $+          tell $ Set.singleton name+        return docName+      _ -> return docName -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]+-- | Rename a located 'Name' in the current renaming environment.+renameNameL :: GenLocated l Name -> RnM (GenLocated l DocName)+renameNameL = mapM renameName++-- | Rename a list of export items in the current renaming environment.+renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem +-- | Rename an 'ExportItem' in the current renaming environment.+renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)+renameExportItem item = case item of+  ExportModule mdl -> return (ExportModule mdl)+  ExportGroup lev id_ doc -> do+    doc' <- renameDoc doc+    return (ExportGroup lev id_ doc')+  ExportDecl ed@(ExportD decl pats doc subs instances fixities splice) -> do+    -- If Hoogle output should be generated, generate it+    RnMEnv{..} <- ask+    let !hoogleOut = force $+          if rnHoogleOutput then+            ppExportD rnDynFlags ed+          else+            [] +    decl' <- renameLDecl decl+    pats' <- renamePats pats+    doc'  <- renameDocForDecl doc+    subs' <- mapM renameSub subs+    instances' <- forM instances renameDocInstance+    fixities' <- forM fixities $ \(name, fixity) -> do+      name' <- lookupRn name+      return (name', fixity)++    return $+      ExportDecl RnExportD+        { rnExpDExpD   = ExportD decl' pats' doc' subs' instances' fixities' splice+        , rnExpDHoogle = hoogleOut+        }+  ExportNoDecl x subs -> do+    x'    <- lookupRn x+    subs' <- mapM lookupRn subs+    return (ExportNoDecl x' subs')+  ExportDoc doc -> do+    doc' <- renameDoc doc+    return (ExportDoc doc')+ renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) renameDocForDecl (doc, fnArgsDoc) =   (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc - renameDocumentation :: Documentation Name -> RnM (Documentation DocName) renameDocumentation (Documentation mDoc mWarning) =   Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning --renameLDocHsSyn :: LHsDocString -> RnM LHsDocString-renameLDocHsSyn = return-+renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))+renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) -renameDoc :: Traversable t => t Name -> RnM (t DocName)-renameDoc = traverse rename+renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))+renameDoc = traverse (traverse renameName)  renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc --renameLType :: LHsType Name -> RnM (LHsType DocName)+renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName)-renameLSigType = renameImplicit renameLType+renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI)+renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty+                                     ; return $ HsValArg ty' }+renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki+                                     ; return $ HsTypeArg l ki' }+renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp -renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)-renameLSigWcType = renameImplicit (renameWc renameLType)+renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)+renameLSigType = mapM renameSigType -renameLKind :: LHsKind Name -> RnM (LHsKind DocName)+renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)+renameLSigWcType = renameWc renameLSigType++renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))+renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName)-renameFamilyResultSig (L loc NoSig)-    = return (L loc NoSig)-renameFamilyResultSig (L loc (KindSig ki))+renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)+renameFamilyResultSig (L loc (NoSig _))+    = return (L loc (NoSig noExtField))+renameFamilyResultSig (L loc (KindSig _ ki))     = do { ki' <- renameLKind ki-         ; return (L loc (KindSig ki')) }-renameFamilyResultSig (L loc (TyVarSig bndr))+         ; return (L loc (KindSig noExtField ki')) }+renameFamilyResultSig (L loc (TyVarSig _ bndr))     = do { bndr' <- renameLTyVarBndr bndr-         ; return (L loc (TyVarSig bndr')) }+         ; return (L loc (TyVarSig noExtField bndr')) } -renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)-renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))-    = do { lhs' <- renameL lhs-         ; rhs' <- mapM renameL rhs-         ; return (L loc (InjectivityAnn lhs' rhs')) }+renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)+renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs))+    = do { lhs' <- renameNameL lhs+         ; rhs' <- mapM renameNameL rhs+         ; return (L loc (InjectivityAnn noExtField lhs' rhs')) } -renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name)-                          -> RnM (Maybe (LInjectivityAnn DocName))+renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)+                          -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType Name -> RnM (HsType DocName)+renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)+renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)+renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))+renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))+renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p++renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of-  HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do-    tyvars'   <- mapM renameLTyVarBndr tyvars-    ltype'    <- renameLType ltype-    return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })+  HsForAllTy { hst_tele = tele, hst_body = ltype } -> do+    tele'  <- renameHsForAllTelescope tele+    ltype' <- renameLType ltype+    return (HsForAllTy { hst_xforall = noAnn+                       , hst_tele = tele', hst_body = ltype' })    HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do     lcontext' <- renameLContext lcontext     ltype'    <- renameLType ltype-    return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })+    return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) -  HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n-  HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype+  HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< renameName n+  HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype -  HsAppTy a b -> do+  HsStarTy _ isUni -> return (HsStarTy noAnn isUni)++  HsAppTy _ a b -> do     a' <- renameLType a     b' <- renameLType b-    return (HsAppTy a' b')+    return (HsAppTy noAnn a' b') -  HsFunTy a b -> do+  HsAppKindTy _ a b -> do     a' <- renameLType a+    b' <- renameLKind b+    return (HsAppKindTy noAnn a' b')++  HsFunTy _ w a b -> do+    a' <- renameLType a     b' <- renameLType b-    return (HsFunTy a' b')+    w' <- renameArrow w+    return (HsFunTy noAnn w' a' b') -  HsListTy ty -> return . HsListTy =<< renameLType ty-  HsPArrTy ty -> return . HsPArrTy =<< renameLType ty-  HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)-  HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)+  HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty+  HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) -  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts+  HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts+  HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts -  HsOpTy a (L loc op) b -> do-    op' <- rename op+  HsOpTy _ prom a (L loc op) b -> do+    op' <- renameName op     a'  <- renameLType a     b'  <- renameLType b-    return (HsOpTy a' (L loc op') b')+    return (HsOpTy noAnn prom a' (L loc op') b') -  HsParTy ty -> return . HsParTy =<< renameLType ty+  HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty -  HsKindSig ty k -> do+  HsKindSig _ ty k -> do     ty' <- renameLType ty     k' <- renameLKind k-    return (HsKindSig ty' k')+    return (HsKindSig noAnn ty' k') -  HsDocTy ty doc -> do+  HsDocTy _ ty doc -> do     ty' <- renameLType ty     doc' <- renameLDocHsSyn doc-    return (HsDocTy ty' doc')+    return (HsDocTy noAnn ty' doc') -  HsTyLit x -> return (HsTyLit x)+  HsTyLit _ x -> return (HsTyLit noAnn (renameTyLit x)) -  HsRecTy a               -> HsRecTy <$> mapM renameConDeclFieldField a-  HsCoreTy a              -> pure (HsCoreTy a)-  HsExplicitListTy  a b   -> HsExplicitListTy  a <$> mapM renameLType b-  HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b-  HsSpliceTy _ _          -> error "renameType: HsSpliceTy"-  HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a-  HsAppsTy _              -> error "renameType: HsAppsTy"+  HsRecTy _ a               -> HsRecTy noAnn <$> mapM renameConDeclFieldField a+  XHsType a                 -> pure (XHsType a)+  HsExplicitListTy _ a b  -> HsExplicitListTy noAnn a <$> mapM renameLType b+  HsExplicitTupleTy _ b   -> HsExplicitTupleTy noAnn <$> mapM renameLType b+  HsSpliceTy (HsUntypedSpliceTop _ st)  _ -> renameType (unLoc st)+  HsSpliceTy (HsUntypedSpliceNested _) _ -> error "renameType: not an top level type splice"+  HsWildCardTy _          -> pure (HsWildCardTy noAnn) -renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)-renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })+renameTyLit :: HsTyLit GhcRn -> HsTyLit DocNameI+renameTyLit t = case t of+  HsNumTy  _ v -> HsNumTy noExtField v+  HsStrTy  _ v -> HsStrTy noExtField v+  HsCharTy _ v -> HsCharTy noExtField v+++renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)+renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do+  bndrs' <- renameOuterTyVarBndrs bndrs+  body'  <- renameLType body+  pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }++renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)+renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })   = do { tvs' <- mapM renameLTyVarBndr tvs-       ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }-                -- This is rather bogus, but I'm not sure what else to do+       ; return (HsQTvs { hsq_ext = noExtField+                        , hsq_explicit = tvs' }) } -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)-renameLTyVarBndr (L loc (UserTyVar (L l n)))-  = do { n' <- rename n-       ; return (L loc (UserTyVar (L l n'))) }-renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))-  = do { n' <- rename n+renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)+renameHsForAllTelescope tele = case tele of+  HsForAllVis   _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+                              pure $ HsForAllVis noExtField bndrs'+  HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+                              pure $ HsForAllInvis noExtField bndrs'++renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)+renameLTyVarBndr (L loc (UserTyVar _ fl (L l n)))+  = do { n' <- renameName n+       ; return (L loc (UserTyVar noExtField fl (L l n'))) }+renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind))+  = do { n' <- renameName n        ; kind' <- renameLKind kind-       ; return (L loc (KindedTyVar (L lv n') kind')) }+       ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])+renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI]) renameLContext (L loc context) = do   context' <- mapM renameLType context   return (L loc context') -renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)-renameWildCardInfo (AnonWildCard  (L l name)) = AnonWildCard . L l <$> rename name--renameInstHead :: InstHead Name -> RnM (InstHead DocName)+renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do-  cname <- rename ihdClsName-  kinds <- mapM renameType ihdKinds+  cname <- renameName ihdClsName   types <- mapM renameType ihdTypes   itype <- case ihdInstType of     ClassInst { .. } -> ClassInst@@ -305,299 +462,358 @@     DataInst  dd -> DataInst  <$> renameTyClD dd   return InstHead     { ihdClsName = cname-    , ihdKinds = kinds     , ihdTypes = types     , ihdInstType = itype     } -renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)+renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d +renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)]+renamePats = mapM+  (\(d,doc) -> do { d'   <- renameDecl d+                  ; doc' <- renameDocForDecl doc+                  ; return (d',doc')}) -renameDecl :: HsDecl Name -> RnM (HsDecl DocName)+renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of-  TyClD d -> do+  TyClD _ d -> do     d' <- renameTyClD d-    return (TyClD d')-  SigD s -> do+    return (TyClD noExtField d')+  SigD _ s -> do     s' <- renameSig s-    return (SigD s')-  ForD d -> do+    return (SigD noExtField s')+  ForD _ d -> do     d' <- renameForD d-    return (ForD d')-  InstD d -> do+    return (ForD noExtField d')+  InstD _ d -> do     d' <- renameInstD d-    return (InstD d')+    return (InstD noExtField d')+  DerivD _ d -> do+    d' <- renameDerivD d+    return (DerivD noExtField d')   _ -> error "renameDecl" -renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))-renameLThing fn (L loc x) = return . L loc =<< fn x+renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI))+renameLThing fn (L loc x) = return . L (locA loc) =<< fn x -renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)+renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of --  TyFamily flav lname ltyvars kind tckind -> do   FamDecl { tcdFam = decl } -> do     decl' <- renameFamilyDecl decl-    return (FamDecl { tcdFam = decl' })+    return (FamDecl { tcdFExt = noExtField, tcdFam = decl' }) -  SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do-    lname'    <- renameL lname+  SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do+    lname'    <- renameNameL lname     tyvars'   <- renameLHsQTyVars tyvars     rhs'     <- renameLType rhs-    return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames })+    return (SynDecl { tcdSExt = noExtField, tcdLName = lname', tcdTyVars = tyvars'+                    , tcdFixity = fixity, tcdRhs = rhs' }) -  DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do-    lname'    <- renameL lname+  DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do+    lname'    <- renameNameL lname     tyvars'   <- renameLHsQTyVars tyvars     defn'     <- renameDataDefn defn-    return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })+    return (DataDecl { tcdDExt = noExtField, tcdLName = lname', tcdTyVars = tyvars'+                     , tcdFixity = fixity, tcdDataDefn = defn' }) -  ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars+  ClassDecl { tcdLayout = layout+            , tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity             , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do-    lcontext' <- renameLContext lcontext-    lname'    <- renameL lname+    lcontext' <- traverse renameLContext lcontext+    lname'    <- renameNameL lname     ltyvars'  <- renameLHsQTyVars ltyvars     lfundeps' <- mapM renameLFunDep lfundeps     lsigs'    <- mapM renameLSig lsigs     ats'      <- mapM (renameLThing renameFamilyDecl) ats-    at_defs'  <- mapM renameLTyFamDefltEqn at_defs+    at_defs'  <- mapM (mapM renameTyFamDefltD) at_defs     -- we don't need the default methods or the already collected doc entities-    return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'+    return (ClassDecl { tcdCExt = noExtField+                      , tcdLayout = renameLayoutInfo layout+                      , tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'+                      , tcdFixity = fixity                       , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag-                      , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })+                      , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [] })    where-    renameLFunDep (L loc (xs, ys)) = do-      xs' <- mapM rename (map unLoc xs)-      ys' <- mapM rename (map unLoc ys)-      return (L loc (map noLoc xs', map noLoc ys'))+    renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)+    renameLFunDep (L loc (FunDep _ xs ys)) = do+      xs' <- mapM renameName (map unLoc xs)+      ys' <- mapM renameName (map unLoc ys)+      return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) -    renameLSig (L loc sig) = return . L loc =<< renameSig sig+    renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)+renameLayoutInfo :: LayoutInfo GhcRn -> LayoutInfo DocNameI+renameLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb+renameLayoutInfo (VirtualBraces n) = VirtualBraces n+renameLayoutInfo NoLayoutInfo = NoLayoutInfo++renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname-                             , fdTyVars = ltyvars, fdResultSig = result+                             , fdTyVars = ltyvars+                             , fdFixity = fixity+                             , fdResultSig = result                              , fdInjectivityAnn = injectivity }) = do     info'        <- renameFamilyInfo info-    lname'       <- renameL lname+    lname'       <- renameNameL lname     ltyvars'     <- renameLHsQTyVars ltyvars     result'      <- renameFamilyResultSig result     injectivity' <- renameMaybeInjectivityAnn injectivity-    return (FamilyDecl { fdInfo = info', fdLName = lname'-                       , fdTyVars = ltyvars', fdResultSig = result'+    return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel+                       , fdLName = lname'+                       , fdTyVars = ltyvars'+                       , fdFixity = fixity+                       , fdResultSig = result'                        , fdInjectivityAnn = injectivity' })  -renamePseudoFamilyDecl :: PseudoFamilyDecl Name-                       -> RnM (PseudoFamilyDecl DocName)+renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn+                       -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) =  PseudoFamilyDecl     <$> renameFamilyInfo pfdInfo-    <*> renameL pfdLName+    <*> renameNameL pfdLName     <*> mapM renameLType pfdTyVars     <*> renameFamilyResultSig pfdKindSig  -renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)+renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily     = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns)-  = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns+  = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns        ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)-renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType+renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)+renameDataDefn (HsDataDefn { dd_ctxt = lcontext, dd_cType = cType                            , dd_kindSig = k, dd_cons = cons }) = do-    lcontext' <- renameLContext lcontext+    lcontext' <- traverse renameLContext lcontext     k'        <- renameMaybeLKind k-    cons'     <- mapM (mapM renameCon) cons+    cons'     <- mapM (mapMA renameCon) cons     -- I don't think we need the derivings, so we return Nothing-    return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType-                       , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })+    return (HsDataDefn { dd_ext = noExtField+                       , dd_ctxt = lcontext', dd_cType = cType+                       , dd_kindSig = k', dd_cons = cons'+                       , dd_derivs = [] }) -renameCon :: ConDecl Name -> RnM (ConDecl DocName)-renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars-                           , con_cxt = lcontext, con_details = details-                           , con_doc = mbldoc }) = do-      lname'    <- renameL lname-      ltyvars'  <- traverse renameLHsQTyVars ltyvars+renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)+renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars+                           , con_mb_cxt = lcontext, con_args = details+                           , con_doc = mbldoc+                           , con_forall = forall_ }) = do+      lname'    <- renameNameL lname+      ltyvars'  <- mapM renameLTyVarBndr ltyvars       lcontext' <- traverse renameLContext lcontext-      details'  <- renameDetails details+      details'  <- renameH98Details details+      mbldoc'   <- mapM (renameLDocHsSyn) mbldoc+      return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'+                   , con_mb_cxt = lcontext'+                   , con_forall = forall_ -- Remove when #18311 is fixed+                   , con_args = details', con_doc = mbldoc' })++renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs+                            , con_dcolon = dcol+                            , con_mb_cxt = lcontext, con_g_args = details+                            , con_res_ty = res_ty+                            , con_doc = mbldoc } = do+      lnames'   <- mapM renameNameL lnames+      bndrs'    <- mapM renameOuterTyVarBndrs bndrs+      lcontext' <- traverse renameLContext lcontext+      details'  <- renameGADTDetails details+      res_ty'   <- renameLType res_ty       mbldoc'   <- mapM renameLDocHsSyn mbldoc-      return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'-                   , con_details = details', con_doc = mbldoc' })+      return (ConDeclGADT+                   { con_g_ext = noExtField, con_names = lnames'+                   , con_dcolon = dcol, con_bndrs = bndrs'+                   , con_mb_cxt = lcontext', con_g_args = details'+                   , con_res_ty = res_ty', con_doc = mbldoc' }) -  where-    renameDetails (RecCon (L l fields)) = do-      fields' <- mapM renameConDeclFieldField fields-      return (RecCon (L l fields'))-    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps-    renameDetails (InfixCon a b) = do-      a' <- renameLType a-      b' <- renameLType b-      return (InfixCon a' b')+renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)+               -> RnM (HsScaled DocNameI (LHsType DocNameI))+renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameCon decl@(ConDeclGADT { con_names = lnames-                            , con_type = lty-                            , con_doc = mbldoc }) = do-      lnames'   <- mapM renameL lnames-      lty'      <- renameLSigType lty-      mbldoc'   <- mapM renameLDocHsSyn mbldoc-      return (decl { con_names = lnames'-                   , con_type = lty', con_doc = mbldoc' })+renameH98Details :: HsConDeclH98Details GhcRn+                 -> RnM (HsConDeclH98Details DocNameI)+renameH98Details (RecCon (L l fields)) = do+  fields' <- mapM renameConDeclFieldField fields+  return (RecCon (L (locA l) fields'))+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps+renameH98Details (InfixCon a b) = do+  a' <- renameHsScaled a+  b' <- renameHsScaled b+  return (InfixCon a' b') -renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)-renameConDeclFieldField (L l (ConDeclField names t doc)) = do+renameGADTDetails :: HsConDeclGADTDetails GhcRn+                  -> RnM (HsConDeclGADTDetails DocNameI)+renameGADTDetails (RecConGADT (L l fields) arr) = do+  fields' <- mapM renameConDeclFieldField fields+  return (RecConGADT (L (locA l) fields') arr)+renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps++renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)+renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do   names' <- mapM renameLFieldOcc names   t'   <- renameLType t   doc' <- mapM renameLDocHsSyn doc-  return $ L l (ConDeclField names' t' doc')+  return $ L (locA l) (ConDeclField noExtField names' t' doc') -renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)-renameLFieldOcc (L l (FieldOcc lbl sel)) = do-  sel' <- rename sel-  return $ L l (FieldOcc lbl sel')+renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)+renameLFieldOcc (L l (FieldOcc sel lbl)) = do+  sel' <- renameName sel+  return $ L l (FieldOcc sel' lbl) -renameSig :: Sig Name -> RnM (Sig DocName)+renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of-  TypeSig lnames ltype -> do-    lnames' <- mapM renameL lnames+  TypeSig _ lnames ltype -> do+    lnames' <- mapM renameNameL lnames     ltype' <- renameLSigWcType ltype-    return (TypeSig lnames' ltype')-  ClassOpSig is_default lnames sig_ty -> do-    lnames' <- mapM renameL lnames+    return (TypeSig noExtField lnames' ltype')+  ClassOpSig _ is_default lnames sig_ty -> do+    lnames' <- mapM renameNameL lnames     ltype' <- renameLSigType sig_ty-    return (ClassOpSig is_default lnames' ltype')-  PatSynSig lname sig_ty -> do-    lname' <- renameL lname+    return (ClassOpSig noExtField is_default lnames' ltype')+  PatSynSig _ lnames sig_ty -> do+    lnames' <- mapM renameNameL lnames     sig_ty' <- renameLSigType sig_ty-    return $ PatSynSig lname' sig_ty'-  FixSig (FixitySig lnames fixity) -> do-    lnames' <- mapM renameL lnames-    return $ FixSig (FixitySig lnames' fixity)-  MinimalSig src (L l s) -> do-    s' <- traverse renameL s-    return $ MinimalSig src (L l s')+    return $ PatSynSig noExtField lnames' sig_ty'+  FixSig _ (FixitySig _ lnames fixity) -> do+    lnames' <- mapM renameNameL lnames+    return $ FixSig noExtField (FixitySig noExtField lnames' fixity)+  MinimalSig _ (L l s) -> do+    s' <- traverse (traverse lookupRn) s+    return $ MinimalSig noExtField (L l s')   -- we have filtered out all other kinds of signatures in Interface.Create   _ -> error "expected TypeSig"  -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)-renameForD (ForeignImport lname ltype co x) = do-  lname' <- renameL lname+renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)+renameForD (ForeignImport _ lname ltype x) = do+  lname' <- renameNameL lname   ltype' <- renameLSigType ltype-  return (ForeignImport lname' ltype' co x)-renameForD (ForeignExport lname ltype co x) = do-  lname' <- renameL lname+  return (ForeignImport noExtField lname' ltype' (renameForI x))+renameForD (ForeignExport _ lname ltype x) = do+  lname' <- renameNameL lname   ltype' <- renameLSigType ltype-  return (ForeignExport lname' ltype' co x)+  return (ForeignExport noExtField lname' ltype' (renameForE x)) +renameForI :: ForeignImport GhcRn -> ForeignImport DocNameI+renameForI (CImport _ cconv safety mHeader spec) = CImport noExtField cconv safety mHeader spec -renameInstD :: InstDecl Name -> RnM (InstDecl DocName)+renameForE :: ForeignExport GhcRn -> ForeignExport DocNameI+renameForE (CExport _ spec) = CExport noExtField spec+++renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do   d' <- renameClsInstD d-  return (ClsInstD { cid_inst = d' })+  return (ClsInstD { cid_d_ext = noExtField, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do   d' <- renameTyFamInstD d-  return (TyFamInstD { tfid_inst = d' })+  return (TyFamInstD { tfid_ext = noExtField, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do   d' <- renameDataFamInstD d-  return (DataFamInstD { dfid_inst = d' })+  return (DataFamInstD { dfid_ext = noExtField, dfid_inst = d' }) -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)+renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)+renameDerivD (DerivDecl { deriv_type = ty+                        , deriv_strategy = strat+                        , deriv_overlap_mode = omode }) = do+  ty'    <- renameLSigWcType ty+  strat' <- mapM (mapM renameDerivStrategy) strat+  return (DerivDecl { deriv_ext = noExtField+                    , deriv_type = ty'+                    , deriv_strategy = strat'+                    , deriv_overlap_mode = omode })++renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI)+renameDerivStrategy (StockStrategy a)    = pure (StockStrategy a)+renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a)+renameDerivStrategy (NewtypeStrategy a)  = pure (NewtypeStrategy a)+renameDerivStrategy (ViaStrategy ty)     = ViaStrategy <$> renameLSigType ty++renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode                             , cid_poly_ty =ltype, cid_tyfam_insts = lATs                             , cid_datafam_insts = lADTs }) = do   ltype' <- renameLSigType ltype   lATs'  <- mapM (mapM renameTyFamInstD) lATs   lADTs' <- mapM (mapM renameDataFamInstD) lADTs-  return (ClsInstDecl { cid_overlap_mode = omode+  return (ClsInstDecl { cid_ext = noExtField, cid_overlap_mode = omode                       , cid_poly_ty = ltype', cid_binds = emptyBag                       , cid_sigs = []                       , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })  -renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)+renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })-  = do { eqn' <- renameLTyFamInstEqn eqn-       ; return (TyFamInstDecl { tfid_eqn = eqn'-                               , tfid_fvs = placeHolderNames }) }+  = do { eqn' <- renameTyFamInstEqn eqn+       ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) } -renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs }))-  = do { tc' <- renameL tc-       ; pats' <- renameImplicit (mapM renameLType) pats+renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)+renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs+                           , feqn_pats = pats, feqn_fixity = fixity+                           , feqn_rhs = rhs })+  = do { tc' <- renameNameL tc+       ; bndrs' <- renameOuterTyVarBndrs bndrs+       ; pats' <- mapM renameLTypeArg pats        ; rhs' <- renameLType rhs-       ; return (L loc (TyFamEqn { tfe_tycon = tc'-                                 , tfe_pats = pats'-                                 , tfe_rhs = rhs' })) }+       ; return (FamEqn { feqn_ext    = noExtField+                        , feqn_tycon  = tc'+                        , feqn_bndrs  = bndrs'+                        , feqn_pats   = pats'+                        , feqn_fixity = fixity+                        , feqn_rhs    = rhs' }) } -renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)-renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))-  = do { tc'  <- renameL tc-       ; tvs' <- renameLHsQTyVars tvs-       ; rhs' <- renameLType rhs-       ; return (L loc (TyFamEqn { tfe_tycon = tc'-                                 , tfe_pats = tvs'-                                 , tfe_rhs = rhs' })) }+renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI)+renameTyFamDefltD = renameTyFamInstD -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_defn = defn })-  = do { tc' <- renameL tc-       ; pats' <- renameImplicit (mapM renameLType) pats-       ; defn' <- renameDataDefn defn-       ; return (DataFamInstDecl { dfid_tycon = tc'-                                 , dfid_pats = pats'-                                 , dfid_defn = defn', dfid_fvs = placeHolderNames }) }+renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)+renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })+  = do { eqn' <- rename_data_fam_eqn eqn+       ; return (DataFamInstDecl { dfid_eqn = eqn' }) }+  where+    rename_data_fam_eqn+      :: FamEqn GhcRn (HsDataDefn GhcRn)+      -> RnM (FamEqn DocNameI (HsDataDefn DocNameI))+    rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs+                                , feqn_pats = pats, feqn_fixity = fixity+                                , feqn_rhs = defn })+      = do { tc' <- renameNameL tc+           ; bndrs' <- renameOuterTyVarBndrs bndrs+           ; pats' <- mapM renameLTypeArg pats+           ; defn' <- renameDataDefn defn+           ; return (FamEqn { feqn_ext    = noExtField+                            , feqn_tycon  = tc'+                            , feqn_bndrs  = bndrs'+                            , feqn_pats   = pats'+                            , feqn_fixity = fixity+                            , feqn_rhs    = defn' }) } -renameImplicit :: (in_thing -> RnM out_thing)-               -> HsImplicitBndrs Name in_thing-               -> RnM (HsImplicitBndrs DocName out_thing)-renameImplicit rn_thing (HsIB { hsib_body = thing })-  = do { thing' <- rn_thing thing-       ; return (HsIB { hsib_body = thing'-                      , hsib_vars = PlaceHolder }) }+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn+                      -> RnM (HsOuterTyVarBndrs flag DocNameI)+renameOuterTyVarBndrs (HsOuterImplicit{}) =+  pure $ HsOuterImplicit{hso_ximplicit = noExtField}+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =+  HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs  renameWc :: (in_thing -> RnM out_thing)-         -> HsWildCardBndrs Name in_thing-         -> RnM (HsWildCardBndrs DocName out_thing)+         -> HsWildCardBndrs GhcRn in_thing+         -> RnM (HsWildCardBndrs DocNameI out_thing) renameWc rn_thing (HsWC { hswc_body = thing })   = do { thing' <- rn_thing thing        ; return (HsWC { hswc_body = thing'-                      , hswc_wcs = PlaceHolder, hswc_ctx = Nothing }) }+                      , hswc_ext = noExtField }) } -renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)-renameDocInstance (inst, idoc, L l n) = do+renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)+renameDocInstance (inst, idoc, L l n, m) = do   inst' <- renameInstHead inst-  n' <- rename n+  n' <- renameName n   idoc' <- mapM renameDoc idoc-  return (inst', idoc',L l n')--renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)-renameExportItem item = case item of-  ExportModule mdl -> return (ExportModule mdl)-  ExportGroup lev id_ doc -> do-    doc' <- renameDoc doc-    return (ExportGroup lev id_ doc')-  ExportDecl decl doc subs instances fixities splice -> do-    decl' <- renameLDecl decl-    doc'  <- renameDocForDecl doc-    subs' <- mapM renameSub subs-    instances' <- forM instances renameDocInstance-    fixities' <- forM fixities $ \(name, fixity) -> do-      name' <- lookupRn name-      return (name', fixity)-    return (ExportDecl decl' doc' subs' instances' fixities' splice)-  ExportNoDecl x subs -> do-    x'    <- lookupRn x-    subs' <- mapM lookupRn subs-    return (ExportNoDecl x' subs')-  ExportDoc doc -> do-    doc' <- renameDoc doc-    return (ExportDoc doc')-+  return (inst', idoc', L l n', m)  renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) renameSub (n,doc) = do-  n' <- rename n+  n' <- renameName n   doc' <- renameDocForDecl doc   return (n', doc')
src/Haddock/Interface/Specialize.hs view
@@ -1,23 +1,26 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-}-+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module Haddock.Interface.Specialize     ( specializeInstHead     ) where  +import Haddock.GhcUtils ( hsTyVarBndrName ) import Haddock.Syb import Haddock.Types  import GHC-import Name-import FastString+import GHC.Types.Name+import GHC.Data.FastString+import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )  import Control.Monad-import Control.Monad.Trans.Reader import Control.Monad.Trans.State  import Data.Data@@ -28,73 +31,62 @@ import Data.Set (Set) import qualified Data.Set as Set ---- | Instantiate all occurrences of given name with particular type.-specialize :: (Eq name, Typeable name)-           => Data a-           => name -> HsType name -> a -> a-specialize name details =-    everywhere $ mkT step+-- | Instantiate all occurrences of given names with corresponding types.+specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a+specialize specs = go spec_map0   where-    step (HsTyVar (L _ name')) | name == name' = details-    step typ = typ+    go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x+    go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map +    strip_kind_sig :: HsType GhcRn -> HsType GhcRn+    strip_kind_sig (HsKindSig _ (L _ t) _) = t+    strip_kind_sig typ = typ --- | Instantiate all occurrences of given names with corresponding types.------ It is just a convenience function wrapping 'specialize' that supports more--- that one specialization.-specialize' :: (Eq name, Typeable name)-            => Data a-            => [(name, HsType name)] -> a -> a-specialize' = flip $ foldr (uncurry specialize)+    specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn+    specialize_ty_var spec_map (HsTyVar _ _ (L _ name'))+      | Just t <- Map.lookup name' spec_map = t+    specialize_ty_var _ typ = typ +    -- This is a tricky recursive definition. By adding in the specializations+    -- one by one, we should avoid infinite loops.+    spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs +{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-}+ -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders.-specializeTyVarBndrs :: (Eq name, DataId name)-                     => Data a-                     => LHsQTyVars name -> [HsType name]-                     -> a -> a-specializeTyVarBndrs bndrs typs =-    specialize' $ zip bndrs' typs+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a+specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs   where-    bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs-    bname (UserTyVar (L _ name)) = name-    bname (KindedTyVar (L _ name) _) = name+    bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs  -specializePseudoFamilyDecl :: (Eq name, DataId name)-                           => LHsQTyVars name -> [HsType name]-                           -> PseudoFamilyDecl name-                           -> PseudoFamilyDecl name-specializePseudoFamilyDecl bndrs typs decl =-    decl { pfdTyVars = map specializeTyVars (pfdTyVars decl) }-  where-    specializeTyVars = specializeTyVarBndrs bndrs typs +specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]+                           -> PseudoFamilyDecl GhcRn+                           -> PseudoFamilyDecl GhcRn+specializePseudoFamilyDecl bndrs typs decl =+  decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)} -specializeSig :: forall name . (Eq name, DataId name, SetName name)-              => LHsQTyVars name -> [HsType name]-              -> Sig name-              -> Sig name-specializeSig bndrs typs (TypeSig lnames typ) =-    TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})+specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]+              -> Sig GhcRn+              -> Sig GhcRn+specializeSig bndrs typs (TypeSig _ lnames typ) =+  TypeSig noAnn lnames (typ {hswc_body = noLocA typ'})   where-    true_type :: HsType name-    true_type = unLoc (hswc_body (hsib_body typ))-    typ' :: HsType name-    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type-    fv = foldr Set.union Set.empty . map freeVariables $ typs+    true_type :: HsSigType GhcRn+    true_type = unLoc (dropWildCards typ)+    typ' :: HsSigType GhcRn+    typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type+    fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig   -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type.-specializeInstHead :: (Eq name, DataId name, SetName name)-                   => InstHead name -> InstHead name+specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =     ihd { ihdInstType = instType' }   where@@ -113,45 +105,36 @@ -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@.-sugar :: forall name. (NamedThing name, DataId name)-      => HsType name -> HsType name-sugar =-    everywhere $ mkT step-  where-    step :: HsType name -> HsType name-    step = sugarOperators . sugarTuples . sugarLists-+sugar :: HsType GhcRn -> HsType GhcRn+sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing name => HsType name -> HsType name-sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)-    | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp-  where-    name' = getName name-    strName = occNameString . nameOccName $ name'+sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)+sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)+    | getName name == listTyConName = HsListTy noAnn ltyp sugarLists typ = typ  -sugarTuples :: NamedThing name => HsType name -> HsType name+sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ =     aux [] typ   where-    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp-    aux apps (HsParTy (L _ typ')) = aux apps typ'-    aux apps (HsTyVar (L _ name))-        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps+    aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp+    aux apps (HsParTy _ (L _ typ')) = aux apps typ'+    aux apps (HsTyVar _ _ (L _ name))+        | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps       where         name' = getName name-        strName = occNameString . nameOccName $ name'+        strName = getOccString name         suitable = case parseTupleArity strName of             Just arity -> arity == length apps             Nothing -> False     aux _ _ = typ  -sugarOperators :: NamedThing name => HsType name -> HsType name-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)-    | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb-    | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb+sugarOperators :: HsType GhcRn -> HsType GhcRn+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)+    | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb+    | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb   where     name' = getName name sugarOperators typ = typ@@ -193,19 +176,25 @@ -- not converted to 'String' or alike to avoid new allocations. Additionally, -- since it is stored mostly in 'Set', fast comparison of 'FastString' is also -- quite nice.-type NameRep = FastString+newtype NameRep+   = NameRep FastString+   deriving (Eq) +instance Ord NameRep where+   compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2++ getNameRep :: NamedThing name => name -> NameRep-getNameRep = occNameFS . getOccName+getNameRep = NameRep . getOccFS  nameRepString :: NameRep -> String-nameRepString = unpackFS+nameRepString (NameRep fs) = unpackFS fs  stringNameRep :: String -> NameRep-stringNameRep = mkFastString+stringNameRep = NameRep . mkFastString  setInternalNameRep :: SetName name => NameRep -> name -> name-setInternalNameRep = setInternalOccName . mkVarOccFS+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)  setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name =@@ -215,22 +204,39 @@     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)  --- | Compute set of free variables of given type.-freeVariables :: forall name. (NamedThing name, DataId name)-              => HsType name -> Set NameRep-freeVariables =-    everythingWithState Set.empty Set.union query+-- | Compute set of free variables of a given 'HsType'.+freeVariablesType :: HsType GhcRn -> Set Name+freeVariablesType =+    everythingWithState Set.empty Set.union+      (mkQ (\ctx -> (Set.empty, ctx)) queryType)++-- | Compute set of free variables of a given 'HsType'.+freeVariablesSigType :: HsSigType GhcRn -> Set Name+freeVariablesSigType =+    everythingWithState Set.empty Set.union+      (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)++queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)+queryType term ctx = case term of+    HsForAllTy _ tele _ ->+        (Set.empty, Set.union ctx (teleNames tele))+    HsTyVar _ _ (L _ name)+        | getName name `Set.member` ctx -> (Set.empty, ctx)+        | otherwise -> (Set.singleton $ getName name, ctx)+    _ -> (Set.empty, ctx)   where-    query term ctx = case cast term :: Maybe (HsType name) of-        Just (HsForAllTy bndrs _) ->-            (Set.empty, Set.union ctx (bndrsNames bndrs))-        Just (HsTyVar (L _ name))-            | getName name `Set.member` ctx -> (Set.empty, ctx)-            | otherwise -> (Set.singleton $ getNameRep name, ctx)-        _ -> (Set.empty, ctx)-    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)+    teleNames :: HsForAllTelescope GhcRn -> Set Name+    teleNames (HsForAllVis   _ bndrs) = bndrsNames bndrs+    teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs +querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =+  (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)++ -- | Make given type visually unambiguous. -- -- After applying 'specialize' method, some free type variables may become@@ -238,140 +244,140 @@ -- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something--- like @(a -> c) -> b@).-rename :: SetName name => Set NameRep -> HsType name -> HsType name-rename fv typ = runReader (renameType typ) $ RenameEnv-    { rneFV = fv-    , rneCtx = Map.empty-    }-+-- like @(a -> b0) -> b@).+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn+rename fv typ = evalState (renameSigType typ) env+  where+    env = RenameEnv+      { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv+      , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ+      , rneCtx = Map.empty+      }+    mkPair name = (getNameRep name, name)  -- | Renaming monad.-type Rename name = Reader (RenameEnv name)---- | Binding generation monad.-type Rebind name = State (RenameEnv name)+type Rename name = State (RenameEnv name)  data RenameEnv name = RenameEnv-    { rneFV :: Set NameRep-    , rneCtx :: Map Name name-    }+  { rneHeadFVs :: Map NameRep Name+  , rneSigFVs :: Set NameRep+  , rneCtx :: Map Name name+  }  -renameType :: SetName name => HsType name -> Rename name (HsType name)-renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->-    HsForAllTy-        <$> pure bndrs'+renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)+renameSigType (HsSig x bndrs body) =+  HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body++renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn+                      -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =+  HsOuterImplicit <$> mapM renameName imp_tvs+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =+  HsOuterExplicit x <$> mapM renameLBinder exp_bndrs++renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)+renameType (HsForAllTy x tele lt) =+    HsForAllTy x+        <$> renameForAllTelescope tele         <*> renameLType lt-renameType (HsQualTy lctxt lt) =-  HsQualTy-        <$> located renameContext lctxt+renameType (HsQualTy x lctxt lt) =+    HsQualTy x+        <$> renameLContext lctxt         <*> renameLType lt-renameType (HsTyVar name) = HsTyVar <$> located renameName name-renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la-renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr-renameType (HsListTy lt) = HsListTy <$> renameLType lt-renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt-renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt-renameType (HsOpTy la lop lb) =-    HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb-renameType (HsParTy lt) = HsParTy <$> renameLType lt-renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt-renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb-renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk+renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name+renameType t@(HsStarTy _ _) = pure t+renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la+renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk+renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsArrow w <*> renameLType la <*> renameLType lr+renameType (HsListTy x lt) = HsListTy x <$> renameLType lt+renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt+renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt+renameType (HsOpTy x prom la lop lb) =+    HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb+renameType (HsParTy x lt) = HsParTy x <$> renameLType lt+renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt+renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t-renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc-renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt-renameType t@(HsRecTy _) = pure t-renameType t@(HsCoreTy _) = pure t-renameType (HsExplicitListTy ph ltys) =-    HsExplicitListTy ph <$> renameLTypes ltys-renameType (HsExplicitTupleTy phs ltys) =-    HsExplicitTupleTy phs <$> renameLTypes ltys-renameType t@(HsTyLit _) = pure t+renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc+renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt+renameType t@(HsRecTy _ _) = pure t+renameType t@(XHsType _) = pure t+renameType (HsExplicitListTy x ip ltys) =+    HsExplicitListTy x ip <$> renameLTypes ltys+renameType (HsExplicitTupleTy x ltys) =+    HsExplicitTupleTy x <$> renameLTypes ltys+renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)-renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" +renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p+renameHsArrow mult = pure mult -renameLType :: SetName name => LHsType name -> Rename name (LHsType name)++renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType +renameLKind :: LHsKind GhcRn -> Rename (IdP GhcRn) (LHsKind GhcRn)+renameLKind = renameLType -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]+renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType +renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)+renameLContext (L l ctxt) = do+  ctxt' <- renameContext ctxt+  return (L l ctxt') -renameContext :: SetName name => HsContext name -> Rename name (HsContext name)+renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -{--renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)-renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname--}+renameForAllTelescope :: HsForAllTelescope GhcRn+                      -> Rename (IdP GhcRn) (HsForAllTelescope GhcRn)+renameForAllTelescope (HsForAllVis x bndrs) =+  HsForAllVis x <$> mapM renameLBinder bndrs+renameForAllTelescope (HsForAllInvis x bndrs) =+  HsForAllInvis x <$> mapM renameLBinder bndrs +renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname+renameBinder (KindedTyVar x fl lname lkind) =+  KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind +renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)+renameLBinder = located renameBinder++-- | Core renaming logic. renameName :: SetName name => name -> Rename name name renameName name = do-    RenameEnv { rneCtx = ctx } <- ask-    pure $ fromMaybe name (Map.lookup (getName name) ctx)---rebind :: SetName name-       => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)-       -> Rename name a-rebind lbndrs action = do-    (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask-    local (const env') (action lbndrs')---rebindLTyVarBndrs :: SetName name-                  => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]-rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs---rebindTyVarBndr :: SetName name-                => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)-rebindTyVarBndr (UserTyVar (L l name)) =-    UserTyVar . L l <$> rebindName name-rebindTyVarBndr (KindedTyVar name kinds) =-    KindedTyVar <$> located rebindName name <*> pure kinds---rebindName :: SetName name => name -> Rebind name name-rebindName name = do     RenameEnv { .. } <- get-    taken <- takenNames     case Map.lookup (getName name) rneCtx of-        Just name' -> pure name'-        Nothing | getNameRep name `Set.member` taken -> freshName name-        Nothing -> reuseName name+      Nothing+        | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs+        , headTv /= getName name -> freshName name+      Just name' -> return name'+      _ -> return name   -- | Generate fresh occurrence name, put it into context and return.-freshName :: SetName name => name -> Rebind name name+freshName :: SetName name => name -> Rename name name freshName name = do-    env@RenameEnv { .. } <- get     taken <- takenNames     let name' = setInternalNameRep (findFreshName taken rep) name-    put $ env { rneCtx = Map.insert nname name' rneCtx }+    modify $ \rne -> rne+      { rneCtx = Map.insert (getName name) name' (rneCtx rne) }     return name'   where     nname = getName name     rep = getNameRep nname  -reuseName :: SetName name => name -> Rebind name name-reuseName name = do-    env@RenameEnv { .. } <- get-    put $ env { rneCtx = Map.insert (getName name) name rneCtx }-    return name---takenNames :: NamedThing name => Rebind name (Set NameRep)+takenNames :: NamedThing name => Rename name (Set NameRep) takenNames = do     RenameEnv { .. } <- get-    return $ Set.union rneFV (ctxElems rneCtx)+    return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx]   where+    headReps = Set.fromList . Map.keys     ctxElems = Set.fromList . map getNameRep . Map.elems  @@ -383,24 +389,19 @@   alternativeNames :: NameRep -> [NameRep]-alternativeNames name-    | [_] <- nameRepString name = letterNames ++ alternativeNames' name-  where-    letterNames = map (stringNameRep . pure) ['a'..'z']-alternativeNames name = alternativeNames' name---alternativeNames' :: NameRep -> [NameRep]-alternativeNames' name =+alternativeNames name =     [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]   where     str = nameRepString name  -located :: Functor f => (a -> f b) -> Located a -> f (Located b)+located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b) located f (L loc e) = L loc <$> f e +locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b)+locatedN f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> name-tyVarName (UserTyVar name) = unLoc name-tyVarName (KindedTyVar (L _ name) _) = name++tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn+tyVarName (UserTyVar _ _ name) = unLoc name+tyVarName (KindedTyVar _ _ (L _ name) _) = name
src/Haddock/InterfaceFile.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -14,59 +16,99 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile (-  InterfaceFile(..), ifUnitId, ifModule,-  readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,-  writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility+  InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,+  PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo,+  readInterfaceFile, writeInterfaceFile,+  freshNameCache,+  binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where   import Haddock.Types-import Haddock.Utils hiding (out) -import Control.Monad-import Data.Array import Data.IORef-import Data.List import qualified Data.Map as Map import Data.Map (Map)+import Data.Version import Data.Word+import Text.ParserCombinators.ReadP (readP_to_S) -import BinIface (getSymtabName, getDictFastString)-import Binary-import FastMutInt-import FastString+import GHC.Iface.Binary (getWithUserData, putSymbolTable)+import GHC.Unit.State+import GHC.Utils.Binary+import GHC.Data.FastMutInt+import GHC.Data.FastString import GHC hiding (NoLink)-import GhcMonad (withSession)-import HscTypes-import IfaceEnv-import Name-import UniqFM-import UniqSupply-import Unique+import GHC.Types.Name.Cache+import GHC.Types.Unique.FM+import GHC.Types.Unique +import Haddock.Options (Visibility (..))  data InterfaceFile = InterfaceFile {   ifLinkEnv         :: LinkEnv,+  -- | Package meta data.  Currently it only consist of a package name, which+  -- is not read from the interface file, but inferred from its name.+  --+  -- issue #+  ifPackageInfo     :: PackageInfo,   ifInstalledIfaces :: [InstalledInterface] } +data PackageInfo = PackageInfo {+  piPackageName    :: PackageName,+  piPackageVersion :: Data.Version.Version+} +ppPackageInfo :: PackageInfo -> String+ppPackageInfo (PackageInfo name version) | version == makeVersion []+                                         = unpackFS (unPackageName name)+ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version++data PackageInterfaces = PackageInterfaces {+  piPackageInfo         :: PackageInfo,+  piVisibility          :: Visibility,+  piInstalledInterfaces :: [InstalledInterface]+}++mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces+mkPackageInterfaces piVisibility+                    InterfaceFile { ifPackageInfo+                                  , ifInstalledIfaces+                                  } =+  PackageInterfaces { piPackageInfo = ifPackageInfo+                    , piVisibility+                    , piInstalledInterfaces = ifInstalledIfaces+                    }+ ifModule :: InterfaceFile -> Module ifModule if_ =   case ifInstalledIfaces if_ of     [] -> error "empty InterfaceFile"     iface:_ -> instMod iface -ifUnitId :: InterfaceFile -> UnitId+ifUnitId :: InterfaceFile -> Unit ifUnitId if_ =   case ifInstalledIfaces if_ of     [] -> error "empty InterfaceFile"-    iface:_ -> moduleUnitId $ instMod iface+    iface:_ -> moduleUnit $ instMod iface   binaryInterfaceMagic :: Word32 binaryInterfaceMagic = 0xD0Cface +-- Note [The DocModule story]+--+-- Breaking changes to the DocH type result in Haddock being unable to read+-- existing interfaces. This is especially painful for interfaces shipped+-- with GHC distributions since there is no easy way to regenerate them!+--+-- PR #1315 introduced a breaking change to the DocModule constructor. To+-- maintain backward compatibility we+--+-- Parse the old DocModule constructor format (tag 5) and parse the contained+-- string into a proper ModLink structure. When writing interfaces we exclusively+-- use the new DocModule format (tag 24)  -- IMPORTANT: Since datatypes in the GHC API might change between major -- versions, and because we store GHC datatypes in our interface files, we need@@ -81,8 +123,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 711) && (__GLASGOW_HASKELL__ < 801)-binaryInterfaceVersion = 28+#if MIN_VERSION_ghc(9,6,0) && !MIN_VERSION_ghc(9,7,0)+binaryInterfaceVersion = 42  binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]@@ -110,14 +152,12 @@   put_ bh0 symtab_p_p    -- Make some intial state-  symtab_next <- newFastMutInt-  writeFastMutInt symtab_next 0+  symtab_next <- newFastMutInt 0   symtab_map <- newIORef emptyUFM   let bin_symtab = BinSymbolTable {                       bin_symtab_next = symtab_next,                       bin_symtab_map  = symtab_map }-  dict_next_ref <- newFastMutInt-  writeFastMutInt dict_next_ref 0+  dict_next_ref <- newFastMutInt 0   dict_map_ref <- newIORef emptyUFM   let bin_dict = BinDictionary {                       bin_dict_next = dict_next_ref,@@ -125,8 +165,9 @@    -- put the main thing   let bh = setUserData bh0 $ newWriteState (putName bin_symtab)+                                           (putName bin_symtab)                                            (putFastString bin_dict)-  put_ bh iface+  putInterfaceFile_ bh iface    -- write the symtab pointer at the front of the file   symtab_p <- tellBin bh@@ -153,101 +194,31 @@   return ()  -type NameCacheAccessor m = (m NameCache, NameCache -> m ())---nameCacheFromGhc :: NameCacheAccessor Ghc-nameCacheFromGhc = ( read_from_session , write_to_session )-  where-    read_from_session = do-       ref <- withSession (return . hsc_NC)-       liftIO $ readIORef ref-    write_to_session nc' = do-       ref <- withSession (return . hsc_NC)-       liftIO $ writeIORef ref nc'---freshNameCache :: NameCacheAccessor IO-freshNameCache = ( create_fresh_nc , \_ -> return () )-  where-    create_fresh_nc = do-       u  <- mkSplitUniqSupply 'a' -- ??-       return (initNameCache u [])-+freshNameCache :: IO NameCache+freshNameCache = initNameCache 'a' -- ??+                               []  -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. -- -- This function can be called in two ways.  Within a GHC session it will -- update the use and update the session's name cache.  Outside a GHC session--- a new empty name cache is used.  The function is therefore generic in the--- monad being used.  The exact monad is whichever monad the first--- argument, the getter and setter of the name cache, requires.----readInterfaceFile :: forall m.-                     MonadIO m-                  => NameCacheAccessor m+-- a new empty name cache is used.+readInterfaceFile :: NameCache                   -> FilePath-                  -> m (Either String InterfaceFile)-readInterfaceFile (get_name_cache, set_name_cache) filename = do-  bh0 <- liftIO $ readBinMem filename--  magic   <- liftIO $ get bh0-  version <- liftIO $ get bh0--  case () of-    _ | magic /= binaryInterfaceMagic -> return . Left $-      "Magic number mismatch: couldn't load interface file: " ++ filename-      | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $-      "Interface file is of wrong version: " ++ filename-      | otherwise -> with_name_cache $ \update_nc -> do--      dict  <- get_dictionary bh0--      -- read the symbol table so we are capable of reading the actual data-      bh1 <- do-          let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")-                                                   (getDictFastString dict)-          symtab <- update_nc (get_symbol_table bh1)-          return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)-                                                  (getDictFastString dict)--      -- load the actual data-      iface <- liftIO $ get bh1-      return (Right iface)- where-   with_name_cache :: forall a.-                      ((forall n b. MonadIO n-                                => (NameCache -> n (NameCache, b))-                                -> n b)-                       -> m a)-                   -> m a-   with_name_cache act = do-      nc_var <-  get_name_cache >>= (liftIO . newIORef)-      x <- act $ \f -> do-              nc <- liftIO $ readIORef nc_var-              (nc', x) <- f nc-              liftIO $ writeIORef nc_var nc'-              return x-      liftIO (readIORef nc_var) >>= set_name_cache-      return x--   get_dictionary bin_handle = liftIO $ do-      dict_p <- get bin_handle-      data_p <- tellBin bin_handle-      seekBin bin_handle dict_p-      dict <- getDictionary bin_handle-      seekBin bin_handle data_p-      return dict--   get_symbol_table bh1 theNC = liftIO $ do-      symtab_p <- get bh1-      data_p'  <- tellBin bh1-      seekBin bh1 symtab_p-      (nc', symtab) <- getSymbolTable bh1 theNC-      seekBin bh1 data_p'-      return (nc', symtab)+                  -> Bool  -- ^ Disable version check. Can cause runtime crash.+                  -> IO (Either String InterfaceFile)+readInterfaceFile name_cache filename bypass_checks = do+  bh <- readBinMem filename +  magic   <- get bh+  if magic /= binaryInterfaceMagic+    then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename+    else do+      version <- get bh+      if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility)+        then return . Left $ "Interface file is of wrong version: " ++ filename+        else Right <$> getWithUserData name_cache bh  ------------------------------------------------------------------------------- -- * Symbol table@@ -272,7 +243,7 @@  data BinSymbolTable = BinSymbolTable {         bin_symtab_next :: !FastMutInt, -- The next index to use-        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))+        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))                                 -- indexed by Name   } @@ -282,72 +253,22 @@                               bin_dict_map  = out_r}  bh f   = do     out <- readIORef out_r-    let unique = getUnique f-    case lookupUFM out unique of+    let !unique = getUnique f+    case lookupUFM_Directly out unique of         Just (j, _)  -> put_ bh (fromIntegral j :: Word32)         Nothing -> do            j <- readFastMutInt j_r            put_ bh (fromIntegral j :: Word32)            writeFastMutInt j_r (j + 1)-           writeIORef out_r $! addToUFM out unique (j, f)+           writeIORef out_r $! addToUFM_Directly out unique (j, f)   data BinDictionary = BinDictionary {         bin_dict_next :: !FastMutInt, -- The next index to use-        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))+        bin_dict_map  :: !(IORef (UniqFM FastString (Int,FastString)))                                 -- indexed by FastString   } --putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()-putSymbolTable bh next_off symtab = do-  put_ bh next_off-  let names = elems (array (0,next_off-1) (eltsUFM symtab))-  mapM_ (\n -> serialiseName bh n symtab) names---getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)-getSymbolTable bh namecache = do-  sz <- get bh-  od_names <- replicateM sz (get bh)-  let arr = listArray (0,sz-1) names-      (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names-  return (namecache', arr)---type OnDiskName = (UnitId, ModuleName, OccName)---fromOnDiskName-   :: Array Int Name-   -> NameCache-   -> OnDiskName-   -> (NameCache, Name)-fromOnDiskName _ nc (pid, mod_name, occ) =-  let-        modu  = mkModule pid mod_name-        cache = nsNames nc-  in-  case lookupOrigNameCache cache modu occ of-     Just name -> (nc, name)-     Nothing   ->-        let-                us        = nsUniqs nc-                u         = uniqFromSupply us-                name      = mkExternalName u modu occ noSrcSpan-                new_cache = extendNameCache cache modu occ name-        in-        case splitUniqSupply us of { (us',_) ->-        ( nc{ nsUniqs = us', nsNames = new_cache }, name )-        }---serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()-serialiseName bh name _ = do-  let modu = nameModule name-  put_ bh (moduleUnitId modu, moduleName modu, nameOccName name)-- ------------------------------------------------------------------------------- -- * GhcBinary instances -------------------------------------------------------------------------------@@ -357,44 +278,60 @@   put_ bh m = put_ bh (Map.toList m)   get bh = fmap (Map.fromList) (get bh) +instance Binary PackageInfo where+  put_ bh PackageInfo { piPackageName, piPackageVersion } = do+    put_ bh (unPackageName piPackageName)+    put_ bh (showVersion piPackageVersion)+  get bh = do+    name <- PackageName <$> get bh+    versionString <- get bh+    let version = case readP_to_S parseVersion versionString of+          [] -> makeVersion []+          vs -> fst (last vs)+    return $ PackageInfo name version  instance Binary InterfaceFile where-  put_ bh (InterfaceFile env ifaces) = do+  put_ bh (InterfaceFile env info ifaces) = do     put_ bh env+    put_ bh info     put_ bh ifaces    get bh = do     env    <- get bh+    info   <- get bh     ifaces <- get bh-    return (InterfaceFile env ifaces)+    return (InterfaceFile env info ifaces)  +putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO ()+putInterfaceFile_ bh (InterfaceFile env info ifaces) = do+  put_ bh env+  put_ bh info+  put_ bh ifaces+ instance Binary InstalledInterface where-  put_ bh (InstalledInterface modu info docMap argMap-           exps visExps opts subMap fixMap) = do+  put_ bh (InstalledInterface modu is_sig info docMap argMap+           exps visExps opts fixMap) = do     put_ bh modu+    put_ bh is_sig     put_ bh info-    put_ bh docMap-    put_ bh argMap+    lazyPut bh (docMap, argMap)     put_ bh exps     put_ bh visExps     put_ bh opts-    put_ bh subMap     put_ bh fixMap    get bh = do     modu    <- get bh+    is_sig  <- get bh     info    <- get bh-    docMap  <- get bh-    argMap  <- get bh+    ~(docMap, argMap) <- lazyGet bh     exps    <- get bh     visExps <- get bh     opts    <- get bh-    subMap  <- get bh     fixMap  <- get bh--    return (InstalledInterface modu info docMap argMap-            exps visExps opts subMap fixMap)+    return (InstalledInterface modu is_sig info docMap argMap+            exps visExps opts fixMap)   instance Binary DocOption where@@ -433,7 +370,7 @@         result <- get bh         return (Example expression result) -instance Binary Hyperlink where+instance Binary a => Binary (Hyperlink a) where     put_ bh (Hyperlink url label) = do         put_ bh url         put_ bh label@@ -442,6 +379,15 @@         label <- get bh         return (Hyperlink url label) +instance Binary a => Binary (ModLink a) where+    put_ bh (ModLink m label) = do+        put_ bh m+        put_ bh label+    get bh = do+        m <- get bh+        label <- get bh+        return (ModLink m label)+ instance Binary Picture where     put_ bh (Picture uri title) = do         put_ bh uri@@ -460,9 +406,40 @@         t <- get bh         return (Header l t) +instance Binary a => Binary (Table a) where+    put_ bh (Table h b) = do+        put_ bh h+        put_ bh b+    get bh = do+        h <- get bh+        b <- get bh+        return (Table h b)++instance Binary a => Binary (TableRow a) where+    put_ bh (TableRow cs) = put_ bh cs+    get bh = do+        cs <- get bh+        return (TableRow cs)++instance Binary a => Binary (TableCell a) where+    put_ bh (TableCell i j c) = do+        put_ bh i+        put_ bh j+        put_ bh c+    get bh = do+        i <- get bh+        j <- get bh+        c <- get bh+        return (TableCell i j c)+ instance Binary Meta where-  put_ bh Meta { _version = v } = put_ bh v-  get bh = (\v -> Meta { _version = v }) <$> get bh+    put_ bh (Meta v p) = do+        put_ bh v+        put_ bh p+    get bh = do+        v <- get bh+        p <- get bh+        return (Meta v p)  instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where   put_ bh MetaDoc { _meta = m, _doc = d } = do@@ -489,9 +466,6 @@     put_ bh (DocIdentifier ae) = do             putByte bh 4             put_ bh ae-    put_ bh (DocModule af) = do-            putByte bh 5-            put_ bh af     put_ bh (DocEmphasis ag) = do             putByte bh 6             put_ bh ag@@ -543,6 +517,13 @@     put_ bh (DocMathDisplay x) = do             putByte bh 22             put_ bh x+    put_ bh (DocTable x) = do+            putByte bh 23+            put_ bh x+    -- See note [The DocModule story]+    put_ bh (DocModule af) = do+            putByte bh 24+            put_ bh af      get bh = do             h <- getByte bh@@ -562,9 +543,13 @@               4 -> do                     ae <- get bh                     return (DocIdentifier ae)+              -- See note [The DocModule story]               5 -> do                     af <- get bh-                    return (DocModule af)+                    return $ DocModule ModLink+                      { modLinkName  = af+                      , modLinkLabel = Nothing+                      }               6 -> do                     ag <- get bh                     return (DocEmphasis ag)@@ -616,6 +601,13 @@               22 -> do                     x <- get bh                     return (DocMathDisplay x)+              23 -> do+                    x <- get bh+                    return (DocTable x)+              -- See note [The DocModule story]+              24 -> do+                    af <- get bh+                    return (DocModule af)               _ -> error "invalid binary data found in the interface file"  @@ -663,3 +655,28 @@         name <- get bh         return (Undocumented name)       _ -> error "get DocName: Bad h"++instance Binary n => Binary (Wrap n) where+  put_ bh (Unadorned n) = do+    putByte bh 0+    put_ bh n+  put_ bh (Parenthesized n) = do+    putByte bh 1+    put_ bh n+  put_ bh (Backticked n) = do+    putByte bh 2+    put_ bh n++  get bh = do+    h <- getByte bh+    case h of+      0 -> do+        name <- get bh+        return (Unadorned name)+      1 -> do+        name <- get bh+        return (Parenthesized name)+      2 -> do+        name <- get bh+        return (Backticked name)+      _ -> error "get Wrap: Bad h"
src/Haddock/ModuleTree.hs view
@@ -14,45 +14,45 @@  import Haddock.Types ( MDoc ) -import GHC           ( Name )-import Module        ( Module, moduleNameString, moduleName, moduleUnitId, unitIdString )-import DynFlags      ( DynFlags )-import Packages      ( lookupPackage )-import PackageConfig ( sourcePackageIdString )+import GHC             ( Name )+import GHC.Unit.Module ( Module, moduleNameString, moduleName, moduleUnit, unitString )+import GHC.Unit.State  ( UnitState, lookupUnit, unitPackageIdString ) +import qualified Control.Applicative as A -data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]-mkModuleTree dflags showPkgs mods =-  foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]++mkModuleTree :: UnitState -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]+mkModuleTree state showPkgs mods =+  foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]   where-    modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_))+    modPkg mod_ | showPkgs = Just (unitString (moduleUnit mod_))                 | otherwise = Nothing-    modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString-                                     (lookupPackage dflags (moduleUnitId mod_))+    modSrcPkg mod_ | showPkgs = fmap unitPackageIdString+                                     (lookupUnit state (moduleUnit mod_))                    | otherwise = Nothing-    fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short+    fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short  -addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]-addToTrees [] _ _ _ ts = ts-addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short-addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)-  | s1 >  s2  = t : addToTrees (s1:ss) pkg srcPkg short ts-  | s1 == s2  = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts-  | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts+addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree]+addToTrees [] _ _ _ _ ts = ts+addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short+addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts)+  | s1 >  s2  = t : addToTrees (s1:ss) m pkg srcPkg short ts+  | s1 == s2  = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts+  | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts  where   this_pkg = if null ss then pkg else node_pkg   this_srcPkg = if null ss then srcPkg else node_srcPkg   this_short = if null ss then short else node_short  -mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]-mkSubTree []     _   _      _     = []-mkSubTree [s]    pkg srcPkg short = [Node s True pkg srcPkg short []]-mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)]+mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree]+mkSubTree []     _ _   _      _     = []+mkSubTree [s]    m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []]+mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)]   splitModule :: Module -> [String]
src/Haddock/Options.hs view
@@ -15,6 +15,7 @@ module Haddock.Options (   parseHaddockOpts,   Flag(..),+  Visibility(..),   getUsage,   optTitle,   outputDir,@@ -24,25 +25,38 @@   optSourceCssFile,   sourceUrls,   wikiUrls,+  baseUrl,+  optParCount,   optDumpInterfaceFile,+  optShowInterfaceFile,   optLaTeXStyle,   optMathjax,   qualification,+  sinceQualification,   verbosity,   ghcFlags,+  reexportFlags,   readIfaceArgs,   optPackageName,-  optPackageVersion+  optPackageVersion,+  modulePackageInfo,+  ignoredSymbols ) where   import qualified Data.Char as Char+import           Data.List (dropWhileEnd)+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import qualified Data.Set as Set import           Data.Version-import           Distribution.Verbosity-import           FastString+import           Control.Applicative+import           GHC.Data.FastString+import           GHC ( Module, moduleUnit )+import           GHC.Unit.State import           Haddock.Types import           Haddock.Utils-import           Packages import           System.Console.GetOpt import qualified Text.ParserCombinators.ReadP as RP @@ -53,6 +67,7 @@ --  | Flag_DocBook   | Flag_ReadInterface String   | Flag_DumpInterface String+  | Flag_ShowInterface String   | Flag_Heading String   | Flag_Html   | Flag_Hoogle@@ -64,10 +79,12 @@   | Flag_SourceEntityURL  String   | Flag_SourceLEntityURL String   | Flag_WikiBaseURL   String+  | Flag_BaseURL       String   | Flag_WikiModuleURL String   | Flag_WikiEntityURL String   | Flag_LaTeX   | Flag_LaTeXStyle String+  | Flag_QuickJumpIndex   | Flag_HyperlinkedSource   | Flag_SourceCss String   | Flag_Mathjax String@@ -76,12 +93,15 @@   | Flag_Version   | Flag_CompatibleInterfaceVersions   | Flag_InterfaceVersion+  | Flag_BypassInterfaceVersonCheck   | Flag_UseContents String   | Flag_GenContents   | Flag_UseIndex String   | Flag_GenIndex   | Flag_IgnoreAllExports   | Flag_HideModule String+  | Flag_ShowModule String+  | Flag_ShowAllModules   | Flag_ShowExtensions String   | Flag_OptGhc String   | Flag_GhcLibDir String@@ -96,6 +116,10 @@   | Flag_NoPrintMissingDocs   | Flag_PackageName String   | Flag_PackageVersion String+  | Flag_Reexport String+  | Flag_SinceQualification String+  | Flag_IgnoreLinkSymbol String+  | Flag_ParCount (Maybe Int)   deriving (Eq, Show)  @@ -112,6 +136,8 @@       "read an interface from FILE",     Option ['D']  ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")       "write the resulting interface to FILE",+    Option []     ["show-interface"] (ReqArg Flag_ShowInterface "FILE")+      "print the interface in a human readable form", --    Option ['S']  ["docbook"]  (NoArg Flag_DocBook) --  "output in DocBook XML",     Option ['h']  ["html"]     (NoArg Flag_Html)@@ -122,6 +148,8 @@     Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",     Option []  ["hoogle"]     (NoArg Flag_Hoogle)       "output for Hoogle; you may want --package-name and --package-version too",+    Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex)+      "generate an index for interactive documentation navigation",     Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)       "generate highlighted and hyperlinked source code (for use with --html)",     Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")@@ -137,6 +165,8 @@       "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",     Option []  ["comments-base"]   (ReqArg Flag_WikiBaseURL "URL")       "URL for a comments link on the contents\nand index pages",+    Option [] ["base-url"] (ReqArg Flag_BaseURL "URL")+      "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.",     Option []  ["comments-module"]  (ReqArg Flag_WikiModuleURL "URL")       "URL for a comments link for each module\n(using the %{MODULE} var)",     Option []  ["comments-entity"]  (ReqArg Flag_WikiEntityURL "URL")@@ -159,6 +189,8 @@       "output compatible interface file versions and exit",     Option []  ["interface-version"]  (NoArg Flag_InterfaceVersion)       "output interface file version and exit",+    Option []  ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)+      "bypass the interface file version check (dangerous)",     Option ['v']  ["verbosity"]  (ReqArg Flag_Verbosity "VERBOSITY")       "set verbosity level",     Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")@@ -170,9 +202,13 @@     Option [] ["gen-index"] (NoArg Flag_GenIndex)       "generate an HTML index from specified\ninterfaces",     Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)-      "behave as if all modules have the\nignore-exports atribute",+      "behave as if all modules have the\nignore-exports attribute",     Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")       "behave as if MODULE has the hide attribute",+    Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")+      "behave as if MODULE does not have the hide attribute",+    Option [] ["show-all"] (NoArg Flag_ShowAllModules)+      "behave as if not modules have the hide attribute",     Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")       "behave as if MODULE has the show-extensions attribute",     Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")@@ -190,10 +226,18 @@       "generate html with newlines and indenting (for use with --html)",     Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)       "don't print information about any undocumented entities",+    Option []  ["reexport"] (ReqArg Flag_Reexport "MOD")+      "reexport the module MOD, adding it to the index",     Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")       "name of the package being documented",     Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")-      "version of the package being documented in usual x.y.z.w format"+      "version of the package being documented in usual x.y.z.w format",+    Option []  ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")+      "package qualification of @since, one of\n'always' (default) or 'only-external'",+    Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")+      "name of a symbol which does not trigger a warning in case of link issue",+    Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")+      "load modules in parallel"   ]  @@ -267,17 +311,23 @@   ,optLast [str | Flag_WikiEntityURL str <- flags])  +baseUrl :: [Flag] -> Maybe String+baseUrl flags = optLast [str | Flag_BaseURL str <- flags]+ optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optShowInterfaceFile :: [Flag] -> Maybe FilePath+optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ]  optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] - optMathjax :: [Flag] -> Maybe String optMathjax flags = optLast [ str | Flag_Mathjax str <- flags ] +optParCount :: [Flag] -> Maybe (Maybe Int)+optParCount flags = optLast [ n | Flag_ParCount n <- flags ]  qualification :: [Flag] -> Either String QualOption qualification flags =@@ -291,34 +341,114 @@       [arg]          -> Left $ "unknown qualification type " ++ show arg       _:_            -> Left "qualification option given multiple times" +sinceQualification :: [Flag] -> Either String SinceQual+sinceQualification flags =+  case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of+      []             -> Right Always+      ["always"]     -> Right Always+      ["external"]   -> Right External+      [arg]          -> Left $ "unknown since-qualification type " ++ show arg+      _:_            -> Left "since-qualification option given multiple times"  verbosity :: [Flag] -> Verbosity verbosity flags =   case [ str | Flag_Verbosity str <- flags ] of-    []  -> normal+    []  -> Normal     x:_ -> case parseVerbosity x of       Left e -> throwE e       Right v -> v +-- | Get the ignored symbols from the given flags. These are the symbols for+-- which no link warnings will be generated if their link destinations cannot be+-- determined.+--+-- Symbols may be provided as qualified or unqualified names (e.g.+-- 'Data.Map.dropWhileEnd' or 'dropWhileEnd', resp). If qualified, no link+-- warnings will be produced for occurances of that name when it is imported+-- from that module. If unqualified, no link warnings will be produced for any+-- occurances of that name from any module.+ignoredSymbols :: [Flag] -> Map (Maybe String) (Set String)+ignoredSymbols flags =+    foldr addToMap Map.empty [ splitSymbol symbol | Flag_IgnoreLinkSymbol symbol <- flags ]+  where+    -- Split a symbol into its module name and unqualified name, producing+    -- 'Nothing' for the module name if the given symbol is already unqualified+    splitSymbol :: String -> (Maybe String, String)+    splitSymbol s =+      -- Drop the longest suffix not containing a '.' character+      case dropWhileEnd (/= '.') s of +        -- If the longest suffix is empty, there was no '.'.+        -- Assume it is an unqualified name (no module string).+        "" -> (Nothing, s)++        -- If the longest suffix is not empty, there was a '.'.+        -- Assume it is a qualified name. `s'` will be the module string followed+        -- by the last '.', e.g. "Data.List.", so take `init s'` as the module+        -- string. Drop the length of `s'` from the original string `s` to+        -- obtain to the unqualified name.+        s' -> (Just $ init s', drop (length s') s)++    -- Add a (module name, name) pair to the map from modules to their ignored+    -- symbols+    addToMap :: (Maybe String, String) -> Map (Maybe String) (Set String) -> Map (Maybe String) (Set String)+    addToMap (m, name) symbs = Map.insertWith (Set.union) m (Set.singleton name) symbs+ ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] +reexportFlags :: [Flag] -> [String]+reexportFlags flags = [ option | Flag_Reexport option <- flags ] -readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]+data Visibility = Visible | Hidden+  deriving (Eq, Show)++readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)] readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]   where-    parseIfaceOption :: String -> (DocPaths, FilePath)+    parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)     parseIfaceOption str =       case break (==',') str of         (fpath, ',':rest) ->           case break (==',') rest of-            (src, ',':file) -> ((fpath, Just src), file)-            (file, _) -> ((fpath, Nothing), file)-        (file, _) -> (("", Nothing), file)+            (src, ',':rest') ->+              let src' = case src of+                    "" -> Nothing+                    _  -> Just src+              in+              case break (==',') rest' of+                (visibility, ',':file) | visibility == "hidden" ->+                  ((fpath, src'), Hidden, file)+                                       | otherwise ->+                  ((fpath, src'), Visible, file)+                (file, _) ->+                  ((fpath, src'), Visible, file)+            (file, _) -> ((fpath, Nothing), Visible, file)+        (file, _) -> (("", Nothing), Visible, file)   -- | Like 'listToMaybe' but returns the last element instead of the first. optLast :: [a] -> Maybe a optLast [] = Nothing optLast xs = Just (last xs)+++-- | This function has a potential to return 'Nothing' because package name and+-- versions can no longer reliably be extracted in all cases: if the package is+-- not installed yet then this info is no longer available.+--+-- The @--package-name@ and @--package-version@ Haddock flags allow the user to+-- specify this information manually and it is returned here if present.+modulePackageInfo :: UnitState+                  -> [Flag] -- ^ Haddock flags are checked as they may contain+                            -- the package name or version provided by the user+                            -- which we prioritise+                  -> Maybe Module+                  -> (Maybe PackageName, Maybe Data.Version.Version)+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)+modulePackageInfo unit_state flags (Just modu) =+  ( optPackageName flags    <|> fmap unitPackageName pkgDb+  , optPackageVersion flags <|> fmap unitPackageVersion pkgDb+  )+  where+    pkgDb = lookupUnit unit_state (moduleUnit modu)
src/Haddock/Parser.hs view
@@ -1,8 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving-             , FlexibleInstances, UndecidableInstances-             , IncoherentInstances #-}-{-# LANGUAGE LambdaCase #-} -- | -- Module      :  Haddock.Parser -- Copyright   :  (c) Mateusz Kowalczyk 2013,@@ -19,26 +14,43 @@                       ) where  import qualified Documentation.Haddock.Parser as P-import DynFlags (DynFlags)-import FastString (mkFastString) import Documentation.Haddock.Types-import Lexer (mkPState, unP, ParseResult(POk))-import Parser (parseIdentifier)-import RdrName (RdrName)-import SrcLoc (mkRealSrcLoc, unLoc)-import StringBuffer (stringToStringBuffer)+import Haddock.Types -parseParas :: DynFlags -> String -> MetaDoc mod RdrName-parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas+import GHC.Driver.Session ( DynFlags )+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Data.FastString   ( fsLit )+import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) )+import GHC.Parser       ( parseIdentifier )+import GHC.Types.Name.Occurrence ( occNameString )+import GHC.Types.Name.Reader ( RdrName(..) )+import GHC.Types.SrcLoc ( mkRealSrcLoc, GenLocated(..) )+import GHC.Data.StringBuffer ( stringToStringBuffer ) -parseString :: DynFlags -> String -> DocH mod RdrName++parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)+parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p++parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName) parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> String -> Maybe RdrName-parseIdent dflags str0 =-  let buffer = stringToStringBuffer str0-      realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0-      pstate = mkPState dflags buffer realSrcLc-  in case unP parseIdentifier pstate of-    POk _ name -> Just (unLoc name)-    _ -> Nothing+parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)+parseIdent dflags ns str0 =+  case unP parseIdentifier (pstate str1) of+    POk _ (L _ name)+      -- Guards against things like 'Q.--', 'Q.case', etc.+      -- See https://github.com/haskell/haddock/issues/952 and Trac #14109+      | Qual _ occ <- name+      , PFailed{} <- unP parseIdentifier (pstate (occNameString occ))+      -> Nothing+      | otherwise+      -> Just (wrap (NsRdrName ns name))+    PFailed{} -> Nothing+  where+    realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0+    pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc+    (wrap,str1) = case str0 of+                    '(' : s@(c : _) | c /= ',', c /= ')'  -- rule out tuple names+                                    -> (Parenthesized, init s)+                    '`' : s@(_ : _) -> (Backticked,    init s)+                    _               -> (Unadorned,     str0)
src/Haddock/Syb.hs view
@@ -1,25 +1,25 @@ {-# LANGUAGE Rank2Types #-}-+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Haddock.Syb-    ( everything, everythingWithState, everywhere+    ( everythingWithState+    , everywhereButType     , mkT-    , combine+    , mkQ+    , extQ     ) where   import Data.Data-import Control.Applicative----- | Perform a query on each level of a tree.------ This is stolen directly from SYB package and copied here to not introduce--- additional dependencies.-everything :: (r -> r -> r) -> (forall a. Data a => a -> r)-           -> (forall a. Data a => a -> r)-everything k f x = foldl k (f x) (gmapQ (everything k f) x)+import Data.Maybe+import Data.Foldable +-- | Returns true if a == t.+-- requires AllowAmbiguousTypes+isType :: forall a b. (Typeable a, Typeable b) => b -> Bool+isType _ = isJust $ eqT @a @b  -- | Perform a query with state on each level of a tree. --@@ -31,15 +31,24 @@                     -> (forall a. Data a => a -> r) everythingWithState s k f x =     let (r, s') = f x s-    in foldl k r (gmapQ (everythingWithState s' k f) x)-+    in foldl' k r (gmapQ (everythingWithState s' k f) x) --- | Apply transformation on each level of a tree.---+-- | Variation on everywhere with an extra stop condition -- Just like 'everything', this is stolen from SYB package.-everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)-everywhere f = f . gmapT (everywhere f)+everywhereBut :: (forall a. Data a => a -> Bool)+  -> (forall a. Data a => a -> a)+  -> (forall a. Data a => a -> a)+everywhereBut q f x+    | q x       = x+    | otherwise = f (gmapT (everywhereBut q f) x) +-- | Variation of "everywhere" that does not recurse into children of type t+-- requires AllowAmbiguousTypes+everywhereButType :: forall t . (Typeable t)+  => (forall a. Data a => a -> a)+  -> (forall a. Data a => a -> a)+everywhereButType = everywhereBut (isType @t)+ -- | Create generic transformation. -- -- Another function stolen from SYB package.@@ -48,8 +57,17 @@     Just f' -> f'     Nothing -> id --- | Combine two queries into one using alternative combinator.-combine :: Alternative f => (forall a. Data a => a -> f r)-                         -> (forall a. Data a => a -> f r)-                         -> (forall a. Data a => a -> f r)-combine f g x = f x <|> g x+-- | Create generic query.+--+-- Another function stolen from SYB package.+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = case cast a of+                        Just b  -> br b+                        Nothing -> r+++-- | Extend a generic query by a type-specific case.+--+-- Another function stolen from SYB package.+extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q+extQ f g a = maybe (f a) g (cast a)
src/Haddock/Types.hs view
@@ -1,7 +1,21 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Types@@ -24,27 +38,28 @@   , module Documentation.Haddock.Types  ) where -import Control.Exception-import Control.Arrow hiding ((<+>)) import Control.DeepSeq-import Data.Typeable+import Control.Exception (throw)+import Control.Monad.Catch+import Control.Monad.State.Strict+import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data)-import qualified Data.Map as Map+import qualified Data.Set as Set import Documentation.Haddock.Types-import BasicTypes (Fixity(..))+import qualified GHC.Data.Strict as Strict+import GHC.Types.Fixity (Fixity(..))+import GHC.Types.Name (stableNameCmp)+import GHC.Types.Name.Reader (RdrName(..))+import GHC.Types.SourceText (SourceText(..))+import GHC.Types.SrcLoc (BufSpan(..), BufPos(..))+import GHC.Types.Var (Specificity) -import GHC hiding (NoLink)-import DynFlags (Language)+import GHC+import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt-import Coercion-import NameSet-import OccName-import Outputable-import Control.Applicative (Applicative(..))-import Control.Monad (ap)--import Haddock.Backends.Hyperlinker.Types+import GHC.Types.Name.Occurrence+import GHC.Utils.Outputable  ----------------------------------------------------------------------------- -- * Convenient synonyms@@ -56,17 +71,17 @@ type DocMap a      = Map Name (MDoc a) type ArgMap a      = Map Name (Map Int (MDoc a)) type SubMap        = Map Name [Name]-type DeclMap       = Map Name [LHsDecl Name]-type InstMap       = Map SrcSpan Name+type DeclMap       = Map Name DeclMapEntry+type InstMap       = Map RealSrcSpan Name type FixMap        = Map Name Fixity type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources+type WarningMap    = Map Name (Doc Name)   -------------------------------------------------------------------------------- * Interface+-- * Interfaces and Interface creation ----------------------------------------------------------------------------- - -- | 'Interface' holds all information used to render a single Haddock page. -- It represents the /interface/ of a module. The core business of Haddock -- lies in creating this structure. Note that the record contains some fields@@ -77,6 +92,9 @@     -- | The module behind this interface.     ifaceMod             :: !Module +    -- | Is this a signature?+  , ifaceIsSig           :: !Bool+     -- | Original file name of the module.   , ifaceOrigFilename    :: !FilePath @@ -90,149 +108,186 @@   , ifaceRnDoc           :: !(Documentation DocName)      -- | Haddock options for this module (prune, ignore-exports, etc).-  , ifaceOptions         :: ![DocOption]+  , ifaceOptions         :: [DocOption]      -- | Declarations originating from the module. Excludes declarations without     -- names (instances and stand-alone documentation comments). Includes     -- names of subordinate declarations mapped to their parent declarations.-  , ifaceDeclMap         :: !(Map Name [LHsDecl Name])+  , ifaceDeclMap         :: !DeclMap      -- | Documentation of declarations originating from the module (including     -- subordinates).   , ifaceDocMap          :: !(DocMap Name)   , ifaceArgMap          :: !(ArgMap Name) -    -- | Documentation of declarations originating from the module (including-    -- subordinates).-  , ifaceRnDocMap        :: !(DocMap DocName)-  , ifaceRnArgMap        :: !(ArgMap DocName)--  , ifaceSubMap          :: !(Map Name [Name])   , ifaceFixMap          :: !(Map Name Fixity) -  , ifaceExportItems     :: ![ExportItem Name]-  , ifaceRnExportItems   :: ![ExportItem DocName]+  , ifaceExportItems     :: [ExportItem GhcRn]+  , ifaceRnExportItems   :: [ExportItem DocNameI]      -- | All names exported by the module.-  , ifaceExports         :: ![Name]+  , ifaceExports         :: [Name]      -- | All \"visible\" names exported by the module.     -- A visible name is a name that will show up in the documentation of the     -- module.-  , ifaceVisibleExports  :: ![Name]+  , ifaceVisibleExports  :: [Name]      -- | Aliases of module imports as in @import A.B.C as C@.   , ifaceModuleAliases   :: !AliasMap      -- | Instances exported by the module.-  , ifaceInstances       :: ![ClsInst]-  , ifaceFamInstances    :: ![FamInst]+  , ifaceInstances       :: [HaddockClsInst]      -- | Orphan instances-  , ifaceOrphanInstances :: ![DocInstance Name]-  , ifaceRnOrphanInstances :: ![DocInstance DocName]+  , ifaceOrphanInstances   :: [DocInstance GhcRn]+  , ifaceRnOrphanInstances :: [DocInstance DocNameI]      -- | The number of haddockable and haddocked items in the module, as a     -- tuple. Haddockable items are the exports and the module itself.-  , ifaceHaddockCoverage :: !(Int, Int)+  , ifaceHaddockCoverage :: (Int, Int)      -- | Warnings for things defined in this module.-  , ifaceWarningMap :: !WarningMap+  , ifaceWarningMap :: WarningMap -    -- | Tokenized source code of module (avaliable if Haddock is invoked with+    -- | Tokenized source code of module (available if Haddock is invoked with     -- source generation flag).-  , ifaceTokenizedSrc :: !(Maybe [RichToken])-  }--type WarningMap = Map Name (Doc Name)+  , ifaceHieFile :: !(Maybe FilePath) +  , ifaceDynFlags :: !DynFlags+  }  -- | A subset of the fields of 'Interface' that we store in the interface -- files. data InstalledInterface = InstalledInterface   {     -- | The module represented by this interface.-    instMod            :: Module+    instMod              :: Module +    -- | Is this a signature?+  , instIsSig            :: Bool+     -- | Textual information about the module.-  , instInfo           :: HaddockModInfo Name+  , instInfo             :: HaddockModInfo Name      -- | Documentation of declarations originating from the module (including     -- subordinates).-  , instDocMap         :: DocMap Name+  , instDocMap           :: DocMap Name -  , instArgMap         :: ArgMap Name+  , instArgMap           :: ArgMap Name      -- | All names exported by this module.-  , instExports        :: [Name]+  , instExports          :: [Name]      -- | All \"visible\" names exported by the module.     -- A visible name is a name that will show up in the documentation of the     -- module.-  , instVisibleExports :: [Name]+  , instVisibleExports   :: [Name]      -- | Haddock options for this module (prune, ignore-exports, etc).-  , instOptions        :: [DocOption]+  , instOptions          :: [DocOption] -  , instSubMap         :: Map Name [Name]-  , instFixMap         :: Map Name Fixity+  , instFixMap           :: Map Name Fixity   } - -- | Convert an 'Interface' to an 'InstalledInterface' toInstalledIface :: Interface -> InstalledInterface toInstalledIface interface = InstalledInterface-  { instMod            = ifaceMod            interface-  , instInfo           = ifaceInfo           interface-  , instDocMap         = ifaceDocMap         interface-  , instArgMap         = ifaceArgMap         interface-  , instExports        = ifaceExports        interface-  , instVisibleExports = ifaceVisibleExports interface-  , instOptions        = ifaceOptions        interface-  , instSubMap         = ifaceSubMap         interface-  , instFixMap         = ifaceFixMap         interface+  { instMod              = ifaceMod              interface+  , instIsSig            = ifaceIsSig            interface+  , instInfo             = ifaceInfo             interface+  , instDocMap           = ifaceDocMap           interface+  , instArgMap           = ifaceArgMap           interface+  , instExports          = ifaceExports          interface+  , instVisibleExports   = ifaceVisibleExports   interface+  , instOptions          = ifaceOptions          interface+  , instFixMap           = ifaceFixMap           interface   }  --------------------------------------------------------------------------------- * Export items & declarations------------------------------------------------------------------------------+-- | A monad in which we create Haddock interfaces. Not to be confused with+-- `GHC.Tc.Types.IfM` which is used to write GHC interfaces.+--+-- In the past `createInterface` was running in the `Ghc` monad but proved hard+-- to sustain as soon as we moved over for Haddock to be a plugin. Also abstracting+-- over the Ghc specific clarifies where side effects happen.+newtype IfM m a = IfM { unIfM :: StateT (IfEnv m) m a } +deriving newtype instance Functor m                => Functor (IfM m)+deriving newtype instance (Monad m, Applicative m) => Applicative (IfM m)+deriving newtype instance Monad m                  => Monad (IfM m)+deriving newtype instance MonadIO m                => MonadIO (IfM m)+deriving newtype instance Monad m                  => MonadState (IfEnv m) (IfM m) -data ExportItem name+-- | Interface creation environment. The name sets are used primarily during+-- processing of doc strings to avoid emitting the same type of warning for the+-- same name twice. This was previously done using a Writer monad and then+-- nubbing the list of warning messages after accumulation. This new approach+-- was implemented to avoid the nubbing of potentially large lists of strings.+data IfEnv m = IfEnv+  {+    -- | Lookup names in the environment.+    ifeLookupName :: Name -> m (Maybe TyThing) -  -- | An exported declaration.-  = ExportDecl+    -- | Names which we have warned about for being out of scope+  , ifeOutOfScopeNames :: !(Set.Set String)++    -- | Names which we have warned about for being ambiguous+  , ifeAmbiguousNames  :: !(Set.Set String)++    -- | Named which we have warned about for being inappropriately namespaced+    -- as values+  , ifeInvalidValues   :: !(Set.Set String)+  }++-- | Run an `IfM` action.+runIfM+  :: (Monad m)+  -- | Lookup a global name in the current session. Used in cases+  -- where declarations don't+  => (Name -> m (Maybe TyThing))+  -- | The action to run.+  -> IfM m a+  -- | Result and accumulated error/warning messages.+  -> m a+runIfM lookup_name action = do+  let+    if_env = IfEnv       {-        -- | A declaration.-        expItemDecl :: !(LHsDecl name)+        ifeLookupName      = lookup_name+      , ifeOutOfScopeNames = Set.empty+      , ifeAmbiguousNames  = Set.empty+      , ifeInvalidValues   = Set.empty+      }+  evalStateT (unIfM action) if_env -        -- | Maybe a doc comment, and possibly docs for arguments (if this-        -- decl is a function or type-synonym).-      , expItemMbDoc :: !(DocForDecl name)+-- | Look up a name in the current environment+lookupName :: Monad m => Name -> IfM m (Maybe TyThing)+lookupName name = IfM $ do+  lookup_name <- gets ifeLookupName+  lift (lookup_name name) -        -- | Subordinate names, possibly with documentation.-      , expItemSubDocs :: ![(name, DocForDecl name)]+-- | Very basic logging function that simply prints to stdout+warn :: MonadIO m => String -> IfM m ()+warn msg = liftIO $ putStrLn msg -        -- | Instances relevant to this declaration, possibly with-        -- documentation.-      , expItemInstances :: ![DocInstance name]+-----------------------------------------------------------------------------+-- * Export items & declarations+----------------------------------------------------------------------------- -        -- | Fixity decls relevant to this declaration (including subordinates).-      , expItemFixities :: ![(name, Fixity)] -        -- | Whether the ExportItem is from a TH splice or not, for generating-        -- the appropriate type of Source link.-      , expItemSpliced :: !Bool-      }+data ExportItem name +  -- | An exported declaration.+  = ExportDecl (XExportDecl name)+   -- | An exported entity for which we have no documentation (perhaps because it   -- resides in another package).   | ExportNoDecl-      { expItemName :: !name+      { expItemName :: !(IdP name)          -- | Subordinate names.-      , expItemSubs :: ![name]+      , expItemSubs :: [IdP name]       }    -- | A section heading.@@ -245,31 +300,115 @@       , expItemSectionId :: !String          -- | Section heading text.-      , expItemSectionText :: !(Doc name)+      , expItemSectionText :: !(Doc (IdP name))       }    -- | Some documentation.-  | ExportDoc !(MDoc name)+  | ExportDoc !(MDoc (IdP name))    -- | A cross-reference to another module.   | ExportModule !Module +-- | A type family mapping a name type index to types of export declarations.+-- The pre-renaming type index ('GhcRn') is mapped to the type of export+-- declarations which do not include Hoogle output ('ExportD'), since Hoogle output is+-- generated during the Haddock renaming step. The post-renaming type index+-- ('DocNameI') is mapped to the type of export declarations which do include+-- Hoogle output ('RnExportD').+type family XExportDecl x where+  XExportDecl GhcRn    = ExportD GhcRn+  XExportDecl DocNameI = RnExportD++-- | Represents an export declaration that Haddock has discovered to be exported+-- from a module. The @name@ index indicated whether the declaration has been+-- renamed such that each 'Name' points to it's optimal link destination.+data ExportD name = ExportD+      {+        -- | A declaration.+        expDDecl :: !(LHsDecl name)++        -- | Bundled patterns for a data type declaration+      , expDPats :: [(HsDecl name, DocForDecl (IdP name))]++        -- | Maybe a doc comment, and possibly docs for arguments (if this+        -- decl is a function or type-synonym).+      , expDMbDoc :: !(DocForDecl (IdP name))++        -- | Subordinate names, possibly with documentation.+      , expDSubDocs :: [(IdP name, DocForDecl (IdP name))]++        -- | Instances relevant to this declaration, possibly with+        -- documentation.+      , expDInstances :: [DocInstance name]++        -- | Fixity decls relevant to this declaration (including subordinates).+      , expDFixities :: [(IdP name, Fixity)]++        -- | Whether the ExportD is from a TH splice or not, for generating+        -- the appropriate type of Source link.+      , expDSpliced :: !Bool+      }++-- | Represents export declarations that have undergone renaming such that every+-- 'Name' in the declaration points to an optimal link destination. Since Hoogle+-- output is also generated during the renaming step, each declaration is also+-- attached to its Hoogle textual database entries, /if/ Hoogle output is+-- enabled and the module is not hidden in the generated documentation using the+-- @{-# OPTIONS_HADDOCK hide #-}@ pragma.+data RnExportD = RnExportD+      {+        -- | The renamed export declaration+        rnExpDExpD :: !(ExportD DocNameI)++      -- | If Hoogle textbase (textual database) output is enabled, the text+      -- output lines for this declaration. If Hoogle output is not enabled, the+      -- list will be empty.+      , rnExpDHoogle :: [String]+      }+ data Documentation name = Documentation-  { documentationDoc :: Maybe (MDoc name)-  , documentationWarning :: !(Maybe (Doc name))+  { documentationDoc     :: Maybe (MDoc name)+  , documentationWarning :: Maybe (Doc name)   } deriving Functor +instance NFData name => NFData (Documentation name) where+  rnf (Documentation d w) = d `deepseq` w `deepseq` ()  -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (MDoc name) type DocForDecl name = (Documentation name, FnArgsDoc name) - noDocForDecl :: DocForDecl name-noDocForDecl = (Documentation Nothing Nothing, Map.empty)+noDocForDecl = (Documentation Nothing Nothing, mempty) +-- | As we build the declaration map, we really only care to track whether we+-- have only seen a value declaration for a 'Name', or anything else. This type+-- is used to represent those cases. If the only declaration attached to a+-- 'Name' is a 'ValD', we will consult the GHC interface file to determine the+-- type of the value, and attach the 'SrcSpan' from the 'EValD' constructor to+-- it. If we see any other type of declaration for the 'Name', we can just use+-- it.+--+-- This type saves us from storing /every/ declaration we see for a given 'Name'+-- in the map, which is unnecessary and very problematic for overall memory+-- usage.+data DeclMapEntry+    = EValD !SrcSpan+    | EOther (LHsDecl GhcRn) +instance Semigroup DeclMapEntry where+  (EValD _)   <> e         = e+  e           <> _         = e++-- | Transform a declaration into a 'DeclMapEntry'. If it is a 'ValD'+-- declaration, only the source location will be noted (since that is all we+-- care to store in the 'DeclMap' due to the way top-level bindings with no type+-- signatures are handled). Otherwise, the entire declaration will be kept.+toDeclMapEntry :: LHsDecl GhcRn -> DeclMapEntry+toDeclMapEntry (L l (ValD _ _)) = EValD (locA l)+toDeclMapEntry d                = EOther d+ ----------------------------------------------------------------------------- -- * Cross-referencing -----------------------------------------------------------------------------@@ -278,6 +417,15 @@ -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | An 'RdrName' tagged with some type/value namespace information.+data NsRdrName = NsRdrName+  { namespace :: !Namespace+  , rdrName :: !RdrName+  }++instance NFData NsRdrName where+  rnf (NsRdrName ns rdrN) = ns `seq` rdrN `deepseq` ()+ -- | Extends 'Name' with cross-reference information. data DocName   = Documented Name Module@@ -289,15 +437,17 @@      -- documentation, as far as Haddock knows.   deriving (Eq, Data) -type instance PostRn DocName NameSet  = PlaceHolder-type instance PostRn DocName Fixity   = PlaceHolder-type instance PostRn DocName Bool     = PlaceHolder-type instance PostRn DocName [Name]   = PlaceHolder+data DocNameI -type instance PostTc DocName Kind     = PlaceHolder-type instance PostTc DocName Type     = PlaceHolder-type instance PostTc DocName Coercion = PlaceHolder+type instance NoGhcTc DocNameI = DocNameI +type instance IdP DocNameI = DocName++instance CollectPass DocNameI where+  collectXXPat _ ext = dataConCantHappen ext+  collectXXHsBindsLR ext = dataConCantHappen ext+  collectXSplicePat _ ext = dataConCantHappen ext+ instance NamedThing DocName where   getName (Documented name _) = name   getName (Undocumented name) = name@@ -326,12 +476,93 @@     setName name' (Documented _ mdl) = Documented name' mdl     setName name' (Undocumented _) = Undocumented name' +-- | Adds extra "wrapper" information to a name.+--+-- This is to work around the fact that most name types in GHC ('Name', 'RdrName',+-- 'OccName', ...) don't include backticks or parens.+data Wrap n+  = Unadorned { unwrap :: n  }     -- ^ don't do anything to the name+  | Parenthesized { unwrap :: n }  -- ^ add parentheses around the name+  | Backticked { unwrap :: n }     -- ^ add backticks around the name+  deriving (Show, Functor, Foldable, Traversable) +instance NFData n => NFData (Wrap n) where+  rnf w = case w of+    Unadorned n     -> rnf n+    Parenthesized n -> rnf n+    Backticked n    -> rnf n +-- | Useful for debugging+instance Outputable n => Outputable (Wrap n) where+  ppr (Unadorned n)     = ppr n+  ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ]+  ppr (Backticked n)    = hcat [ char '`', ppr n, char '`' ]++showWrapped :: (a -> String) -> Wrap a -> String+showWrapped f (Unadorned n) = f n+showWrapped f (Parenthesized n) = "(" ++ f n ++ ")"+showWrapped f (Backticked n) = "`" ++ f n ++ "`"++instance HasOccName DocName where++    occName = occName . getName+ ----------------------------------------------------------------------------- -- * Instances ----------------------------------------------------------------------------- +data HaddockClsInst = HaddockClsInst+    { haddockClsInstPprHoogle :: Maybe String+    , haddockClsInstName      :: Name+    , haddockClsInstClsName   :: Name+    , haddockClsInstIsOrphan  :: Bool+    , haddockClsInstHead      :: ([Int], SName, [SimpleType])+    , haddockClsInstSynified  :: InstHead GhcRn+    , haddockClsInstTyNames   :: Set.Set Name+    }++-- | TODO: This instance is not lawful. We leave the 'InstHead' segment of the+-- class instance evaluated only to WHNF. This should probably be fixed.+instance NFData HaddockClsInst where+  rnf (HaddockClsInst h n cn o hd s ns) =+              h+    `deepseq` n+    `deepseq` cn+    `deepseq` o+    `deepseq` hd+    `deepseq` s+    `seq`     ns+    `deepseq` ()++-- | Stable name for stable comparisons. GHC's `Name` uses unstable+-- ordering based on their `Unique`'s.+newtype SName = SName Name+  deriving newtype NFData++instance Eq SName where+  SName n1 == SName n2 = n1 `stableNameCmp` n2 == EQ++instance Ord SName where+  SName n1 `compare` SName n2 = n1 `stableNameCmp` n2++-- | Simplified type for sorting types, ignoring qualification (not visible+-- in Haddock output) and unifying special tycons with normal ones.+-- For the benefit of the user (looks nice and predictable) and the+-- tests (which prefer output to be deterministic).+data SimpleType = SimpleType SName [SimpleType]+                | SimpleIntTyLit Integer+                | SimpleStringTyLit String+                | SimpleCharTyLit Char+                  deriving (Eq,Ord)++instance NFData SimpleType where+  rnf st =+    case st of+      SimpleType sn sts   -> sn `deepseq` sts `deepseq` ()+      SimpleIntTyLit i    -> rnf i+      SimpleStringTyLit s -> rnf s+      SimpleCharTyLit c   -> rnf c+ -- | The three types of instances data InstType name   = ClassInst@@ -343,7 +574,8 @@   | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)   | DataInst (TyClDecl name)        -- ^ Data constructors -instance OutputableBndr a => Outputable (InstType a) where+instance (OutputableBndrId p)+         => Outputable (InstType (GhcPass p)) where   ppr (ClassInst { .. }) = text "ClassInst"       <+> ppr clsiCtx       <+> ppr clsiTyVars@@ -361,13 +593,13 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl     { pfdInfo :: FamilyInfo name-    , pfdLName :: Located name+    , pfdLName :: LocatedN (IdP name)     , pfdTyVars :: [LHsType name]     , pfdKindSig :: LFamilyResultSig name     }  -mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name+mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl     { pfdInfo = fdInfo     , pfdLName = fdLName@@ -375,21 +607,21 @@     , pfdKindSig = fdResultSig     }   where-    mkType (KindedTyVar (L loc name) lkind) =-        HsKindSig tvar lkind+    mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn+    mkType (KindedTyVar _ _ (L loc name) lkind) =+        HsKindSig noAnn tvar lkind       where-        tvar = L loc (HsTyVar (L loc name))-    mkType (UserTyVar name) = HsTyVar name+        tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name))+    mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name   -- | An instance head that may have documentation and a source location.-type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)+type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name), Maybe Module) --- | The head of an instance. Consists of a class name, a list of kind--- parameters, a list of type parameters and an instance type+-- | The head of an instance. Consists of a class name, a list of type+-- parameters (which may be annotated with kinds), and an instance type data InstHead name = InstHead-    { ihdClsName :: name-    , ihdKinds :: [HsType name]+    { ihdClsName :: IdP name     , ihdTypes :: [HsType name]     , ihdInstType :: InstType name     }@@ -419,9 +651,17 @@  type LDoc id = Located (Doc id) -type Doc id = DocH (ModuleName, OccName) id-type MDoc id = MetaDoc (ModuleName, OccName) id+type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id)+type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id) +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a++instance NFData Meta where+  rnf (Meta v p) = v `deepseq` p `deepseq` ()++instance NFData id => NFData (MDoc id) where+  rnf (MetaDoc m d) = m `deepseq` d `deepseq` ()+ instance (NFData a, NFData mod)          => NFData (DocH mod a) where   rnf doc = case doc of@@ -448,6 +688,7 @@     DocProperty a             -> a `deepseq` ()     DocExamples a             -> a `deepseq` ()     DocHeader a               -> a `deepseq` ()+    DocTable a                -> a `deepseq` ()  #if !MIN_VERSION_ghc(8,0,2) -- These were added to GHC itself in 8.0.2@@ -459,47 +700,45 @@ instance NFData id => NFData (Header id) where   rnf (Header a b) = a `deepseq` b `deepseq` () -instance NFData Hyperlink where+instance NFData id => NFData (Hyperlink id) where   rnf (Hyperlink a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (ModLink id) where+  rnf (ModLink a b) = a `deepseq` b `deepseq` ()+ instance NFData Picture where   rnf (Picture a b) = a `deepseq` b `deepseq` ()  instance NFData Example where   rnf (Example a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (Table id) where+    rnf (Table h b) = h `deepseq` b `deepseq` () +instance NFData id => NFData (TableRow id) where+    rnf (TableRow cs) = cs `deepseq` ()++instance NFData id => NFData (TableCell id) where+    rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` ()+ exampleToString :: Example -> String exampleToString (Example expression result) =     ">>> " ++ expression ++ "\n" ++  unlines result --data DocMarkup id a = Markup-  { markupEmpty                :: a-  , markupString               :: String -> a-  , markupParagraph            :: a -> a-  , markupAppend               :: a -> a -> a-  , markupIdentifier           :: id -> a-  , markupIdentifierUnchecked  :: (ModuleName, OccName) -> a-  , markupModule               :: String -> a-  , markupWarning              :: a -> a-  , markupEmphasis             :: a -> a-  , markupBold                 :: a -> a-  , markupMonospaced           :: a -> a-  , markupUnorderedList        :: [a] -> a-  , markupOrderedList          :: [a] -> a-  , markupDefList              :: [(a,a)] -> a-  , markupCodeBlock            :: a -> a-  , markupHyperlink            :: Hyperlink -> a-  , markupAName                :: String -> a-  , markupPic                  :: Picture -> a-  , markupMathInline           :: String -> a-  , markupMathDisplay          :: String -> a-  , markupProperty             :: String -> a-  , markupExample              :: [Example] -> a-  , markupHeader               :: Header a -> a-  }+instance NFData name => NFData (HaddockModInfo name) where+  rnf (HaddockModInfo{..}) =+              hmi_description+    `deepseq` hmi_copyright+    `deepseq` hmi_license+    `deepseq` hmi_maintainer+    `deepseq` hmi_stability+    `deepseq` hmi_portability+    `deepseq` hmi_safety+    `deepseq` hmi_language+    `deepseq` hmi_extensions+    `deepseq` () +instance NFData LangExt.Extension  data HaddockModInfo name = HaddockModInfo   { hmi_description :: Maybe (Doc name)@@ -513,7 +752,6 @@   , hmi_extensions  :: [LangExt.Extension]   } - emptyHaddockModInfo :: HaddockModInfo a emptyHaddockModInfo = HaddockModInfo   { hmi_description = Nothing@@ -584,97 +822,321 @@     OptFullQual       -> FullQual     OptNoQual         -> NoQual +-- | Whether to hide empty contexts+-- Since pattern synonyms have two contexts with different semantics, it is+-- important to all of them, even if one of them is empty.+data HideEmptyContexts+  = HideEmptyContexts+  | ShowEmptyToplevelContexts +-- | When to qualify @since@ annotations with their package+data SinceQual+  = Always+  | External -- ^ only qualify when the thing being annotated is from+             -- an external package+ ----------------------------------------------------------------------------- -- * Error handling ----------------------------------------------------------------------------- +-- | Haddock's own exception type.+data HaddockException+  = HaddockException String+  | WithContext [String] SomeException+  deriving Typeable --- A monad which collects error messages, locally defined to avoid a dep on mtl+instance Show HaddockException where+  show (HaddockException str) = str+  show (WithContext ctxts se)  = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se] +throwE :: String -> a+instance Exception HaddockException+throwE str = throw (HaddockException str) -type ErrMsg = String-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }+withExceptionContext :: MonadCatch m => String -> m a -> m a+withExceptionContext ctxt =+  handle (\ex ->+      case ex of+        HaddockException _ -> throwM $ WithContext [ctxt] (toException ex)+        WithContext ctxts se -> throwM $ WithContext (ctxt:ctxts) se+          ) .+  handle (throwM . WithContext [ctxt]) +-----------------------------------------------------------------------------+-- * Pass sensitive types+----------------------------------------------------------------------------- -instance Functor ErrMsgM where-        fmap f (Writer (a, msgs)) = Writer (f a, msgs)+type instance XRec DocNameI a = GenLocated (Anno a) a+instance UnXRec DocNameI where+  unXRec = unLoc+instance MapXRec DocNameI where+  mapXRec = fmap+instance WrapXRec DocNameI (HsType DocNameI) where+  wrapXRec = noLocA -instance Applicative ErrMsgM where-    pure a = Writer (a, [])-    (<*>)  = ap+type instance Anno DocName                           = SrcSpanAnnN+type instance Anno (HsTyVarBndr flag DocNameI)       = SrcSpanAnnA+type instance Anno [LocatedA (HsType DocNameI)]      = SrcSpanAnnC+type instance Anno (HsType DocNameI)                 = SrcSpanAnnA+type instance Anno (DataFamInstDecl DocNameI)        = SrcSpanAnnA+type instance Anno (DerivStrategy DocNameI)          = SrcAnn NoEpAnns+type instance Anno (FieldOcc DocNameI)               = SrcAnn NoEpAnns+type instance Anno (ConDeclField DocNameI)           = SrcSpan+type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan+type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan+type instance Anno (ConDecl DocNameI)                = SrcSpan+type instance Anno (FunDep DocNameI)                 = SrcSpan+type instance Anno (TyFamInstDecl DocNameI)          = SrcSpanAnnA+type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL+type instance Anno (FamilyDecl DocNameI)               = SrcSpan+type instance Anno (Sig DocNameI)                      = SrcSpan+type instance Anno (InjectivityAnn DocNameI)           = SrcAnn NoEpAnns+type instance Anno (HsDecl DocNameI)                   = SrcSpanAnnA+type instance Anno (FamilyResultSig DocNameI)          = SrcAnn NoEpAnns+type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA+type instance Anno (HsSigType DocNameI)                     = SrcSpanAnnA -instance Monad ErrMsgM where-        return   = pure-        m >>= k  = Writer $ let-                (a, w)  = runWriter m-                (b, w') = runWriter (k a)-                in (b, w ++ w')+type XRecCond a+  = ( XParTy a           ~ EpAnn AnnParen+    , NoGhcTc a ~ a+    , MapXRec a+    , UnXRec a+    , WrapXRec a (HsType a)+    ) +type instance XForAllTy        DocNameI = EpAnn [AddEpAnn]+type instance XQualTy          DocNameI = EpAnn [AddEpAnn]+type instance XTyVar           DocNameI = EpAnn [AddEpAnn]+type instance XStarTy          DocNameI = EpAnn [AddEpAnn]+type instance XAppTy           DocNameI = EpAnn [AddEpAnn]+type instance XAppKindTy       DocNameI = EpAnn [AddEpAnn]+type instance XFunTy           DocNameI = EpAnn [AddEpAnn]+type instance XListTy          DocNameI = EpAnn AnnParen+type instance XTupleTy         DocNameI = EpAnn AnnParen+type instance XSumTy           DocNameI = EpAnn AnnParen+type instance XOpTy            DocNameI = EpAnn [AddEpAnn]+type instance XParTy           DocNameI = EpAnn AnnParen+type instance XIParamTy        DocNameI = EpAnn [AddEpAnn]+type instance XKindSig         DocNameI = EpAnn [AddEpAnn]+type instance XSpliceTy        DocNameI = DataConCantHappen+type instance XDocTy           DocNameI = EpAnn [AddEpAnn]+type instance XBangTy          DocNameI = EpAnn [AddEpAnn]+type instance XRecTy           DocNameI = EpAnn [AddEpAnn]+type instance XExplicitListTy  DocNameI = EpAnn [AddEpAnn]+type instance XExplicitTupleTy DocNameI = EpAnn [AddEpAnn]+type instance XTyLit           DocNameI = EpAnn [AddEpAnn]+type instance XWildCardTy      DocNameI = EpAnn [AddEpAnn]+type instance XXType           DocNameI = HsCoreTy -tell :: [ErrMsg] -> ErrMsgM ()-tell w = Writer ((), w)+type instance XNumTy           DocNameI = NoExtField+type instance XStrTy           DocNameI = NoExtField+type instance XCharTy          DocNameI = NoExtField+type instance XXTyLit          DocNameI = DataConCantHappen +type instance XHsForAllVis        DocNameI = NoExtField+type instance XHsForAllInvis      DocNameI = NoExtField+type instance XXHsForAllTelescope DocNameI = DataConCantHappen --- Exceptions+type instance XUserTyVar    DocNameI = NoExtField+type instance XKindedTyVar  DocNameI = NoExtField+type instance XXTyVarBndr   DocNameI = DataConCantHappen +type instance XCFieldOcc   DocNameI = DocName+type instance XXFieldOcc   DocNameI = NoExtField --- | Haddock's own exception type.-data HaddockException = HaddockException String deriving Typeable+type instance XFixitySig   DocNameI = NoExtField+type instance XFixSig      DocNameI = NoExtField+type instance XPatSynSig   DocNameI = NoExtField+type instance XClassOpSig  DocNameI = NoExtField+type instance XTypeSig     DocNameI = NoExtField+type instance XMinimalSig  DocNameI = NoExtField +type instance XForeignExport  DocNameI = NoExtField+type instance XForeignImport  DocNameI = NoExtField -instance Show HaddockException where-  show (HaddockException str) = str+type instance XCImport  DocNameI = NoExtField+type instance XCExport  DocNameI = NoExtField +type instance XXForeignImport DocNameI = DataConCantHappen+type instance XXForeignExport DocNameI = DataConCantHappen -throwE :: String -> a-instance Exception HaddockException-throwE str = throw (HaddockException str)+type instance XConDeclGADT    DocNameI = NoExtField+type instance XConDeclH98     DocNameI = NoExtField+type instance XXConDecl       DocNameI = DataConCantHappen +type instance XDerivD     DocNameI = NoExtField+type instance XInstD      DocNameI = NoExtField+type instance XForD       DocNameI = NoExtField+type instance XSigD       DocNameI = NoExtField+type instance XTyClD      DocNameI = NoExtField --- In "Haddock.Interface.Create", we need to gather--- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,--- but we can't just use @GhcT ErrMsgM@ because GhcT requires the--- transformed monad to be MonadIO.-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }---instance MonadIO ErrMsgGhc where---  liftIO = WriterGhc . fmap (\a->(a,[])) liftIO---er, implementing GhcMonad involves annoying ExceptionMonad and---WarnLogMonad classes, so don't bother.-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a-liftErrMsg = WriterGhc . return . runWriter---  for now, use (liftErrMsg . tell) for this---tell :: [ErrMsg] -> ErrMsgGhc ()---tell msgs = WriterGhc $ return ( (), msgs )+type instance XNoSig            DocNameI = NoExtField+type instance XCKindSig         DocNameI = NoExtField+type instance XTyVarSig         DocNameI = NoExtField+type instance XXFamilyResultSig DocNameI = DataConCantHappen +type instance XCFamEqn       DocNameI _ = NoExtField+type instance XXFamEqn       DocNameI _ = DataConCantHappen -instance Functor ErrMsgGhc where-  fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)+type instance XCClsInstDecl DocNameI = NoExtField+type instance XCDerivDecl   DocNameI = NoExtField+type instance XStockStrategy    DocNameI = NoExtField+type instance XAnyClassStrategy DocNameI = NoExtField+type instance XNewtypeStrategy  DocNameI = NoExtField+type instance XViaStrategy  DocNameI = LHsSigType DocNameI+type instance XDataFamInstD DocNameI = NoExtField+type instance XTyFamInstD   DocNameI = NoExtField+type instance XClsInstD     DocNameI = NoExtField+type instance XCHsDataDefn  DocNameI = NoExtField+type instance XCFamilyDecl  DocNameI = NoExtField+type instance XClassDecl    DocNameI = NoExtField+type instance XDataDecl     DocNameI = NoExtField+type instance XSynDecl      DocNameI = NoExtField+type instance XFamDecl      DocNameI = NoExtField+type instance XXFamilyDecl  DocNameI = DataConCantHappen+type instance XXTyClDecl    DocNameI = DataConCantHappen -instance Applicative ErrMsgGhc where-    pure a = WriterGhc (return (a, []))-    (<*>) = ap+type instance XHsWC DocNameI _ = NoExtField -instance Monad ErrMsgGhc where-  return = pure-  m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->-               fmap (second (msgs1 ++)) (runWriterGhc (k a))+type instance XHsOuterExplicit    DocNameI _ = NoExtField+type instance XHsOuterImplicit    DocNameI   = NoExtField+type instance XXHsOuterTyVarBndrs DocNameI   = DataConCantHappen +type instance XHsSig      DocNameI = NoExtField+type instance XXHsSigType DocNameI = DataConCantHappen +type instance XHsQTvs        DocNameI = NoExtField+type instance XConDeclField  DocNameI = NoExtField+type instance XXConDeclField DocNameI = DataConCantHappen++type instance XXPat DocNameI = DataConCantHappen+type instance XXHsBindsLR DocNameI a = DataConCantHappen++type instance XSplicePat DocNameI = DataConCantHappen++type instance XCInjectivityAnn DocNameI = NoExtField++type instance XCFunDep DocNameI = NoExtField++type instance XCTyFamInstDecl DocNameI = NoExtField+ -------------------------------------------------------------------------------- * Pass sensitive types+-- * NFData instances for GHC types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet        = PlaceHolder-type instance PostRn DocName Fixity         = PlaceHolder-type instance PostRn DocName Bool           = PlaceHolder-type instance PostRn DocName Name           = DocName-type instance PostRn DocName (Located Name) = Located DocName-type instance PostRn DocName [Name]         = PlaceHolder-type instance PostRn DocName DocName        = DocName+instance NFData RdrName where+  rnf (Unqual on) = rnf on+  rnf (Qual mn on) = mn `deepseq` on `deepseq` ()+  rnf (Orig m on) = m `deepseq` on `deepseq` ()+  rnf (Exact n) = rnf n -type instance PostTc DocName Kind     = PlaceHolder-type instance PostTc DocName Type     = PlaceHolder-type instance PostTc DocName Coercion = PlaceHolder+instance NFData SourceText where+  rnf NoSourceText   = ()+  rnf (SourceText s) = rnf s++instance NFData FixityDirection where+  rnf InfixL = ()+  rnf InfixR = ()+  rnf InfixN = ()++instance NFData Fixity where+  rnf (Fixity sourceText n dir) =+    sourceText `deepseq` n `deepseq` dir `deepseq` ()++instance NFData ann => NFData (SrcSpanAnn' ann) where+  rnf (SrcSpanAnn a ss) = a `deepseq` ss `deepseq` ()++instance NFData (EpAnn NameAnn) where+  rnf EpAnnNotUsed = ()+  rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` ()++instance NFData NameAnn where+  rnf (NameAnn a b c d e) =+              a+    `deepseq` b+    `deepseq` c+    `deepseq` d+    `deepseq` e+    `deepseq` ()+  rnf (NameAnnCommas a b c d e) =+              a+    `deepseq` b+    `deepseq` c+    `deepseq` d+    `deepseq` e+    `deepseq` ()+  rnf (NameAnnBars a b c d e) =+              a+    `deepseq` b+    `deepseq` c+    `deepseq` d+    `deepseq` e+    `deepseq` ()+  rnf (NameAnnOnly a b c d) =+              a+    `deepseq` b+    `deepseq` c+    `deepseq` d+    `deepseq` ()+  rnf (NameAnnRArrow a b) =+              a+    `deepseq` b+    `deepseq` ()+  rnf (NameAnnQuote a b c) =+              a+    `deepseq` b+    `deepseq` c+    `deepseq` ()+  rnf (NameAnnTrailing a) = rnf a++instance NFData TrailingAnn where+  rnf (AddSemiAnn epaL)  = rnf epaL+  rnf (AddCommaAnn epaL) = rnf epaL+  rnf (AddVbarAnn epaL)  = rnf epaL++instance NFData NameAdornment where+  rnf NameParens     = ()+  rnf NameParensHash = ()+  rnf NameBackquotes = ()+  rnf NameSquare     = ()++instance NFData EpaLocation where+  rnf (EpaSpan ss bs)  = ss `seq` bs `deepseq` ()+  rnf (EpaDelta dp lc) = dp `seq` lc `deepseq` ()++instance NFData EpAnnComments where+  rnf (EpaComments cs) = rnf cs+  rnf (EpaCommentsBalanced cs1 cs2) = cs1 `deepseq` cs2 `deepseq` ()++instance NFData EpaComment where+  rnf (EpaComment t rss) = t `deepseq` rss `seq` ()++instance NFData EpaCommentTok where+  rnf (EpaDocComment ds)  = rnf ds+  rnf (EpaDocOptions s)   = rnf s+  rnf (EpaLineComment s)  = rnf s+  rnf (EpaBlockComment s) = rnf s+  rnf EpaEofComment       = ()+++instance NFData a => NFData (Strict.Maybe a) where+  rnf Strict.Nothing  = ()+  rnf (Strict.Just x) = rnf x++instance NFData BufSpan where+  rnf (BufSpan p1 p2) = p1 `deepseq` p2 `deepseq` ()++instance NFData BufPos where+  rnf (BufPos n) = rnf n++instance NFData Anchor where+  rnf (Anchor ss op) = ss `seq` op `deepseq` ()++instance NFData AnchorOperation where+  rnf UnchangedAnchor  = ()+  rnf (MovedAnchor dp) = rnf dp++instance NFData DeltaPos where+  rnf (SameLine n)        = rnf n+  rnf (DifferentLine n m) = n `deepseq` m `deepseq` ()+
src/Haddock/Utils.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Utils@@ -13,17 +16,12 @@ ----------------------------------------------------------------------------- module Haddock.Utils ( -  -- * Misc utilities-  restrictTo, emptyHsQTvs,-  toDescription, toInstalledDescription,-  mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes,-   -- * Filename utilities   moduleHtmlFile, moduleHtmlFile',-  contentsHtmlFile, indexHtmlFile,-  moduleIndexFrameName, mainFrameName, synopsisFrameName,+  contentsHtmlFile, indexHtmlFile, indexJsonFile,   subIndexHtmlFile,-  jsFile,+  haddockJsFile, jsQuickJumpFile,+  quickJumpCssFile,    -- * Anchor and URL utilities   moduleNameUrl, moduleNameUrl', moduleUrl,@@ -31,25 +29,21 @@   makeAnchorId,    -- * Miscellaneous utilities-  getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,+  getProgramName, bye, die, escapeStr,+  writeUtf8File, withTempDir,    -- * HTML cross reference mapping   html_xrefs_ref, html_xrefs_ref',    -- * Doc markup-  markup,-  idMarkup,   mkMeta,    -- * List utilities   replace,   spanWith, -  -- * MTL stuff-  MonadIO(..),-   -- * Logging-  parseVerbosity,+  parseVerbosity, Verbosity(..), silent, normal, verbose, deafening,   out,    -- * System tools@@ -59,44 +53,54 @@  import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types-import Haddock.GhcUtils  import GHC-import Name-import NameSet ( emptyNameSet )-import HsTypes (selectorFieldOcc)+import GHC.Types.Name -import Control.Monad ( liftM )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Catch ( MonadMask, bracket_ ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf )-import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit-import System.IO ( hPutStr, stderr )+import System.Directory ( createDirectory, removeDirectoryRecursive )+import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath-import Distribution.Verbosity-import Distribution.ReadE  #ifndef mingw32_HOST_OS import qualified System.Posix.Internals #endif -import MonadUtils ( MonadIO(..) )-- -------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- +data Verbosity = Silent | Normal | Verbose | Deafening+  deriving (Eq, Ord, Enum, Bounded, Show) -parseVerbosity :: String -> Either String Verbosity-parseVerbosity = runReadE flagToVerbosity+silent, normal, verbose, deafening :: Verbosity+silent    = Silent+normal    = Normal+verbose   = Verbose+deafening = Deafening +-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing.+parseVerbosity :: String -> Either String Verbosity+parseVerbosity "0" = Right Silent+parseVerbosity "1" = Right Normal+parseVerbosity "2" = Right Silent+parseVerbosity "3" = Right Deafening+parseVerbosity "silent"    = return Silent+parseVerbosity "normal"    = return Normal+parseVerbosity "verbose"   = return Verbose+parseVerbosity "debug"     = return Deafening+parseVerbosity "deafening" = return Deafening+parseVerbosity other = Left ("Can't parse verbosity " ++ other)  -- | Print a message to stdout, if it is not too verbose out :: MonadIO m@@ -113,129 +117,14 @@ --------------------------------------------------------------------------------  --- | Extract a module's short description.-toDescription :: Interface -> Maybe (MDoc Name)-toDescription = fmap mkMeta . hmi_description . ifaceInfo ---- | Extract a module's short description.-toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)-toInstalledDescription = fmap mkMeta . hmi_description . instInfo- mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name--- Dubious, because the implicit binders are empty even--- though the type might have free varaiables-mkEmptySigWcType ty = mkEmptyImplicitBndrs (mkEmptyWildCardBndrs ty)--addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name--- Add the class context to a class-op signature-addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype))-  = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype))))-          -- The mkEmptySigWcType is suspicious-  where-    go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty }))-       = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty })-    go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))-       = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty })-    go (L loc ty)-       = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })--    extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0)-    add_ctxt (L loc preds) = L loc (extra_pred : preds)--addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine--lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]-lHsQTyVarsToTypes tvs-  = [ noLoc (HsTyVar (noLoc (hsLTyVarName tv)))-    | tv <- hsQTvExplicit tvs ]- ----------------------------------------------------------------------------------- * Making abstract declarations------------------------------------------------------------------------------------restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name-restrictTo names (L loc decl) = L loc $ case decl of-  TyClD d | isDataDecl d  ->-    TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })-  TyClD d | isClassDecl d ->-    TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),-               tcdATs = restrictATs names (tcdATs d) })-  _ -> decl--restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })-  | DataType <- new_or_data-  = defn { dd_cons = restrictCons names cons }-  | otherwise    -- Newtype-  = case restrictCons names cons of-      []    -> defn { dd_ND = DataType, dd_cons = [] }-      [con] -> defn { dd_cons = [con] }-      _ -> error "Should not happen"--restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]-  where-    keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) =-      case getConDetails h98d of-        PrefixCon _ -> Just d-        RecCon fields-          | all field_avail (unL fields) -> Just d-          | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) })-          -- if we have *all* the field names available, then-          -- keep the record declaration.  Otherwise degrade to-          -- a constructor declaration.  This isn't quite right, but-          -- it's the best we can do.-        InfixCon _ _ -> Just d-      where-        h98d = h98ConDecl d-        h98ConDecl c@ConDeclH98{} = c-        h98ConDecl c@ConDeclGADT{} = c'-          where-            (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)-            c' :: ConDecl Name-            c' = ConDeclH98-                   { con_name = head (con_names c)-                   , con_qvars = Just $ HsQTvs { hsq_implicit = mempty-                                               , hsq_explicit = tvs-                                               , hsq_dependent = emptyNameSet }-                   , con_cxt = Just cxt-                   , con_details = details-                   , con_doc = con_doc c-                   }--        field_avail :: LConDeclField Name -> Bool-        field_avail (L _ (ConDeclField fs _ _))-            = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs-        field_types flds = [ t | ConDeclField _ t _ <- flds ]--    keep _ = Nothing--restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]-restrictDecls names = mapMaybe (filterLSigNames (`elem` names))---restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]--emptyHsQTvs :: LHsQTyVars Name--- This function is here, rather than in HsTypes, because it *renamed*, but--- does not necessarily have all the rigt kind variables.  It is used--- in Haddock just for printing, so it doesn't matter-emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs"-                     , hsq_explicit = []-                     , hsq_dependent = error "haddock:emptyHsQTvs" }----------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. -------------------------------------------------------------------------------- - baseName :: ModuleName -> FilePath baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString @@ -256,16 +145,10 @@     Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]  -contentsHtmlFile, indexHtmlFile :: String+contentsHtmlFile, indexHtmlFile, indexJsonFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html"----moduleIndexFrameName, mainFrameName, synopsisFrameName :: String-moduleIndexFrameName = "modules"-mainFrameName = "main"-synopsisFrameName = "synopsis"+indexJsonFile = "doc-index.json"   subIndexHtmlFile :: String -> String@@ -326,17 +209,22 @@ -------------------------------------------------------------------------------  -jsFile :: String-jsFile    = "haddock-util.js"+haddockJsFile :: String+haddockJsFile = "haddock-bundle.min.js" +jsQuickJumpFile :: String+jsQuickJumpFile = "quick-jump.min.js" +quickJumpCssFile :: String+quickJumpCssFile = "quick-jump.css"+ ------------------------------------------------------------------------------- -- * Misc. -------------------------------------------------------------------------------   getProgramName :: IO String-getProgramName = liftM (`withoutSuffix` ".bin") getProgName+getProgramName = fmap (`withoutSuffix` ".bin") getProgName    where str `withoutSuffix` suff             | suff `isSuffixOf` str = take (length str - length suff) str             | otherwise             = str@@ -345,25 +233,6 @@ bye :: String -> IO a bye s = putStr s >> exitSuccess --dieMsg :: String -> IO ()-dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)---noDieMsg :: String -> IO ()-noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)---mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]-mapSnd _ [] = []-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs---mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)-mapMaybeM _ Nothing = return Nothing-mapMaybeM f (Just a) = liftM Just (f a)-- escapeStr :: String -> String escapeStr = escapeURIString isUnreserved @@ -400,7 +269,20 @@ isDigitChar c    = c >= '0' && c <= '9' isAlphaNumChar c = isAlphaChar c || isDigitChar c +-- | Utility to write output to UTF-8 encoded files.+--+-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from+-- 'getLocaleEncoding', and on some platforms (like Windows) this default+-- encoding isn't enough for the characters we want to write.+writeUtf8File :: FilePath -> String -> IO ()+writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do+    hSetEncoding h utf8+    hPutStr h contents +withTempDir :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a+withTempDir dir = bracket_ (liftIO $ createDirectory dir)+                           (liftIO $ removeDirectoryRecursive dir)+ ----------------------------------------------------------------------------- -- * HTML cross references --@@ -447,71 +329,6 @@ spanWith p xs@(a:as)   | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)   | otherwise     = ([],xs)----------------------------------------------------------------------------------- * Put here temporarily---------------------------------------------------------------------------------markup :: DocMarkup id a -> Doc id -> a-markup m DocEmpty                    = markupEmpty m-markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)-markup m (DocString s)               = markupString m s-markup m (DocParagraph d)            = markupParagraph m (markup m d)-markup m (DocIdentifier x)           = markupIdentifier m x-markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x-markup m (DocModule mod0)            = markupModule m mod0-markup m (DocWarning d)              = markupWarning m (markup m d)-markup m (DocEmphasis d)             = markupEmphasis m (markup m d)-markup m (DocBold d)                 = markupBold m (markup m d)-markup m (DocMonospaced d)           = markupMonospaced m (markup m d)-markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)-markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)-markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)-markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)-markup m (DocHyperlink l)            = markupHyperlink m l-markup m (DocAName ref)              = markupAName m ref-markup m (DocPic img)                = markupPic m img-markup m (DocMathInline mathjax)     = markupMathInline m mathjax-markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax-markup m (DocProperty p)             = markupProperty m p-markup m (DocExamples e)             = markupExample m e-markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))---markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)-markupPair m (a,b) = (markup m a, markup m b)----- | The identity markup-idMarkup :: DocMarkup a (Doc a)-idMarkup = Markup {-  markupEmpty                = DocEmpty,-  markupString               = DocString,-  markupParagraph            = DocParagraph,-  markupAppend               = DocAppend,-  markupIdentifier           = DocIdentifier,-  markupIdentifierUnchecked  = DocIdentifierUnchecked,-  markupModule               = DocModule,-  markupWarning              = DocWarning,-  markupEmphasis             = DocEmphasis,-  markupBold                 = DocBold,-  markupMonospaced           = DocMonospaced,-  markupUnorderedList        = DocUnorderedList,-  markupOrderedList          = DocOrderedList,-  markupDefList              = DocDefList,-  markupCodeBlock            = DocCodeBlock,-  markupHyperlink            = DocHyperlink,-  markupAName                = DocAName,-  markupPic                  = DocPic,-  markupMathInline           = DocMathInline,-  markupMathDisplay          = DocMathDisplay,-  markupProperty             = DocProperty,-  markupExample              = DocExamples,-  markupHeader               = DocHeader-  }-  ----------------------------------------------------------------------------- -- * System tools
+ src/Haddock/Utils/Json.hs view
@@ -0,0 +1,558 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}++-- | Minimal JSON / RFC 7159 support+--+-- The API is heavily inspired by @aeson@'s API but puts emphasis on+-- simplicity rather than performance. The 'ToJSON' instances are+-- intended to have an encoding compatible with @aeson@'s encoding.+--+module Haddock.Utils.Json+    ( Value(..)+    , Object, object, Pair, (.=)+    , encodeToString+    , encodeToBuilder+    , ToJSON(toJSON)++    , Parser(..)+    , Result(..)+    , FromJSON(parseJSON)+    , withObject+    , withArray+    , withString+    , withDouble+    , withBool+    , fromJSON+    , parse+    , parseEither+    , (.:)+    , (.:?)+    , decode+    , decodeWith+    , eitherDecode+    , eitherDecodeWith+    , decodeFile+    , eitherDecodeFile+    )+    where++import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus (..), zipWithM, (>=>))+import qualified Control.Monad as Monad+import qualified Control.Monad.Fail as Fail++import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB+import Data.Char+import Data.Int+import Data.Word+import Data.List (intersperse)+import Data.Monoid++import GHC.Natural++-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'++import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy+import qualified Text.ParserCombinators.Parsec as Parsec++import Haddock.Utils.Json.Types+import Haddock.Utils.Json.Parser+++infixr 8 .=++-- | A key-value pair for encoding a JSON object.+(.=) :: ToJSON v => String -> v -> Pair+k .= v  = (k, toJSON v)+++-- | A type that can be converted to JSON.+class ToJSON a where+  -- | Convert a Haskell value to a JSON-friendly intermediate type.+  toJSON :: a -> Value++instance ToJSON () where+  toJSON () = Array []++instance ToJSON Value where+  toJSON = id++instance ToJSON Bool where+  toJSON = Bool++instance ToJSON a => ToJSON [a] where+  toJSON = Array . map toJSON++instance ToJSON a => ToJSON (Maybe a) where+  toJSON Nothing  = Null+  toJSON (Just a) = toJSON a++instance (ToJSON a,ToJSON b) => ToJSON (a,b) where+  toJSON (a,b) = Array [toJSON a, toJSON b]++instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]++instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]++instance ToJSON Float where+  toJSON = Number . realToFrac++instance ToJSON Double where+  toJSON = Number++instance ToJSON Int    where  toJSON = Number . realToFrac+instance ToJSON Int8   where  toJSON = Number . realToFrac+instance ToJSON Int16  where  toJSON = Number . realToFrac+instance ToJSON Int32  where  toJSON = Number . realToFrac++instance ToJSON Word   where  toJSON = Number . realToFrac+instance ToJSON Word8  where  toJSON = Number . realToFrac+instance ToJSON Word16 where  toJSON = Number . realToFrac+instance ToJSON Word32 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Int64  where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Word64 where  toJSON = Number . realToFrac++-- | Possibly lossy due to conversion to 'Double'+instance ToJSON Integer where toJSON = Number . fromInteger++------------------------------------------------------------------------------+-- 'BB.Builder'-based encoding++-- | Serialise value as JSON/UTF8-encoded 'Builder'+encodeToBuilder :: ToJSON a => a -> Builder+encodeToBuilder = encodeValueBB . toJSON++encodeValueBB :: Value -> Builder+encodeValueBB jv = case jv of+  Bool True  -> "true"+  Bool False -> "false"+  Null       -> "null"+  Number n+    | isNaN n || isInfinite n   -> encodeValueBB Null+    | Just i <- doubleToInt64 n -> BB.int64Dec i+    | otherwise                 -> BB.doubleDec n+  Array a  -> encodeArrayBB a+  String s -> encodeStringBB s+  Object o -> encodeObjectBB o++encodeArrayBB :: [Value] -> Builder+encodeArrayBB [] = "[]"+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'+  where+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB++encodeObjectBB :: Object -> Builder+encodeObjectBB [] = "{}"+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'+  where+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x++encodeStringBB :: String -> Builder+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'+  where+    go = BB.stringUtf8 . escapeString++------------------------------------------------------------------------------+-- 'String'-based encoding++-- | Serialise value as JSON-encoded Unicode 'String'+encodeToString :: ToJSON a => a -> String+encodeToString jv = encodeValue (toJSON jv) []++encodeValue :: Value -> ShowS+encodeValue jv = case jv of+  Bool b   -> showString (if b then "true" else "false")+  Null     -> showString "null"+  Number n+    | isNaN n || isInfinite n    -> encodeValue Null+    | Just i <- doubleToInt64 n -> shows i+    | otherwise                 -> shows n+  Array a -> encodeArray a+  String s -> encodeString s+  Object o -> encodeObject o++encodeArray :: [Value] -> ShowS+encodeArray [] = showString "[]"+encodeArray jvs = ('[':) . go jvs . (']':)+  where+    go []     = id+    go [x]    = encodeValue x+    go (x:xs) = encodeValue x . (',':) . go xs++encodeObject :: Object -> ShowS+encodeObject [] = showString "{}"+encodeObject jvs = ('{':) . go jvs . ('}':)+  where+    go []          = id+    go [(l,x)]     = encodeString l . (':':) . encodeValue x+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs++encodeString :: String -> ShowS+encodeString str = ('"':) . showString (escapeString str) . ('"':)++------------------------------------------------------------------------------+-- helpers++-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not+-- representable loss-free as integral 'Int64' value.+doubleToInt64 :: Double -> Maybe Int64+doubleToInt64 x+  | fromInteger x' == x+  , x' <= toInteger (maxBound :: Int64)+  , x' >= toInteger (minBound :: Int64)+    = Just (fromIntegral x')+  | otherwise = Nothing+  where+    x' = round x++-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"+escapeString :: String -> String+escapeString s+  | not (any needsEscape s) = s+  | otherwise               = escape s+  where+    escape [] = []+    escape (x:xs) = case x of+      '\\' -> '\\':'\\':escape xs+      '"'  -> '\\':'"':escape xs+      '\b' -> '\\':'b':escape xs+      '\f' -> '\\':'f':escape xs+      '\n' -> '\\':'n':escape xs+      '\r' -> '\\':'r':escape xs+      '\t' -> '\\':'t':escape xs+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs+        | otherwise    -> c : escape xs++    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']++------------------------------------------------------------------------------+-- FromJSON++-- | Elements of a JSON path used to describe the location of an+-- error.+data JSONPathElement+  = Key String+  -- ^ JSON path element of a key into an object,+  -- \"object.key\".+  | Index !Int+  -- ^ JSON path element of an index into an+  -- array, \"array[index]\".+  deriving (Eq, Show, Ord)++type JSONPath = [JSONPathElement]++-- | Failure continuation.+type Failure f r   = JSONPath -> String -> f r++-- | Success continuation.+type Success a f r = a -> f r++newtype Parser a = Parser {+      runParser :: forall f r.+                   JSONPath+                -> Failure f r+                -> Success a f r+                -> f r+    }++modifyFailure :: (String -> String) -> Parser a -> Parser a+modifyFailure f (Parser p) = Parser $ \path kf ks ->+    p path (\p' m -> kf p' (f m)) ks++prependFailure :: String -> Parser a -> Parser a+prependFailure = modifyFailure . (++)++prependContext :: String -> Parser a -> Parser a+prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")++typeMismatch :: String -> Value -> Parser a+typeMismatch expected actual =+    fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual++instance Monad.Monad Parser where+    m >>= g = Parser $ \path kf ks ->+      runParser m path kf+                       (\a -> runParser (g a) path kf ks)+    return = pure++instance Fail.MonadFail Parser where+    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg++instance Functor Parser where+    fmap f m = Parser $ \path kf ks ->+      let ks' a = ks (f a)+      in runParser m path kf ks'++instance Applicative Parser where+    pure a = Parser $ \_path _kf ks -> ks a+    (<*>) = apP++instance Alternative Parser where+    empty = fail "empty"+    (<|>) = mplus++instance MonadPlus Parser where+    mzero = fail "mzero"+    mplus a b = Parser $ \path kf ks ->+      runParser a path (\_ _ -> runParser b path kf ks) ks++instance Semigroup (Parser a) where+    (<>) = mplus++instance Monoid (Parser a) where+    mempty  = fail "mempty"+    mappend = (<>)++apP :: Parser (a -> b) -> Parser a -> Parser b+apP d e = do+  b <- d+  b <$> e++(<?>) :: Parser a -> JSONPathElement -> Parser a+p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks++parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a+parseIndexedJSON p idx value = p value <?> Index idx++unexpected :: Value -> Parser a+unexpected actual = fail $ "unexpected " ++ typeOf actual++withObject :: String -> (Object -> Parser a) -> Value -> Parser a+withObject _    f (Object obj) = f obj+withObject name _ v            = prependContext name (typeMismatch "Object" v)++withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a+withArray _    f (Array arr) = f arr+withArray name _ v           = prependContext name (typeMismatch "Array" v)++withString :: String -> (String -> Parser a) -> Value -> Parser a+withString _    f (String txt) = f txt+withString name _ v            = prependContext name (typeMismatch "String" v)++withDouble :: String -> (Double -> Parser a) -> Value -> Parser a+withDouble _    f (Number duble) = f duble+withDouble name _ v              = prependContext name (typeMismatch "Number" v)++withBool :: String -> (Bool -> Parser a) -> Value -> Parser a+withBool _    f (Bool arr) = f arr+withBool name _ v          = prependContext name (typeMismatch "Boolean" v)++class FromJSON a where+    parseJSON     :: Value -> Parser a++    parseJSONList :: Value -> Parser [a]+    parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..])++instance FromJSON Bool where+    parseJSON (Bool b)  = pure b+    parseJSON v = typeMismatch "Bool" v++instance FromJSON () where+    parseJSON =+      withArray "()" $ \v ->+        if null v+          then pure ()+          else prependContext "()" $ fail "expected an empty array"++instance FromJSON Char where+    parseJSON = withString "Char" parseChar++    parseJSONList (String s) = pure s+    parseJSONList v = typeMismatch "String" v++parseChar :: String -> Parser Char+parseChar t =+    if length t == 1+      then pure $ head t+      else prependContext "Char" $ fail "expected a string of length 1"++parseRealFloat :: RealFloat a => String -> Value -> Parser a+parseRealFloat _    (Number s) = pure $ realToFrac s+parseRealFloat _    Null       = pure (0/0)+parseRealFloat name v          = prependContext name (unexpected v)++instance FromJSON Double where+    parseJSON = parseRealFloat "Double"++instance FromJSON Float where+    parseJSON = parseRealFloat "Float"++parseNatural :: Integer -> Parser Natural+parseNatural integer =+    if integer < 0 then+        fail $ "parsing Natural failed, unexpected negative number " <> show integer+    else+        pure $ fromIntegral integer++parseIntegralFromDouble :: Integral a => Double -> Parser a+parseIntegralFromDouble d =+    let r = toRational d+        x = truncate r+    in if toRational x == r+         then pure x+         else fail $ "unexpected floating number " <> show d++parseIntegral :: Integral a => String -> Value -> Parser a+parseIntegral name = withDouble name parseIntegralFromDouble++instance FromJSON Integer where+    parseJSON = parseIntegral "Integer"++instance FromJSON Natural where+    parseJSON = withDouble "Natural"+                  (parseIntegralFromDouble >=> parseNatural)++instance FromJSON Int where+    parseJSON = parseIntegral "Int"++instance FromJSON Int8 where+    parseJSON = parseIntegral "Int8"++instance FromJSON Int16 where+    parseJSON = parseIntegral "Int16"++instance FromJSON Int32 where+    parseJSON = parseIntegral "Int32"++instance FromJSON Int64 where+    parseJSON = parseIntegral "Int64"++instance FromJSON Word where+    parseJSON = parseIntegral "Word"++instance FromJSON Word8 where+    parseJSON = parseIntegral "Word8"++instance FromJSON Word16 where+    parseJSON = parseIntegral "Word16"++instance FromJSON Word32 where+    parseJSON = parseIntegral "Word32"++instance FromJSON Word64 where+    parseJSON = parseIntegral "Word64"++instance FromJSON a => FromJSON [a] where+    parseJSON = parseJSONList++data Result a = Error String+              | Success a+                deriving (Eq, Show)++fromJSON :: FromJSON a => Value -> Result a+fromJSON = parse parseJSON++parse :: (a -> Parser b) -> a -> Result b+parse m v = runParser (m v) [] (const Error) Success++parseEither :: (a -> Parser b) -> a -> Either String b+parseEither m v = runParser (m v) [] onError Right+  where onError path msg = Left (formatError path msg)++formatError :: JSONPath -> String -> String+formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg++formatPath :: JSONPath -> String+formatPath path = "$" ++ formatRelativePath path++formatRelativePath :: JSONPath -> String+formatRelativePath path = format "" path+  where+    format :: String -> JSONPath -> String+    format pfx []                = pfx+    format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts+    format pfx (Key key:parts)   = format (pfx ++ formatKey key) parts++    formatKey :: String -> String+    formatKey key+       | isIdentifierKey key = "." ++ key+       | otherwise           = "['" ++ escapeKey key ++ "']"++    isIdentifierKey :: String -> Bool+    isIdentifierKey []     = False+    isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs++    escapeKey :: String -> String+    escapeKey = concatMap escapeChar++    escapeChar :: Char -> String+    escapeChar '\'' = "\\'"+    escapeChar '\\' = "\\\\"+    escapeChar c    = [c]++explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a+explicitParseField p obj key =+    case key `lookup` obj of+      Nothing -> fail $ "key " ++ key ++ " not found"+      Just v  -> p v <?> Key key++(.:) :: FromJSON a => Object -> String -> Parser a+(.:) = explicitParseField parseJSON++explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a)+explicitParseFieldMaybe p obj key =+    case key `lookup` obj of+      Nothing -> pure Nothing+      Just v  -> Just <$> p v <?> Key key++(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a)+(.:?) = explicitParseFieldMaybe parseJSON+++decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a+decodeWith decoder bsl =+   case Parsec.parse parseJSONValue "<input>" bsl of+     Left  _    -> Nothing+     Right json ->+       case decoder json of+         Success a -> Just a+         Error _   -> Nothing++decode :: FromJSON a => BSL.ByteString -> Maybe a+decode = decodeWith fromJSON++eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a+eitherDecodeWith decoder bsl =+    case Parsec.parse parseJSONValue "<input>" bsl of+      Left parsecError -> Left (show parsecError)+      Right json ->+        case decoder json of+          Success a -> Right a+          Error err -> Left  err++eitherDecode :: FromJSON a => BSL.ByteString -> Either String a+eitherDecode = eitherDecodeWith fromJSON+++decodeFile :: FromJSON a => FilePath -> IO (Maybe a)+decodeFile filePath = do+    parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath+    case parsecResult of+      Right r ->+        case fromJSON r of+          Success a -> return (Just a)+          Error   _ -> return Nothing+      Left _ -> return Nothing+++eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a)+eitherDecodeFile filePath = do+    parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath+    case parsecResult of+      Right r ->+        case fromJSON r of+          Success a -> return (Right a)+          Error err -> return (Left err)+      Left err -> return $ Left (show err)+
+ src/Haddock/Utils/Json/Parser.hs view
@@ -0,0 +1,102 @@+-- | Json "Parsec" parser, based on+-- [json](https://hackage.haskell.org/package/json) package.+--+module Haddock.Utils.Json.Parser+  ( parseJSONValue+  ) where++import Prelude hiding (null)++import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus (..))+import Data.Char (isHexDigit)+import Data.Functor (($>))+import qualified Data.ByteString.Lazy.Char8 as BSCL+import Numeric+import Text.Parsec.ByteString.Lazy (Parser)+import Text.ParserCombinators.Parsec ((<?>))+import qualified Text.ParserCombinators.Parsec as Parsec++import Haddock.Utils.Json.Types hiding (object)++parseJSONValue :: Parser Value+parseJSONValue = Parsec.spaces *> parseValue++tok :: Parser a -> Parser a+tok p = p <* Parsec.spaces++parseValue :: Parser Value+parseValue =+         parseNull+     <|> Bool   <$> parseBoolean+     <|> Array  <$> parseArray+     <|> String <$> parseString+     <|> Object <$> parseObject+     <|> Number <$> parseNumber+     <?> "JSON value"++parseNull :: Parser Value+parseNull = tok+     $  Parsec.string "null"+     $> Null++parseBoolean :: Parser Bool+parseBoolean = tok+     $  Parsec.string "true"  $> True+    <|> Parsec.string "false" $> False++parseArray :: Parser [Value]+parseArray =+    Parsec.between+      (tok (Parsec.char '['))+      (tok (Parsec.char ']'))+      (parseValue `Parsec.sepBy` tok (Parsec.char ','))++parseString :: Parser String+parseString =+    Parsec.between+      (tok (Parsec.char '"'))+      (tok (Parsec.char '"'))+      (many char)+  where+    char = (Parsec.char '\\' >> escapedChar)+       <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\')++    escapedChar =+          Parsec.char '"'  $> '"'+      <|> Parsec.char '\\' $> '\\'+      <|> Parsec.char '/'  $> '/'+      <|> Parsec.char 'b'  $> '\b'+      <|> Parsec.char 'f'  $> '\f'+      <|> Parsec.char 'n'  $> '\n'+      <|> Parsec.char 'r'  $> '\r'+      <|> Parsec.char 't'  $> '\t'+      <|> Parsec.char 'u'  *> uni+      <?> "escape character"++    uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)+      where+        check x | code <= max_char = return (toEnum code)+                | otherwise        = mzero+          where code      = fst $ head $ readHex x+                max_char  = fromEnum (maxBound :: Char)++parseObject :: Parser Object+parseObject =+      Parsec.between+        (tok (Parsec.char '{'))+        (tok (Parsec.char '}'))+        (field `Parsec.sepBy` tok (Parsec.char ','))+  where+    field :: Parser (String, Value)+    field = (,)+        <$> parseString+        <*  tok (Parsec.char ':')+        <*> parseValue++parseNumber :: Parser Double+parseNumber = tok $ do+  s <- BSCL.unpack <$> Parsec.getInput+  case readSigned readFloat s of+    [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n+    _        -> mzero
+ src/Haddock/Utils/Json/Types.hs view
@@ -0,0 +1,42 @@+module Haddock.Utils.Json.Types+  ( Value(..)+  , typeOf+  , Pair+  , Object+  , object+  ) where++import Data.String++-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array  [Value]+           | String  String+           | Number !Double+           | Bool   !Bool+           | Null+           deriving (Eq, Read, Show)++typeOf :: Value -> String+typeOf v = case v of+    Object _ -> "Object"+    Array _  -> "Array"+    String _ -> "String"+    Number _ -> "Number"+    Bool _   -> "Boolean"+    Null     -> "Null"++-- | A key\/value pair for an 'Object'+type Pair = (String, Value)++-- | A JSON \"object\" (key/value map).+type Object = [Pair]++-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object++instance IsString Value where+  fromString = String
test/Haddock/Backends/Hyperlinker/ParserSpec.hs view
@@ -1,98 +1,162 @@+{-# LANGUAGE OverloadedStrings #-} module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where - import Test.Hspec import Test.QuickCheck +import GHC                ( runGhc, getSessionDynFlags )+import GHC.Driver.Session ( DynFlags )+import Control.Monad.IO.Class++import Data.String     ( fromString )+import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS ++import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types +withDynFlags :: (DynFlags -> IO ()) -> IO ()+withDynFlags cont = do+  libDir <- fmap snd (getGhcDirs [])+  runGhc libDir $ do+    dflags <- getSessionDynFlags+    liftIO $ cont dflags + main :: IO () main = hspec spec   spec :: Spec-spec = do-    describe "parse" parseSpec+spec = describe "parse" parseSpec  +-- | Defined for its instance of 'Arbitrary'. Represents strings that, when+-- considered as GHC source, won't be rewritten.+newtype NoGhcRewrite = NoGhcRewrite String deriving (Show, Eq)++-- | Filter out strings where GHC would replace/remove some characters during+-- lexing.+noGhcRewrite :: String -> Bool+noGhcRewrite ('\t':_) = False        -- GHC replaces tabs with 8 spaces+noGhcRewrite ('\r':_) = False+noGhcRewrite ('\f':_) = False+noGhcRewrite ('\v':_) = False+noGhcRewrite (' ':'\n':_) = False    -- GHC strips whitespace on empty lines+noGhcRewrite (_:s) = noGhcRewrite s+noGhcRewrite "" = True++instance Arbitrary NoGhcRewrite where+  arbitrary = fmap NoGhcRewrite (arbitrary `suchThat` noGhcRewrite)+  shrink (NoGhcRewrite src) = [ NoGhcRewrite shrunk+                              | shrunk <- shrink src+                              , noGhcRewrite shrunk+                              ]++ parseSpec :: Spec-parseSpec = do+parseSpec = around withDynFlags $ do -    it "is total" $-        property $ \src -> length (parse src) `shouldSatisfy` (>= 0)+    it "is total" $ \dflags ->+        property $ \src -> length (parse dflags "" (fromString src)) `shouldSatisfy` (>= 0) -    it "retains file layout" $-        property $ \src -> concatMap tkValue (parse src) == src+    it "retains file layout" $ \dflags ->+        property $ \(NoGhcRewrite src) ->+          let orig = fromString src+              lexed = BS.concat (map tkValue (parse dflags "" orig))+          in lexed == orig       context "when parsing single-line comments" $ do -        it "should ignore content until the end of line" $-            "-- some very simple comment\nidentifier"-            `shouldParseTo`-            [TkComment, TkSpace, TkIdentifier]+        it "should ignore content until the end of line" $ \dflags ->+            shouldParseTo+                "-- some very simple comment\nidentifier"+                [TkComment, TkSpace, TkIdentifier]+                dflags -        it "should allow endline escaping" $-            "-- first line\\\nsecond line\\\nand another one"-            `shouldParseTo`-            [TkComment]+        it "should allow endline escaping" $ \dflags ->+            shouldParseTo+                "#define first line\\\nsecond line\\\nand another one"+                [TkCpp]+                dflags      context "when parsing multi-line comments" $ do -        it "should support nested comments" $-            "{- comment {- nested -} still comment -} {- next comment -}"-            `shouldParseTo`-            [TkComment, TkSpace, TkComment]+        it "should support nested comments" $ \dflags ->+            shouldParseTo+                "{- comment {- nested -} still comment -} {- next comment -}"+                [TkComment, TkSpace, TkComment]+                dflags -        it "should distinguish compiler pragma" $-            "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"-            `shouldParseTo`-            [TkComment, TkPragma, TkComment]+        it "should distinguish compiler pragma" $ \dflags ->+            shouldParseTo+                "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"+                [TkComment, TkPragma, TkComment]+                dflags -    it "should recognize preprocessor directives" $ do-        "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]-        "x # y" `shouldParseTo`-            [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]+    it "should recognize preprocessor directives" $ \dflags -> do+            shouldParseTo+                "\n#define foo bar"+                [TkCpp]+                dflags+            shouldParseTo+                "x # y"+                [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]+                dflags -    it "should distinguish basic language constructs" $ do-        "(* 2) <$> (\"abc\", foo)" `shouldParseTo`+    it "should distinguish basic language constructs" $ \dflags -> do+        +        shouldParseTo+            "(* 2) <$> (\"abc\", foo)"             [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial             , TkSpace, TkOperator, TkSpace             , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial             ]-        "let foo' = foo in foo' + foo'" `shouldParseTo`+            dflags+            +        shouldParseTo+            "let foo' = foo in foo' + foo'"             [ TkKeyword, TkSpace, TkIdentifier             , TkSpace, TkGlyph, TkSpace             , TkIdentifier, TkSpace, TkKeyword, TkSpace             , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier             ]-        "square x = y^2 where y = x" `shouldParseTo`+            dflags+        +        shouldParseTo+            "square x = y^2 where y = x"             [ TkIdentifier, TkSpace, TkIdentifier             , TkSpace, TkGlyph, TkSpace             , TkIdentifier, TkOperator, TkNumber             , TkSpace, TkKeyword, TkSpace             , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier             ]+            dflags -    it "should parse do-notation syntax" $ do-        "do { foo <- getLine; putStrLn foo }" `shouldParseTo`+    it "should parse do-notation syntax" $ \dflags -> do+        shouldParseTo+            "do { foo <- getLine; putStrLn foo }"             [ TkKeyword, TkSpace, TkSpecial, TkSpace             , TkIdentifier, TkSpace, TkGlyph, TkSpace             , TkIdentifier, TkSpecial, TkSpace             , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial             ]+            dflags -        unlines-            [ "do"-            , "    foo <- getLine"-            , "    putStrLn foo"-            ] `shouldParseTo`+        shouldParseTo+            (fromString $ unlines+                [ "do"+                , "    foo <- getLine"+                , "    putStrLn foo"+                ])             [ TkKeyword, TkSpace, TkIdentifier             , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace             , TkIdentifier, TkSpace, TkIdentifier, TkSpace             ]---shouldParseTo :: String -> [TokenType] -> Expectation-str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens+            dflags+  where+    shouldParseTo :: ByteString -> [TokenType] -> DynFlags -> Expectation+    shouldParseTo str tokens dflags = [ tkType tok+                                      | tok <- parse dflags "" str+                                      , not (BS.null (tkValue tok)) ] `shouldBe` tokens