packages feed

haddock-api 2.18.1 → 2.19.0.1

raw patch · 39 files changed

+2821/−1753 lines, 39 filesdep ~Cabaldep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Cabal, QuickCheck, base, ghc, haddock-library

API changes (from Hackage documentation)

- Documentation.Haddock: [ifaceBundledPatSynMap] :: Interface -> !(Map Name [Name])
- Documentation.Haddock: [ifaceSubMap] :: Interface -> !(Map Name [Name])
- Documentation.Haddock: [instBundledPatSynMap] :: InstalledInterface -> Map Name [Name]
- Documentation.Haddock: [instSubMap] :: InstalledInterface -> Map Name [Name]
- Documentation.Haddock: data DocMarkup id a
+ Documentation.Haddock: DocTable :: Table DocH mod id -> DocH mod id
+ Documentation.Haddock: Flag_QuickJumpIndex :: Flag
+ Documentation.Haddock: Flag_Reexport :: String -> Flag
+ Documentation.Haddock: Flag_ShowAllModules :: Flag
+ Documentation.Haddock: Flag_ShowInterface :: String -> Flag
+ Documentation.Haddock: Flag_ShowModule :: String -> Flag
+ Documentation.Haddock: [markupTable] :: DocMarkupH mod id a -> Table a -> a
+ Documentation.Haddock: data DocMarkupH mod id a
+ Documentation.Haddock: type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a
- Documentation.Haddock: ExportDecl :: !(LHsDecl name) -> ![(HsDecl name, DocForDecl name)] -> !(DocForDecl name) -> ![(name, DocForDecl name)] -> ![DocInstance name] -> ![(name, Fixity)] -> !Bool -> ExportItem name
+ Documentation.Haddock: ExportDecl :: !(LHsDecl name) -> ![(HsDecl name, DocForDecl (IdP name))] -> !(DocForDecl (IdP name)) -> ![(IdP name, DocForDecl (IdP name))] -> ![DocInstance name] -> ![(IdP name, Fixity)] -> !Bool -> ExportItem name
- Documentation.Haddock: ExportDoc :: !(MDoc name) -> ExportItem name
+ Documentation.Haddock: ExportDoc :: !(MDoc (IdP name)) -> ExportItem name
- Documentation.Haddock: ExportGroup :: !Int -> !String -> !(Doc name) -> ExportItem name
+ Documentation.Haddock: ExportGroup :: !Int -> !String -> !(Doc (IdP name)) -> ExportItem name
- Documentation.Haddock: ExportNoDecl :: !name -> ![name] -> ExportItem name
+ Documentation.Haddock: ExportNoDecl :: !(IdP name) -> ![IdP name] -> ExportItem name
- Documentation.Haddock: InstalledInterface :: Module -> Bool -> HaddockModInfo Name -> DocMap Name -> ArgMap Name -> [Name] -> [Name] -> [DocOption] -> Map Name [Name] -> Map Name [Name] -> Map Name Fixity -> InstalledInterface
+ Documentation.Haddock: InstalledInterface :: Module -> Bool -> HaddockModInfo Name -> DocMap Name -> ArgMap Name -> [Name] -> [Name] -> [DocOption] -> Map Name Fixity -> InstalledInterface
- Documentation.Haddock: Interface :: !Module -> !Bool -> !FilePath -> !(HaddockModInfo Name) -> !(Documentation Name) -> !(Documentation DocName) -> ![DocOption] -> !(Map Name [LHsDecl Name]) -> !(Map Name [Name]) -> !(DocMap Name) -> !(ArgMap Name) -> !(DocMap DocName) -> !(ArgMap DocName) -> !(Map Name [Name]) -> !(Map Name Fixity) -> ![ExportItem Name] -> ![ExportItem DocName] -> ![Name] -> ![Name] -> !AliasMap -> ![ClsInst] -> ![FamInst] -> ![DocInstance Name] -> ![DocInstance DocName] -> !(Int, Int) -> !WarningMap -> !(Maybe [RichToken]) -> Interface
+ Documentation.Haddock: Interface :: !Module -> !Bool -> !FilePath -> !(HaddockModInfo Name) -> !(Documentation Name) -> !(Documentation DocName) -> ![DocOption] -> !(Map Name [LHsDecl GhcRn]) -> !(DocMap Name) -> !(ArgMap Name) -> !(DocMap DocName) -> !(ArgMap DocName) -> !(Map Name Fixity) -> ![ExportItem GhcRn] -> ![ExportItem DocNameI] -> ![Name] -> ![Name] -> !AliasMap -> ![ClsInst] -> ![FamInst] -> ![DocInstance GhcRn] -> ![DocInstance DocNameI] -> !(Int, Int) -> !WarningMap -> !(Maybe [RichToken]) -> Interface
- Documentation.Haddock: Markup :: a -> (String -> a) -> (a -> a) -> (a -> a -> a) -> (id -> a) -> ((ModuleName, OccName) -> a) -> (String -> a) -> (a -> a) -> (a -> a) -> (a -> a) -> (a -> a) -> ([a] -> a) -> ([a] -> a) -> ([(a, a)] -> a) -> (a -> a) -> (Hyperlink -> a) -> (String -> a) -> (Picture -> a) -> (String -> a) -> (String -> a) -> (String -> a) -> ([Example] -> a) -> (Header a -> a) -> DocMarkup id a
+ Documentation.Haddock: Markup :: a -> String -> a -> a -> a -> a -> a -> a -> id -> a -> mod -> a -> String -> a -> a -> a -> a -> a -> a -> a -> a -> a -> [a] -> a -> [a] -> a -> [(a, a)] -> a -> a -> a -> Hyperlink -> a -> String -> a -> Picture -> a -> String -> a -> String -> a -> String -> a -> [Example] -> a -> Header a -> a -> Table a -> a -> DocMarkupH mod id a
- Documentation.Haddock: [expItemFixities] :: ExportItem name -> ![(name, Fixity)]
+ Documentation.Haddock: [expItemFixities] :: ExportItem name -> ![(IdP name, Fixity)]
- Documentation.Haddock: [expItemMbDoc] :: ExportItem name -> !(DocForDecl name)
+ Documentation.Haddock: [expItemMbDoc] :: ExportItem name -> !(DocForDecl (IdP name))
- Documentation.Haddock: [expItemName] :: ExportItem name -> !name
+ Documentation.Haddock: [expItemName] :: ExportItem name -> !(IdP name)
- Documentation.Haddock: [expItemPats] :: ExportItem name -> ![(HsDecl name, DocForDecl name)]
+ Documentation.Haddock: [expItemPats] :: ExportItem name -> ![(HsDecl name, DocForDecl (IdP name))]
- Documentation.Haddock: [expItemSectionText] :: ExportItem name -> !(Doc name)
+ Documentation.Haddock: [expItemSectionText] :: ExportItem name -> !(Doc (IdP name))
- Documentation.Haddock: [expItemSubDocs] :: ExportItem name -> ![(name, DocForDecl name)]
+ Documentation.Haddock: [expItemSubDocs] :: ExportItem name -> ![(IdP name, DocForDecl (IdP name))]
- Documentation.Haddock: [expItemSubs] :: ExportItem name -> ![name]
+ Documentation.Haddock: [expItemSubs] :: ExportItem name -> ![IdP name]
- Documentation.Haddock: [ifaceDeclMap] :: Interface -> !(Map Name [LHsDecl Name])
+ Documentation.Haddock: [ifaceDeclMap] :: Interface -> !(Map Name [LHsDecl GhcRn])
- Documentation.Haddock: [ifaceExportItems] :: Interface -> ![ExportItem Name]
+ Documentation.Haddock: [ifaceExportItems] :: Interface -> ![ExportItem GhcRn]
- Documentation.Haddock: [ifaceOrphanInstances] :: Interface -> ![DocInstance Name]
+ Documentation.Haddock: [ifaceOrphanInstances] :: Interface -> ![DocInstance GhcRn]
- Documentation.Haddock: [ifaceRnExportItems] :: Interface -> ![ExportItem DocName]
+ Documentation.Haddock: [ifaceRnExportItems] :: Interface -> ![ExportItem DocNameI]
- Documentation.Haddock: [ifaceRnOrphanInstances] :: Interface -> ![DocInstance DocName]
+ Documentation.Haddock: [ifaceRnOrphanInstances] :: Interface -> ![DocInstance DocNameI]
- Documentation.Haddock: [markupAName] :: DocMarkup id a -> String -> a
+ Documentation.Haddock: [markupAName] :: DocMarkupH mod id a -> String -> a
- Documentation.Haddock: [markupAppend] :: DocMarkup id a -> a -> a -> a
+ Documentation.Haddock: [markupAppend] :: DocMarkupH mod id a -> a -> a -> a
- Documentation.Haddock: [markupBold] :: DocMarkup id a -> a -> a
+ Documentation.Haddock: [markupBold] :: DocMarkupH mod id a -> a -> a
- Documentation.Haddock: [markupCodeBlock] :: DocMarkup id a -> a -> a
+ Documentation.Haddock: [markupCodeBlock] :: DocMarkupH mod id a -> a -> a
- Documentation.Haddock: [markupDefList] :: DocMarkup id a -> [(a, a)] -> a
+ Documentation.Haddock: [markupDefList] :: DocMarkupH mod id a -> [(a, a)] -> a
- Documentation.Haddock: [markupEmphasis] :: DocMarkup id a -> a -> a
+ Documentation.Haddock: [markupEmphasis] :: DocMarkupH mod id a -> a -> a
- Documentation.Haddock: [markupEmpty] :: DocMarkup id a -> a
+ Documentation.Haddock: [markupEmpty] :: DocMarkupH mod id a -> a
- Documentation.Haddock: [markupExample] :: DocMarkup id a -> [Example] -> a
+ Documentation.Haddock: [markupExample] :: DocMarkupH mod id a -> [Example] -> a
- Documentation.Haddock: [markupHeader] :: DocMarkup id a -> Header a -> a
+ Documentation.Haddock: [markupHeader] :: DocMarkupH mod id a -> Header a -> a
- Documentation.Haddock: [markupHyperlink] :: DocMarkup id a -> Hyperlink -> a
+ Documentation.Haddock: [markupHyperlink] :: DocMarkupH mod id a -> Hyperlink -> a
- Documentation.Haddock: [markupIdentifierUnchecked] :: DocMarkup id a -> (ModuleName, OccName) -> a
+ Documentation.Haddock: [markupIdentifierUnchecked] :: DocMarkupH mod id a -> mod -> a
- Documentation.Haddock: [markupIdentifier] :: DocMarkup id a -> id -> a
+ Documentation.Haddock: [markupIdentifier] :: DocMarkupH mod id a -> id -> a
- Documentation.Haddock: [markupMathDisplay] :: DocMarkup id a -> String -> a
+ Documentation.Haddock: [markupMathDisplay] :: DocMarkupH mod id a -> String -> a
- Documentation.Haddock: [markupMathInline] :: DocMarkup id a -> String -> a
+ Documentation.Haddock: [markupMathInline] :: DocMarkupH mod id a -> String -> a
- Documentation.Haddock: [markupModule] :: DocMarkup id a -> String -> a
+ Documentation.Haddock: [markupModule] :: DocMarkupH mod id a -> String -> a
- Documentation.Haddock: [markupMonospaced] :: DocMarkup id a -> a -> a
+ Documentation.Haddock: [markupMonospaced] :: DocMarkupH mod id a -> a -> a
- Documentation.Haddock: [markupOrderedList] :: DocMarkup id a -> [a] -> a
+ Documentation.Haddock: [markupOrderedList] :: DocMarkupH mod id a -> [a] -> a
- Documentation.Haddock: [markupParagraph] :: DocMarkup id a -> a -> a
+ Documentation.Haddock: [markupParagraph] :: DocMarkupH mod id a -> a -> a
- Documentation.Haddock: [markupPic] :: DocMarkup id a -> Picture -> a
+ Documentation.Haddock: [markupPic] :: DocMarkupH mod id a -> Picture -> a
- Documentation.Haddock: [markupProperty] :: DocMarkup id a -> String -> a
+ Documentation.Haddock: [markupProperty] :: DocMarkupH mod id a -> String -> a
- Documentation.Haddock: [markupString] :: DocMarkup id a -> String -> a
+ Documentation.Haddock: [markupString] :: DocMarkupH mod id a -> String -> a
- Documentation.Haddock: [markupUnorderedList] :: DocMarkup id a -> [a] -> a
+ Documentation.Haddock: [markupUnorderedList] :: DocMarkupH mod id a -> [a] -> a
- Documentation.Haddock: [markupWarning] :: DocMarkup id a -> a -> a
+ Documentation.Haddock: [markupWarning] :: DocMarkupH mod id a -> a -> a
- Documentation.Haddock: data DocH mod id :: * -> * -> *
+ Documentation.Haddock: data DocH mod id
- Documentation.Haddock: data Example :: *
+ Documentation.Haddock: data Example
- Documentation.Haddock: data Hyperlink :: *
+ Documentation.Haddock: data Hyperlink
- Documentation.Haddock: markup :: DocMarkup id a -> Doc id -> a
+ Documentation.Haddock: markup :: () => DocMarkupH mod id a -> DocH mod id -> a
- Documentation.Haddock: nameCacheFromGhc :: NameCacheAccessor Ghc
+ Documentation.Haddock: nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m
- Documentation.Haddock: type DocInstance name = (InstHead name, Maybe (MDoc name), Located name)
+ Documentation.Haddock: type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name))

Files

haddock-api.cabal view
@@ -1,5 +1,6 @@+cabal-version:        2.0 name:                 haddock-api-version:              2.18.1+version:              2.19.0.1 synopsis:             A documentation-generation tool for Haskell libraries description:          Haddock is a documentation-generation tool for Haskell                       libraries@@ -12,7 +13,6 @@ copyright:            (c) Simon Marlow, David Waern category:             Documentation build-type:           Simple-cabal-version:        >= 2.0  extra-source-files:   CHANGES.md@@ -20,8 +20,10 @@ 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@@ -38,11 +40,11 @@   default-language: Haskell2010    -- this package typically supports only single major versions-  build-depends: base            ^>= 4.10.0-               , Cabal           ^>= 2.0.0-               , ghc             ^>= 8.2+  build-depends: base            ^>= 4.11.0+               , Cabal           ^>= 2.2.0+               , ghc             ^>= 8.4                , ghc-paths       ^>= 0.1.0.9-               , haddock-library ^>= 1.4.4+               , haddock-library ^>= 1.5.0                , xhtml           ^>= 3000.2.2    -- Versions for the dependencies below are transitively pinned by@@ -73,15 +75,18 @@     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.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@@ -119,24 +124,68 @@       test     , src -  -- NB: We only use a small subset of lib:haddock-api here, which-  --     explains why this component has a smaller build-depends set   other-modules:+    Haddock+    Haddock.Backends.Hoogle+    Haddock.Backends.Hyperlinker+    Haddock.Backends.Hyperlinker.Ast+    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.Version+    Paths_haddock_api     Haddock.Backends.Hyperlinker.ParserSpec     Haddock.Backends.Hyperlinker.Parser     Haddock.Backends.Hyperlinker.Types -  build-depends:-      ghc         ^>= 8.2-    , hspec       ^>= 2.4.4-    , QuickCheck  ^>= 2.10+  build-depends: Cabal           ^>= 2.0.0+               , ghc             ^>= 8.4+               , ghc-paths       ^>= 0.1.0.9+               , haddock-library ^>= 1.5.0+               , xhtml           ^>= 3000.2.2+               , hspec           ^>= 2.4.4+               , QuickCheck      ^>= 2.11    -- Versions for the dependencies below are transitively pinned by   -- the non-reinstallable `ghc` package and hence need no version   -- bounds-  build-depends:-      base-    , containers+  build-depends: base+               , array+               , bytestring+               , containers+               , deepseq+               , directory+               , filepath+               , ghc-boot+               , transformers    build-tool-depends:     hspec-discover:hspec-discover ^>= 2.4.4
resources/html/Classic.theme/xhaddock.css view
@@ -392,6 +392,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/Ocean.std-theme/ocean.css view
@@ -46,6 +46,14 @@  /* @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@@ -106,7 +114,7 @@  /* @group Common */ -.caption, h1, h2, h3, h4, h5, h6 {+.caption, h1, h2, h3, h4, h5, h6, summary {   font-weight: bold;   color: rgb(78,98,114);   margin: 0.8em 0 0.4em;@@ -168,7 +176,17 @@   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;@@ -338,7 +356,8 @@   z-index: 1; } -#synopsis .caption {+#synopsis summary {+  display: block;   float: left;   width: 29px;   color: rgba(255,255,255,0);@@ -346,16 +365,13 @@   margin: 0;   font-size: 1px;   padding: 0;+  background: url(synopsis.png) no-repeat 0px -8px; } -#synopsis p.caption.collapser {+#synopsis details[open] > summary {   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;@@ -419,14 +435,27 @@   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;+}++.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 {
+ resources/html/haddock-bundle.min.js view
@@ -0,0 +1,2 @@+!function e(t,n,o){function r(s,a){if(!n[s]){if(!t[s]){var l="function"==typeof require&&require;if(!a&&l)return l(s,!0);if(i)return i(s,!0);var c=new Error("Cannot find module '"+s+"'");throw c.code="MODULE_NOT_FOUND",c}var u=n[s]={exports:{}};t[s][0].call(u.exports,function(e){var n=t[s][1][e];return r(n||e)},u,u.exports,e,t,n,o)}return n[s].exports}for(var i="function"==typeof require&&require,s=0;s<o.length;s++)r(o[s]);return r}({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";function o(e){var t=d[e];if(void 0==t)throw new Error("could not find <details> element with id '"+e+"'");return t}function r(e){for(var t=e.target,n=t.id,r=o(n),i=r.element.open,s=0,l=r.toggles;s<l.length;s++){var c=l[s];c.classList.contains("details-toggle-control")&&(c.classList.add(i?"collapser":"expander"),c.classList.remove(i?"expander":"collapser"))}t.open==r.openByDefault?delete p[n]:p[n]=!0,a()}function i(){for(var e=0,t=Array.prototype.slice.call(document.getElementsByTagName("details"));e<t.length;e++){var n=t[e];"string"==typeof n.id&&n.id.length>0&&(d[n.id]={element:n,openByDefault:!!n.open,toggles:[]},n.addEventListener("toggle",r))}}function s(e){var t=o(e).element;t.open=!t.open}function a(){var e=Object.keys(p);document.cookie="toggled="+encodeURIComponent(e.join("+"))}function l(){var e=h.getCookie("toggled");if(e)for(var t=0,n=e.split("+");t<n.length;t++){var o=n[t],r=d[o];p[o]=!0,r&&(r.element.open=!r.element.open)}}function c(e){e.preventDefault();var t=e.currentTarget.getAttribute("data-details-id");if(!t)throw new Error("element with class 'details-toggle' has no 'data-details-id' attribute!");s(t)}function u(){Array.prototype.slice.call(document.getElementsByClassName("details-toggle")).forEach(function(e){var t=e.getAttribute("data-details-id");if(!t)throw new Error("element with class 'details-toggle' has no 'data-details-id' attribute!");var n=o(t);n.toggles.push(e),e.addEventListener("click",c),e.classList.contains("details-toggle-control")&&e.classList.add(n.element.open?"collapser":"expander")})}Object.defineProperty(n,"__esModule",{value:!0});var h=e("./cookies"),d={},p={};n.init=function(){i(),l(),u()}},{"./cookies":1}],3:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0});var o=e("./style-menu"),r=e("./details-helper"),i=e("./quick-jump");!function(e){"interactive"===document.readyState?e():document.addEventListener("readystatechange",function(){"interactive"===document.readyState&&e()})}(function(){document.body.classList.add("js-enabled"),o.init(),r.init(),i.init()})},{"./details-helper":2,"./quick-jump":4,"./style-menu":5}],4:[function(e,t,n){"use strict";function o(e,t,n){var o=new XMLHttpRequest;o.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()}function r(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),d.render(p(v,{onClick:e,title:"Quick Jump"}),t,n)}function i(e,t){return t.length<=e?t:t.slice(0,e)}function s(){return p("table",{class:"keyboard-shortcuts"},p("tr",null,p("th",null,"Key"),p("th",null,"Shortcut")),p("tr",null,p("td",null,p("span",{class:"key"},"s")),p("td",null,"Open this search box")),p("tr",null,p("td",null,p("span",{class:"key"},"esc")),p("td",null,"Close this search box")),p("tr",null,p("td",null,p("span",{class:"key"},"↓"),",",p("span",{class:"key"},"ctrl")," + ",p("span",{class:"key"},"j")),p("td",null,"Move down in search results")),p("tr",null,p("td",null,p("span",{class:"key"},"↑"),",",p("span",{class:"key"},"ctrl")," + ",p("span",{class:"key"},"k")),p("td",null,"Move up in search results")),p("tr",null,p("td",null,p("span",{class:"key"},"↵")),p("td",null,"Go to active search result")))}function a(){return p("p",null,"You can find any exported type, constructor, class, function or pattern defined in this package by (approximate) name.")}function l(e){var t=[p("p",null,"Your search for '",e.searchString,"' produced the following list of results: ",p("code",null,"[]"),"."),p("p",null,p("code",null,"Nothing")," matches your query for '",e.searchString,"'."),p("p",null,p("code",null,"Left \"no matches for '",e.searchString,"'\" :: Either String (NonEmpty SearchResult)"))];return t[(e.searchString||"a").charCodeAt(0)%t.length]}function c(e,t){d.render(p(g,{baseUrl:e||".",showHideTrigger:t||r}),document.body)}var u=this&&this.__extends||function(){var e=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])};return function(t,n){function o(){this.constructor=t}e(t,n),t.prototype=null===n?Object.create(n):(o.prototype=n.prototype,new o)}}();Object.defineProperty(n,"__esModule",{value:!0});var h=e("fuse.js"),d=e("preact"),p=d.h,f=d.Component,v=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return u(t,e),t.prototype.render=function(e){return p("li",null,p("a",{href:"#",onClick:function(t){t.preventDefault(),e.onClick()}},e.title))},t}(f),g=function(e){function t(){var t=null!==e&&e.apply(this,arguments)||this;return t.linkIndex=0,t.focusPlease=!1,t.navigatedByKeyboard=!1,t}return u(t,e),t.prototype.componentWillMount=function(){var e=this;this.setState({searchString:"",isVisible:!1,expanded:{},activeLinkIndex:-1,moduleResults:[]}),o(this.props.baseUrl+"/doc-index.json",function(t){e.setState({fuse:new h(t,{threshold:.25,caseSensitive:!0,includeScore:!0,tokenize:!0,keys:[{name:"name",weight:.7},{name:"module",weight:.3}]}),moduleResults:[]})},function(t){console&&console.error("could not load 'doc-index.json' for searching",t),e.setState({failedLoading:!0})}),document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(t){e.state.isVisible&&("Escape"===t.key?e.hide():"ArrowUp"===t.key||"k"===t.key&&t.ctrlKey?(t.preventDefault(),e.navigateLinks(-1)):"ArrowDown"===t.key||"j"===t.key&&t.ctrlKey?(t.preventDefault(),e.navigateLinks(1)):"Enter"===t.key&&e.state.activeLinkIndex>=0&&e.followActiveLink()),"s"===t.key&&"input"!==t.target.tagName.toLowerCase()&&(t.preventDefault(),e.show())})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},t.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},t.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t={};this.state.fuse.search(e).forEach(function(e){var n=e.item.module;(t[n]||(t[n]=[])).push(e)});var n=[];for(var o in t)!function(e){var o=t[e],r=0;o.forEach(function(e){r+=1/e.score}),n.push({module:e,totalScore:1/r,items:o})}(o);n.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:n})},t.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.top<t&&(this.searchResults.scrollTop-=t-e.top+80)}this.focusPlease&&this.input&&this.input.focus(),this.navigatedByKeyboard=!1,this.focusPlease=!1},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){var n=this;if(t.failedLoading){var o="file:"==window.location.protocol;return p("div",{id:"search",class:t.isVisible?"":"hidden"},p("div",{id:"search-results"},p("p",{class:"error"},"Failed to load file 'doc-index.json' containing definitions in this package."),o?p("p",{class:"error"},"To use quick jump, load this page with HTTP (from a local static file web server) instead of using the ",p("code",null,"file://")," protocol. (For security reasons, it is not possible to fetch auxiliary files using JS in a HTML page opened with ",p("code",null,"file://"),".)"):[]))}this.linkIndex=0;var r=function(e){e.stopPropagation()},c=i(10,t.moduleResults).map(function(e){return n.renderResultsInModule(e)});return p("div",{id:"search",class:t.isVisible?"":"hidden"},p("div",{id:"search-form",onMouseDown:r},p("input",{placeholder:"Search in package by name",ref:function(e){n.input=e},onFocus:this.show.bind(this),onClick:this.show.bind(this),onInput:this.updateResults.bind(this)})),p("div",{id:"search-results",ref:function(e){n.searchResults=e},onMouseDown:r,onMouseOver:function(e){for(var t=e.target;t&&"function"==typeof t.getAttribute;){var o=t.getAttribute("data-link-index");if("string"==typeof o){var r=parseInt(o,10);n.setState({activeLinkIndex:r});break}t=t.parentNode}}},""===t.searchString?[p(a,null),p(s,null)]:0==c.length?p(l,{searchString:t.searchString}):p("ul",null,c)))},t.prototype.renderResultsInModule=function(e){var t=this,n=e.items,o=e.module,r=this.state.expanded[o]||n.length<=10,s=r?n:i(8,n),a=function(e){return p("li",{class:"search-result"},t.navigationLink(t.props.baseUrl+"/"+e.link,{},p(m,{html:e.display_html})))};return p("li",{class:"search-module"},p("h4",null,o),p("ul",null,s.map(function(e){return a(e.item)}),r?[]:p("li",{class:"more-results"},this.actionLink(function(){var e=Object.assign({},t.state.expanded);e[o]=!0,t.setState({expanded:e})},{},"show "+(n.length-s.length)+" more results from this module"))))},t.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),s=function(){window.location.href=e,n.hide()};return this.menuLink.apply(this,[i,s].concat(o))},t.prototype.actionLink=function(e,t){for(var n=[],o=2;o<arguments.length;o++)n[o-2]=arguments[o];var r=Object.assign({href:"#",onClick:function(t){t.preventDefault(),e()}},t);return this.menuLink.apply(this,[r,e].concat(n))},t.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,p.apply(void 0,["a",s].concat(o))},t}(f),m=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return u(t,e),t.prototype.shouldComponentUpdate=function(e){return this.props.html!==e.html},t.prototype.render=function(e){return p("div",{dangerouslySetInnerHTML:{__html:e.html}})},t}(f);n.init=c,window.quickNav={init:c}},{"fuse.js":6,preact:7}],5:[function(e,t,n){"use strict";function o(e){return(" "+e+" ").replace(g," ")}function r(e){return e.replace(m,"")}function i(e,t){return o(e.className||"").indexOf(" "+t+" ")>=0}function s(e,t){var n=o(e.className||"");n.indexOf(" "+t+" ")<0&&(e.className=r(n+" "+t))}function a(e,t){var n=o(e.className||"");n=n.replace(" "+t+" "," "),e.className=r(n)}function l(e,t,n,o){return null==o&&(o=!i(e,t)),o?(a(e,n),s(e,t)):(a(e,t),s(e,n)),o}function c(e){var t=document.getElementById("page-menu");if(t&&t.firstChild){var n=t.firstChild.cloneNode(!1);n.innerHTML=e,t.appendChild(n)}}function u(){return Array.prototype.slice.call(document.getElementsByTagName("link")).filter(function(e){return-1!=e.rel.indexOf("style")&&e.title})}function h(){var e=u(),t="";e.forEach(function(e){t+="<li><a href='#' onclick=\"setActiveStyleSheet('"+e.title+"'); return false;\">"+e.title+"</a></li>"}),e.length>1&&c("<div id='style-menu-holder'><a href='#' onclick='styleMenu(); return false;'>Style &#9662;</a><ul id='style-menu' class='hide'>"+t+"</ul></div>")}function d(e){for(var t=u(),n=null,o=0;o<t.length;o++){var r=t[o];r.disabled=!0,r.title==e&&(n=r)}n?(n.disabled=!1,v.setCookie("haddock-style",e)):(t[0].disabled=!1,v.clearCookie("haddock-style")),f(!1)}function p(){var e=v.getCookie("haddock-style");e&&d(e)}function f(e){var t=document.getElementById("style-menu");t&&y(t,e)}Object.defineProperty(n,"__esModule",{value:!0});var v=e("./cookies"),g=/\s\s+/g,m=/^\s+|\s+$/g,y=function(e,t){return function(n,o){return l(n,e,t,o)}}("show","hide");n.init=function(){h(),p()}},{"./cookies":1}],6:[function(e,t,n){!function(e,o){"object"==typeof n&&"object"==typeof t?t.exports=o():"function"==typeof define&&define.amd?define("Fuse",[],o):"object"==typeof n?n.Fuse=o():e.Fuse=o()}(this,function(){return function(e){function t(o){if(n[o])return n[o].exports;var r=n[o]={i:o,l:!1,exports:{}};return e[o].call(r.exports,r,r.exports,t),r.l=!0,r.exports}var n={};return t.m=e,t.c=n,t.i=function(e){return e},t.d=function(e,n,o){t.o(e,n)||Object.defineProperty(e,n,{configurable:!1,enumerable:!0,get:o})},t.n=function(e){var n=e&&e.__esModule?function(){return e.default}:function(){return e};return t.d(n,"a",n),n},t.o=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},t.p="",t(t.s=8)}([function(e,t,n){"use strict";e.exports=function(e){return"[object Array]"===Object.prototype.toString.call(e)}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;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(t,n,o){return n&&e(t.prototype,n),o&&e(t,o),t}}(),i=n(5),s=n(7),a=n(4),l=function(){function e(t,n){var r=n.location,i=void 0===r?0:r,s=n.distance,l=void 0===s?100:s,c=n.threshold,u=void 0===c?.6:c,h=n.maxPatternLength,d=void 0===h?32:h,p=n.isCaseSensitive,f=void 0!==p&&p,v=n.tokenSeparator,g=void 0===v?/ +/g:v,m=n.findAllMatches,y=void 0!==m&&m,_=n.minMatchCharLength,k=void 0===_?1:_;o(this,e),this.options={location:i,distance:l,threshold:u,maxPatternLength:d,isCaseSensitive:f,tokenSeparator:g,findAllMatches:y,minMatchCharLength:k},this.pattern=this.options.isCaseSensitive?t:t.toLowerCase(),this.pattern.length<=d&&(this.patternAlphabet=a(this.pattern))}return r(e,[{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 i(e,this.pattern,o);var r=this.options,a=r.location,l=r.distance,c=r.threshold,u=r.findAllMatches,h=r.minMatchCharLength;return s(e,this.pattern,this.patternAlphabet,{location:a,distance:l,threshold:c,findAllMatches:u,minMatchCharLength:h})}}]),e}();e.exports=l},function(e,t,n){"use strict";var o=n(0),r=function e(t,n,r){if(n){var i=n.indexOf("."),s=n,a=null;-1!==i&&(s=n.slice(0,i),a=n.slice(i+1));var l=t[s];if(null!==l&&void 0!==l)if(a||"string"!=typeof l&&"number"!=typeof l)if(o(l))for(var c=0,u=l.length;c<u;c+=1)e(l[c],a,r);else a&&e(l,a,r);else r.push(l.toString())}else r.push(t);return r};e.exports=function(e,t){return r(e,t,[])}},function(e,t,n){"use strict";e.exports=function(){for(var e=arguments.length>0&&void 0!==arguments[0]?arguments[0]:[],t=arguments.length>1&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i<s;i+=1){var a=e[i];a&&-1===o?o=i:a||-1===o||((r=i-1)-o+1>=t&&n.push([o,r]),o=-1)}return e[i-1]&&i-o>=t&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;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 o=/[\-\[\]\/\{\}\(\)\*\+\?\.\\\^\$\|]/g;e.exports=function(e,t){var n=arguments.length>2&&void 0!==arguments[2]?arguments[2]:/ +/g,r=new RegExp(t.replace(o,"\\$&").replace(n,"|")),i=e.match(r),s=!!i,a=[];if(s)for(var l=0,c=i.length;l<c;l+=1){var u=i[l];a.push([e.indexOf(u),u.length-1])}return{score:s?.5:1,isMatch:s,matchedIndices:a}}},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 o=n(6),r=n(3);e.exports=function(e,t,n,i){for(var s=i.location,a=void 0===s?0:s,l=i.distance,c=void 0===l?100:l,u=i.threshold,h=void 0===u?.6:u,d=i.findAllMatches,p=void 0!==d&&d,f=i.minMatchCharLength,v=void 0===f?1:f,g=a,m=e.length,y=h,_=e.indexOf(t,g),k=t.length,b=[],x=0;x<m;x+=1)b[x]=0;if(-1!==_){var w=o(t,{errors:0,currentLocation:_,expectedLocation:g,distance:c});if(y=Math.min(w,y),-1!==(_=e.lastIndexOf(t,g+k))){var S=o(t,{errors:0,currentLocation:_,expectedLocation:g,distance:c});y=Math.min(S,y)}}_=-1;for(var L=[],C=1,M=k+m,N=1<<k-1,I=0;I<k;I+=1){for(var A=0,O=M;A<O;)o(t,{errors:I,currentLocation:g+O,expectedLocation:g,distance:c})<=y?A=O:M=O,O=Math.floor((M-A)/2+A);M=O;var E=Math.max(1,g-O+1),T=p?m:Math.min(g+O,m)+k,j=Array(T+2);j[T+1]=(1<<I)-1;for(var P=T;P>=E;P-=1){var R=P-1,U=n[e.charAt(R)];if(U&&(b[R]=1),j[P]=(j[P+1]<<1|1)&U,0!==I&&(j[P]|=(L[P+1]|L[P])<<1|1|L[P+1]),j[P]&N&&(C=o(t,{errors:I,currentLocation:R,expectedLocation:g,distance:c}))<=y){if(y=C,(_=R)<=g)break;E=Math.max(1,2*g-_)}}if(o(t,{errors:I+1,currentLocation:g,expectedLocation:g,distance:c})>y)break;L=j}return{isMatch:_>=0,score:0===C?.001:C,matchedIndices:r(b,v)}}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;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(t,n,o){return n&&e(t.prototype,n),o&&e(t,o),t}}(),i=n(1),s=n(2),a=n(0),l=function(){function e(t,n){var r=n.location,i=void 0===r?0:r,a=n.distance,l=void 0===a?100:a,c=n.threshold,u=void 0===c?.6:c,h=n.maxPatternLength,d=void 0===h?32:h,p=n.caseSensitive,f=void 0!==p&&p,v=n.tokenSeparator,g=void 0===v?/ +/g:v,m=n.findAllMatches,y=void 0!==m&&m,_=n.minMatchCharLength,k=void 0===_?1:_,b=n.id,x=void 0===b?null:b,w=n.keys,S=void 0===w?[]:w,L=n.shouldSort,C=void 0===L||L,M=n.getFn,N=void 0===M?s:M,I=n.sortFn,A=void 0===I?function(e,t){return e.score-t.score}:I,O=n.tokenize,E=void 0!==O&&O,T=n.matchAllTokens,j=void 0!==T&&T,P=n.includeMatches,R=void 0!==P&&P,U=n.includeScore,D=void 0!==U&&U,V=n.verbose,F=void 0!==V&&V;o(this,e),this.options={location:i,distance:l,threshold:u,maxPatternLength:d,isCaseSensitive:f,tokenSeparator:g,findAllMatches:y,minMatchCharLength:k,id:x,keys:S,includeMatches:R,includeScore:D,shouldSort:C,getFn:N,sortFn:A,verbose:F,tokenize:E,matchAllTokens:j},this.setCollection(t)}return r(e,[{key:"setCollection",value:function(e){return this.list=e,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=arguments.length>0&&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=arguments.length>0&&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,d=this.options.keys.length;h<d;h+=1){var p=this.options.keys[h];if("string"!=typeof p){if(a[p.name]={weight:1-p.weight||1},p.weight<=0||p.weight>1)throw new Error("Key weight has to be > 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,l=e.index,c=t.tokenSearchers,u=void 0===c?[]:c,h=t.fullSearcher,d=void 0===h?[]:h,p=t.resultMap,f=void 0===p?{}:p,v=t.results,g=void 0===v?[]:v;if(void 0!==i&&null!==i){var m=!1,y=-1,_=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var k=d.search(i);if(this._log('Full text: "'+i+'", score: '+k.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),x=[],w=0;w<u.length;w+=1){var S=u[w];this._log('\nPattern: "'+S.pattern+'"');for(var L=!1,C=0;C<b.length;C+=1){var M=b[C],N=S.search(M),I={};N.isMatch?(I[M]=N.score,m=!0,L=!0,x.push(N.score)):(I[M]=1,this.options.matchAllTokens||x.push(1)),this._log('Token: "'+M+'", score: '+I[M])}L&&(_+=1)}y=x[0];for(var A=x.length,O=1;O<A;O+=1)y+=x[O];y/=A,this._log("Token score average:",y)}var E=k.score;y>-1&&(E=(E+y)/2),this._log("Score average:",E);var T=!this.options.tokenize||!this.options.matchAllTokens||_>=u.length;if(this._log("\nCheck Matches: "+T),(m||k.isMatch)&&T){var j=f[l];j?j.output.push({key:n,arrayIndex:r,value:i,score:E,matchedIndices:k.matchedIndices}):(f[l]={item:s,output:[{key:n,arrayIndex:r,value:i,score:E,matchedIndices:k.matchedIndices}]},g.push(f[l]))}}else if(a(i))for(var P=0,R=i.length;P<R;P+=1)this._analyze({key:n,arrayIndex:P,value:i[P],record:s,index:l},{resultMap:f,results:g,tokenSearchers:u,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=0,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):(r[l].nScore=u,s+=u)}t[n].score=1===a?s/i: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._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")&&i.arrayIndex>-1&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;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(){if(this.options.verbose){var e;(e=console).log.apply(e,arguments)}}}]),e}();e.exports=l}])})},{}],7:[function(e,t,n){!function(){"use strict";function e(){}function n(t,n){var o,r,i,s,a=O;for(s=arguments.length;s-- >2;)A.push(arguments[s]);for(n&&null!=n.children&&(A.length||A.push(n.children),delete n.children);A.length;)if((r=A.pop())&&void 0!==r.pop)for(s=r.length;s--;)A.push(r[s]);else"boolean"==typeof r&&(r=null),(i="function"!=typeof t)&&(null==r?r="":"number"==typeof r?r=String(r):"string"!=typeof r&&(i=!1)),i&&o?a[a.length-1]+=r:a===O?a=[r]:a.push(r),o=i;var l=new e;return l.nodeName=t,l.children=a,l.attributes=null==n?void 0:n,l.key=null==n?void 0:n.key,void 0!==I.vnode&&I.vnode(l),l}function o(e,t){for(var n in t)e[n]=t[n];return e}function r(e){!e.__d&&(e.__d=!0)&&1==j.push(e)&&(I.debounceRendering||E)(i)}function i(){var e,t=j;for(j=[];e=t.pop();)e.__d&&L(e)}function s(e,t,n){return"string"==typeof t||"number"==typeof t?void 0!==e.splitText:"string"==typeof t.nodeName?!e._componentConstructor&&a(e,t.nodeName):n||e._componentConstructor===t.nodeName}function a(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function l(e){var t=o({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var r in n)void 0===t[r]&&(t[r]=n[r]);return t}function c(e,t){var n=t?document.createElementNS("http://www.w3.org/2000/svg",e):document.createElement(e);return n.__n=e,n}function u(e){var t=e.parentNode;t&&t.removeChild(e)}function h(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===T.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,p,s):e.removeEventListener(t,p,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e)d(e,t,null==o?"":o),null!=o&&!1!==o||e.removeAttribute(t);else{var a=r&&t!==(t=t.replace(/^xlink\:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function d(e,t,n){try{e[t]=n}catch(e){}}function p(e){return this.__l[e.type](I.event&&I.event(e)||e)}function f(){for(var e;e=P.pop();)I.afterMount&&I.afterMount(e),e.componentDidMount&&e.componentDidMount()}function v(e,t,n,o,r,i){R++||(U=null!=r&&void 0!==r.ownerSVGElement,D=null!=e&&!("__preactattr_"in e));var s=g(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(D=!1,i||f()),s}function g(e,t,n,o,r){var i=e,s=U;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),y(e,!0))),i.__preactattr_=!0,i;var l=t.nodeName;if("function"==typeof l)return C(e,t,n,o);if(U="svg"===l||"foreignObject"!==l&&U,l=String(l),(!e||!a(e,l))&&(i=c(l,U),e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),y(e,!0)}var u=i.firstChild,h=i.__preactattr_,d=t.children;if(null==h){h=i.__preactattr_={};for(var p=i.attributes,f=p.length;f--;)h[p[f].name]=p[f].value}return!D&&d&&1===d.length&&"string"==typeof d[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=d[0]&&(u.nodeValue=d[0]):(d&&d.length||null!=u)&&m(i,d,n,o,D||null!=h.dangerouslySetInnerHTML),k(i,t.attributes,h),U=s,i}function m(e,t,n,o,r){var i,a,l,c,h,d=e.childNodes,p=[],f={},v=0,m=0,_=d.length,k=0,b=t?t.length:0;if(0!==_)for(L=0;L<_;L++){var x=d[L],w=x.__preactattr_;null!=(S=b&&w?x._component?x._component.__k:w.key:null)?(v++,f[S]=x):(w||(void 0!==x.splitText?!r||x.nodeValue.trim():r))&&(p[k++]=x)}if(0!==b)for(L=0;L<b;L++){h=null;var S=(c=t[L]).key;if(null!=S)v&&void 0!==f[S]&&(h=f[S],f[S]=void 0,v--);else if(!h&&m<k)for(i=m;i<k;i++)if(void 0!==p[i]&&s(a=p[i],c,r)){h=a,p[i]=void 0,i===k-1&&k--,i===m&&m++;break}h=g(h,c,n,o),l=d[L],h&&h!==e&&h!==l&&(null==l?e.appendChild(h):h===l.nextSibling?u(l):e.insertBefore(h,l))}if(v)for(var L in f)void 0!==f[L]&&y(f[L],!1);for(;m<=k;)void 0!==(h=p[k--])&&y(h,!1)}function y(e,t){var n=e._component;n?M(n):(null!=e.__preactattr_&&e.__preactattr_.ref&&e.__preactattr_.ref(null),!1!==t&&null!=e.__preactattr_||u(e),_(e))}function _(e){for(e=e.lastChild;e;){var t=e.previousSibling;y(e,!0),e=t}}function k(e,t,n){var o;for(o in n)t&&null!=t[o]||null==n[o]||h(e,o,n[o],n[o]=void 0,U);for(o in t)"children"===o||"innerHTML"===o||o in n&&t[o]===("value"===o||"checked"===o?e[o]:n[o])||h(e,o,n[o],n[o]=t[o],U)}function b(e){var t=e.constructor.name;(V[t]||(V[t]=[])).push(e)}function x(e,t,n){var o,r=V[e.name];if(e.prototype&&e.prototype.render?(o=new e(t,n),N.call(o,t,n)):((o=new N(t,n)).constructor=e,o.render=w),r)for(var i=r.length;i--;)if(r[i].constructor===e){o.__b=r[i].__b,r.splice(i,1);break}return o}function w(e,t,n){return this.constructor(e,n)}function S(e,t,n,o,i){e.__x||(e.__x=!0,(e.__r=t.ref)&&delete t.ref,(e.__k=t.key)&&delete t.key,!e.base||i?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===I.syncComponentUpdates&&e.base?r(e):L(e,1,i)),e.__r&&e.__r(e))}function L(e,t,n,r){if(!e.__x){var i,s,a,c=e.props,u=e.state,h=e.context,d=e.__p||c,p=e.__s||u,g=e.__c||h,m=e.base,_=e.__b,k=m||_,b=e._component,w=!1;if(m&&(e.props=d,e.state=p,e.context=g,2!==t&&e.shouldComponentUpdate&&!1===e.shouldComponentUpdate(c,u,h)?w=!0:e.componentWillUpdate&&e.componentWillUpdate(c,u,h),e.props=c,e.state=u,e.context=h),e.__p=e.__s=e.__c=e.__b=null,e.__d=!1,!w){i=e.render(c,u,h),e.getChildContext&&(h=o(o({},h),e.getChildContext()));var C,N,A=i&&i.nodeName;if("function"==typeof A){var O=l(i);(s=b)&&s.constructor===A&&O.key==s.__k?S(s,O,1,h,!1):(C=s,e._component=s=x(A,O,h),s.__b=s.__b||_,s.__u=e,S(s,O,0,h,!1),L(s,1,n,!0)),N=s.base}else a=k,(C=b)&&(a=e._component=null),(k||1===t)&&(a&&(a._component=null),N=v(a,i,h,n||!m,k&&k.parentNode,!0));if(k&&N!==k&&s!==b){var E=k.parentNode;E&&N!==E&&(E.replaceChild(N,k),C||(k._component=null,y(k,!1)))}if(C&&M(C),e.base=N,N&&!r){for(var T=e,j=e;j=j.__u;)(T=j).base=N;N._component=T,N._componentConstructor=T.constructor}}if(!m||n?P.unshift(e):w||(e.componentDidUpdate&&e.componentDidUpdate(d,p,g),I.afterUpdate&&I.afterUpdate(e)),null!=e.__h)for(;e.__h.length;)e.__h.pop().call(e);R||r||f()}}function C(e,t,n,o){for(var r=e&&e._component,i=r,s=e,a=r&&e._componentConstructor===t.nodeName,c=a,u=l(t);r&&!c&&(r=r.__u);)c=r.constructor===t.nodeName;return r&&c&&(!o||r._component)?(S(r,u,3,n,o),e=r.base):(i&&!a&&(M(i),e=s=null),r=x(t.nodeName,u,n),e&&!r.__b&&(r.__b=e,s=null),S(r,u,1,n,o),e=r.base,s&&e!==s&&(s._component=null,y(s,!1))),e}function M(e){I.beforeUnmount&&I.beforeUnmount(e);var t=e.base;e.__x=!0,e.componentWillUnmount&&e.componentWillUnmount(),e.base=null;var n=e._component;n?M(n):t&&(t.__preactattr_&&t.__preactattr_.ref&&t.__preactattr_.ref(null),e.__b=t,u(t),b(e),_(t)),e.__r&&e.__r(null)}function N(e,t){this.__d=!0,this.context=t,this.props=e,this.state=this.state||{}}var I={},A=[],O=[],E="function"==typeof Promise?Promise.resolve().then.bind(Promise.resolve()):setTimeout,T=/acit|ex(?:s|g|n|p|$)|rph|ows|mnc|ntw|ine[ch]|zoo|^ord/i,j=[],P=[],R=0,U=!1,D=!1,V={};o(N.prototype,{setState:function(e,t){var n=this.state;this.__s||(this.__s=o({},n)),o(n,"function"==typeof e?e(n,this.props):e),t&&(this.__h=this.__h||[]).push(t),r(this)},forceUpdate:function(e){e&&(this.__h=this.__h||[]).push(e),L(this,2)},render:function(){}});var F={h:n,createElement:n,cloneElement:function(e,t){return n(e.nodeName,o(o({},e.attributes),t),arguments.length>2?[].slice.call(arguments,2):e.children)},Component:N,render:function(e,t,n){return v(n,e,{},!1,t,!1)},rerender:i,options:I};void 0!==t?t.exports=F:self.preact=F}()},{}]},{},[3]);+//# sourceMappingURL=haddock-bundle.min.js.map
− resources/html/haddock-util.js 
@@ -1,186 +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);-  return b;-}--var collapsed = {};-function rememberCollapsed(id)-{-  if(collapsed[id])-    delete collapsed[id]-  else-    collapsed[id] = true;--  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;-}--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,164 @@+/* @group Search box layout */++#search {+  position: fixed;+  top: 3.2em;+  bottom: 0;+  left: calc(50% - 22em);+  width: 44em;+  z-index: 1000;+  pointer-events: none;+  overflow-y: auto;+}++#search.hidden {+  display: none;+}++#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;+}++#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 */
+ resources/html/quick-jump.min.js view
@@ -0,0 +1,2 @@+!function e(t,n,o){function r(s,a){if(!n[s]){if(!t[s]){var l="function"==typeof require&&require;if(!a&&l)return l(s,!0);if(i)return i(s,!0);var c=new Error("Cannot find module '"+s+"'");throw c.code="MODULE_NOT_FOUND",c}var u=n[s]={exports:{}};t[s][0].call(u.exports,function(e){var n=t[s][1][e];return r(n||e)},u,u.exports,e,t,n,o)}return n[s].exports}for(var i="function"==typeof require&&require,s=0;s<o.length;s++)r(o[s]);return r}({1:[function(e,t,n){"use strict";function o(e,t,n){var o=new XMLHttpRequest;o.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()}function r(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),p.render(d(v,{onClick:e,title:"Quick Jump"}),t,n)}function i(e,t){return t.length<=e?t:t.slice(0,e)}function s(){return d("table",{class:"keyboard-shortcuts"},d("tr",null,d("th",null,"Key"),d("th",null,"Shortcut")),d("tr",null,d("td",null,d("span",{class:"key"},"s")),d("td",null,"Open this search box")),d("tr",null,d("td",null,d("span",{class:"key"},"esc")),d("td",null,"Close this search box")),d("tr",null,d("td",null,d("span",{class:"key"},"↓"),",",d("span",{class:"key"},"ctrl")," + ",d("span",{class:"key"},"j")),d("td",null,"Move down in search results")),d("tr",null,d("td",null,d("span",{class:"key"},"↑"),",",d("span",{class:"key"},"ctrl")," + ",d("span",{class:"key"},"k")),d("td",null,"Move up in search results")),d("tr",null,d("td",null,d("span",{class:"key"},"↵")),d("td",null,"Go to active search result")))}function a(){return d("p",null,"You can find any exported type, constructor, class, function or pattern defined in this package by (approximate) name.")}function l(e){var t=[d("p",null,"Your search for '",e.searchString,"' produced the following list of results: ",d("code",null,"[]"),"."),d("p",null,d("code",null,"Nothing")," matches your query for '",e.searchString,"'."),d("p",null,d("code",null,"Left \"no matches for '",e.searchString,"'\" :: Either String (NonEmpty SearchResult)"))];return t[(e.searchString||"a").charCodeAt(0)%t.length]}function c(e,t){p.render(d(_,{baseUrl:e||".",showHideTrigger:t||r}),document.body)}var u=this&&this.__extends||function(){var e=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])};return function(t,n){function o(){this.constructor=t}e(t,n),t.prototype=null===n?Object.create(n):(o.prototype=n.prototype,new o)}}();Object.defineProperty(n,"__esModule",{value:!0});var h=e("fuse.js"),p=e("preact"),d=p.h,f=p.Component,v=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return u(t,e),t.prototype.render=function(e){return d("li",null,d("a",{href:"#",onClick:function(t){t.preventDefault(),e.onClick()}},e.title))},t}(f),_=function(e){function t(){var t=null!==e&&e.apply(this,arguments)||this;return t.linkIndex=0,t.focusPlease=!1,t.navigatedByKeyboard=!1,t}return u(t,e),t.prototype.componentWillMount=function(){var e=this;this.setState({searchString:"",isVisible:!1,expanded:{},activeLinkIndex:-1,moduleResults:[]}),o(this.props.baseUrl+"/doc-index.json",function(t){e.setState({fuse:new h(t,{threshold:.25,caseSensitive:!0,includeScore:!0,tokenize:!0,keys:[{name:"name",weight:.7},{name:"module",weight:.3}]}),moduleResults:[]})},function(t){console&&console.error("could not load 'doc-index.json' for searching",t),e.setState({failedLoading:!0})}),document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(t){e.state.isVisible&&("Escape"===t.key?e.hide():"ArrowUp"===t.key||"k"===t.key&&t.ctrlKey?(t.preventDefault(),e.navigateLinks(-1)):"ArrowDown"===t.key||"j"===t.key&&t.ctrlKey?(t.preventDefault(),e.navigateLinks(1)):"Enter"===t.key&&e.state.activeLinkIndex>=0&&e.followActiveLink()),"s"===t.key&&"input"!==t.target.tagName.toLowerCase()&&(t.preventDefault(),e.show())})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},t.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},t.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t={};this.state.fuse.search(e).forEach(function(e){var n=e.item.module;(t[n]||(t[n]=[])).push(e)});var n=[];for(var o in t)!function(e){var o=t[e],r=0;o.forEach(function(e){r+=1/e.score}),n.push({module:e,totalScore:1/r,items:o})}(o);n.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:n})},t.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.top<t&&(this.searchResults.scrollTop-=t-e.top+80)}this.focusPlease&&this.input&&this.input.focus(),this.navigatedByKeyboard=!1,this.focusPlease=!1},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){var n=this;if(t.failedLoading){var o="file:"==window.location.protocol;return d("div",{id:"search",class:t.isVisible?"":"hidden"},d("div",{id:"search-results"},d("p",{class:"error"},"Failed to load file 'doc-index.json' containing definitions in this package."),o?d("p",{class:"error"},"To use quick jump, load this page with HTTP (from a local static file web server) instead of using the ",d("code",null,"file://")," protocol. (For security reasons, it is not possible to fetch auxiliary files using JS in a HTML page opened with ",d("code",null,"file://"),".)"):[]))}this.linkIndex=0;var r=function(e){e.stopPropagation()},c=i(10,t.moduleResults).map(function(e){return n.renderResultsInModule(e)});return d("div",{id:"search",class:t.isVisible?"":"hidden"},d("div",{id:"search-form",onMouseDown:r},d("input",{placeholder:"Search in package by name",ref:function(e){n.input=e},onFocus:this.show.bind(this),onClick:this.show.bind(this),onInput:this.updateResults.bind(this)})),d("div",{id:"search-results",ref:function(e){n.searchResults=e},onMouseDown:r,onMouseOver:function(e){for(var t=e.target;t&&"function"==typeof t.getAttribute;){var o=t.getAttribute("data-link-index");if("string"==typeof o){var r=parseInt(o,10);n.setState({activeLinkIndex:r});break}t=t.parentNode}}},""===t.searchString?[d(a,null),d(s,null)]:0==c.length?d(l,{searchString:t.searchString}):d("ul",null,c)))},t.prototype.renderResultsInModule=function(e){var t=this,n=e.items,o=e.module,r=this.state.expanded[o]||n.length<=10,s=r?n:i(8,n),a=function(e){return d("li",{class:"search-result"},t.navigationLink(t.props.baseUrl+"/"+e.link,{},d(g,{html:e.display_html})))};return d("li",{class:"search-module"},d("h4",null,o),d("ul",null,s.map(function(e){return a(e.item)}),r?[]:d("li",{class:"more-results"},this.actionLink(function(){var e=Object.assign({},t.state.expanded);e[o]=!0,t.setState({expanded:e})},{},"show "+(n.length-s.length)+" more results from this module"))))},t.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),s=function(){window.location.href=e,n.hide()};return this.menuLink.apply(this,[i,s].concat(o))},t.prototype.actionLink=function(e,t){for(var n=[],o=2;o<arguments.length;o++)n[o-2]=arguments[o];var r=Object.assign({href:"#",onClick:function(t){t.preventDefault(),e()}},t);return this.menuLink.apply(this,[r,e].concat(n))},t.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,d.apply(void 0,["a",s].concat(o))},t}(f),g=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return u(t,e),t.prototype.shouldComponentUpdate=function(e){return this.props.html!==e.html},t.prototype.render=function(e){return d("div",{dangerouslySetInnerHTML:{__html:e.html}})},t}(f);n.init=c,window.quickNav={init:c}},{"fuse.js":2,preact:3}],2:[function(e,t,n){!function(e,o){"object"==typeof n&&"object"==typeof t?t.exports=o():"function"==typeof define&&define.amd?define("Fuse",[],o):"object"==typeof n?n.Fuse=o():e.Fuse=o()}(this,function(){return function(e){function t(o){if(n[o])return n[o].exports;var r=n[o]={i:o,l:!1,exports:{}};return e[o].call(r.exports,r,r.exports,t),r.l=!0,r.exports}var n={};return t.m=e,t.c=n,t.i=function(e){return e},t.d=function(e,n,o){t.o(e,n)||Object.defineProperty(e,n,{configurable:!1,enumerable:!0,get:o})},t.n=function(e){var n=e&&e.__esModule?function(){return e.default}:function(){return e};return t.d(n,"a",n),n},t.o=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},t.p="",t(t.s=8)}([function(e,t,n){"use strict";e.exports=function(e){return"[object Array]"===Object.prototype.toString.call(e)}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;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(t,n,o){return n&&e(t.prototype,n),o&&e(t,o),t}}(),i=n(5),s=n(7),a=n(4),l=function(){function e(t,n){var r=n.location,i=void 0===r?0:r,s=n.distance,l=void 0===s?100:s,c=n.threshold,u=void 0===c?.6:c,h=n.maxPatternLength,p=void 0===h?32:h,d=n.isCaseSensitive,f=void 0!==d&&d,v=n.tokenSeparator,_=void 0===v?/ +/g:v,g=n.findAllMatches,m=void 0!==g&&g,y=n.minMatchCharLength,k=void 0===y?1:y;o(this,e),this.options={location:i,distance:l,threshold:u,maxPatternLength:p,isCaseSensitive:f,tokenSeparator:_,findAllMatches:m,minMatchCharLength:k},this.pattern=this.options.isCaseSensitive?t:t.toLowerCase(),this.pattern.length<=p&&(this.patternAlphabet=a(this.pattern))}return r(e,[{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 i(e,this.pattern,o);var r=this.options,a=r.location,l=r.distance,c=r.threshold,u=r.findAllMatches,h=r.minMatchCharLength;return s(e,this.pattern,this.patternAlphabet,{location:a,distance:l,threshold:c,findAllMatches:u,minMatchCharLength:h})}}]),e}();e.exports=l},function(e,t,n){"use strict";var o=n(0),r=function e(t,n,r){if(n){var i=n.indexOf("."),s=n,a=null;-1!==i&&(s=n.slice(0,i),a=n.slice(i+1));var l=t[s];if(null!==l&&void 0!==l)if(a||"string"!=typeof l&&"number"!=typeof l)if(o(l))for(var c=0,u=l.length;c<u;c+=1)e(l[c],a,r);else a&&e(l,a,r);else r.push(l.toString())}else r.push(t);return r};e.exports=function(e,t){return r(e,t,[])}},function(e,t,n){"use strict";e.exports=function(){for(var e=arguments.length>0&&void 0!==arguments[0]?arguments[0]:[],t=arguments.length>1&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i<s;i+=1){var a=e[i];a&&-1===o?o=i:a||-1===o||((r=i-1)-o+1>=t&&n.push([o,r]),o=-1)}return e[i-1]&&i-o>=t&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;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 o=/[\-\[\]\/\{\}\(\)\*\+\?\.\\\^\$\|]/g;e.exports=function(e,t){var n=arguments.length>2&&void 0!==arguments[2]?arguments[2]:/ +/g,r=new RegExp(t.replace(o,"\\$&").replace(n,"|")),i=e.match(r),s=!!i,a=[];if(s)for(var l=0,c=i.length;l<c;l+=1){var u=i[l];a.push([e.indexOf(u),u.length-1])}return{score:s?.5:1,isMatch:s,matchedIndices:a}}},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 o=n(6),r=n(3);e.exports=function(e,t,n,i){for(var s=i.location,a=void 0===s?0:s,l=i.distance,c=void 0===l?100:l,u=i.threshold,h=void 0===u?.6:u,p=i.findAllMatches,d=void 0!==p&&p,f=i.minMatchCharLength,v=void 0===f?1:f,_=a,g=e.length,m=h,y=e.indexOf(t,_),k=t.length,b=[],x=0;x<g;x+=1)b[x]=0;if(-1!==y){var w=o(t,{errors:0,currentLocation:y,expectedLocation:_,distance:c});if(m=Math.min(w,m),-1!==(y=e.lastIndexOf(t,_+k))){var S=o(t,{errors:0,currentLocation:y,expectedLocation:_,distance:c});m=Math.min(S,m)}}y=-1;for(var L=[],C=1,M=k+g,N=1<<k-1,I=0;I<k;I+=1){for(var A=0,T=M;A<T;)o(t,{errors:I,currentLocation:_+T,expectedLocation:_,distance:c})<=m?A=T:M=T,T=Math.floor((M-A)/2+A);M=T;var O=Math.max(1,_-T+1),j=d?g:Math.min(_+T,g)+k,P=Array(j+2);P[j+1]=(1<<I)-1;for(var E=j;E>=O;E-=1){var R=E-1,U=n[e.charAt(R)];if(U&&(b[R]=1),P[E]=(P[E+1]<<1|1)&U,0!==I&&(P[E]|=(L[E+1]|L[E])<<1|1|L[E+1]),P[E]&N&&(C=o(t,{errors:I,currentLocation:R,expectedLocation:_,distance:c}))<=m){if(m=C,(y=R)<=_)break;O=Math.max(1,2*_-y)}}if(o(t,{errors:I+1,currentLocation:_,expectedLocation:_,distance:c})>m)break;L=P}return{isMatch:y>=0,score:0===C?.001:C,matchedIndices:r(b,v)}}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;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(t,n,o){return n&&e(t.prototype,n),o&&e(t,o),t}}(),i=n(1),s=n(2),a=n(0),l=function(){function e(t,n){var r=n.location,i=void 0===r?0:r,a=n.distance,l=void 0===a?100:a,c=n.threshold,u=void 0===c?.6:c,h=n.maxPatternLength,p=void 0===h?32:h,d=n.caseSensitive,f=void 0!==d&&d,v=n.tokenSeparator,_=void 0===v?/ +/g:v,g=n.findAllMatches,m=void 0!==g&&g,y=n.minMatchCharLength,k=void 0===y?1:y,b=n.id,x=void 0===b?null:b,w=n.keys,S=void 0===w?[]:w,L=n.shouldSort,C=void 0===L||L,M=n.getFn,N=void 0===M?s:M,I=n.sortFn,A=void 0===I?function(e,t){return e.score-t.score}:I,T=n.tokenize,O=void 0!==T&&T,j=n.matchAllTokens,P=void 0!==j&&j,E=n.includeMatches,R=void 0!==E&&E,U=n.includeScore,D=void 0!==U&&U,V=n.verbose,F=void 0!==V&&V;o(this,e),this.options={location:i,distance:l,threshold:u,maxPatternLength:p,isCaseSensitive:f,tokenSeparator:_,findAllMatches:m,minMatchCharLength:k,id:x,keys:S,includeMatches:R,includeScore:D,shouldSort:C,getFn:N,sortFn:A,verbose:F,tokenize:O,matchAllTokens:P},this.setCollection(t)}return r(e,[{key:"setCollection",value:function(e){return this.list=e,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=arguments.length>0&&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=arguments.length>0&&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||d.weight>1)throw new Error("Key weight has to be > 0 and <= 1");d=d.name}else a[d]={weight:1};this._analyze({key:d,value:this.options.getFn(u,d),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,l=e.index,c=t.tokenSearchers,u=void 0===c?[]:c,h=t.fullSearcher,p=void 0===h?[]:h,d=t.resultMap,f=void 0===d?{}:d,v=t.results,_=void 0===v?[]:v;if(void 0!==i&&null!==i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var k=p.search(i);if(this._log('Full text: "'+i+'", score: '+k.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),x=[],w=0;w<u.length;w+=1){var S=u[w];this._log('\nPattern: "'+S.pattern+'"');for(var L=!1,C=0;C<b.length;C+=1){var M=b[C],N=S.search(M),I={};N.isMatch?(I[M]=N.score,g=!0,L=!0,x.push(N.score)):(I[M]=1,this.options.matchAllTokens||x.push(1)),this._log('Token: "'+M+'", score: '+I[M])}L&&(y+=1)}m=x[0];for(var A=x.length,T=1;T<A;T+=1)m+=x[T];m/=A,this._log("Token score average:",m)}var O=k.score;m>-1&&(O=(O+m)/2),this._log("Score average:",O);var j=!this.options.tokenize||!this.options.matchAllTokens||y>=u.length;if(this._log("\nCheck Matches: "+j),(g||k.isMatch)&&j){var P=f[l];P?P.output.push({key:n,arrayIndex:r,value:i,score:O,matchedIndices:k.matchedIndices}):(f[l]={item:s,output:[{key:n,arrayIndex:r,value:i,score:O,matchedIndices:k.matchedIndices}]},_.push(f[l]))}}else if(a(i))for(var E=0,R=i.length;E<R;E+=1)this._analyze({key:n,arrayIndex:E,value:i[E],record:s,index:l},{resultMap:f,results:_,tokenSearchers:u,fullSearcher:p})}}},{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=0,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):(r[l].nScore=u,s+=u)}t[n].score=1===a?s/i: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._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")&&i.arrayIndex>-1&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;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(){if(this.options.verbose){var e;(e=console).log.apply(e,arguments)}}}]),e}();e.exports=l}])})},{}],3:[function(e,t,n){!function(){"use strict";function e(){}function n(t,n){var o,r,i,s,a=T;for(s=arguments.length;s-- >2;)A.push(arguments[s]);for(n&&null!=n.children&&(A.length||A.push(n.children),delete n.children);A.length;)if((r=A.pop())&&void 0!==r.pop)for(s=r.length;s--;)A.push(r[s]);else"boolean"==typeof r&&(r=null),(i="function"!=typeof t)&&(null==r?r="":"number"==typeof r?r=String(r):"string"!=typeof r&&(i=!1)),i&&o?a[a.length-1]+=r:a===T?a=[r]:a.push(r),o=i;var l=new e;return l.nodeName=t,l.children=a,l.attributes=null==n?void 0:n,l.key=null==n?void 0:n.key,void 0!==I.vnode&&I.vnode(l),l}function o(e,t){for(var n in t)e[n]=t[n];return e}function r(e){!e.__d&&(e.__d=!0)&&1==P.push(e)&&(I.debounceRendering||O)(i)}function i(){var e,t=P;for(P=[];e=t.pop();)e.__d&&L(e)}function s(e,t,n){return"string"==typeof t||"number"==typeof t?void 0!==e.splitText:"string"==typeof t.nodeName?!e._componentConstructor&&a(e,t.nodeName):n||e._componentConstructor===t.nodeName}function a(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function l(e){var t=o({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var r in n)void 0===t[r]&&(t[r]=n[r]);return t}function c(e,t){var n=t?document.createElementNS("http://www.w3.org/2000/svg",e):document.createElement(e);return n.__n=e,n}function u(e){var t=e.parentNode;t&&t.removeChild(e)}function h(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===j.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,d,s):e.removeEventListener(t,d,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e)p(e,t,null==o?"":o),null!=o&&!1!==o||e.removeAttribute(t);else{var a=r&&t!==(t=t.replace(/^xlink\:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function p(e,t,n){try{e[t]=n}catch(e){}}function d(e){return this.__l[e.type](I.event&&I.event(e)||e)}function f(){for(var e;e=E.pop();)I.afterMount&&I.afterMount(e),e.componentDidMount&&e.componentDidMount()}function v(e,t,n,o,r,i){R++||(U=null!=r&&void 0!==r.ownerSVGElement,D=null!=e&&!("__preactattr_"in e));var s=_(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(D=!1,i||f()),s}function _(e,t,n,o,r){var i=e,s=U;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),m(e,!0))),i.__preactattr_=!0,i;var l=t.nodeName;if("function"==typeof l)return C(e,t,n,o);if(U="svg"===l||"foreignObject"!==l&&U,l=String(l),(!e||!a(e,l))&&(i=c(l,U),e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),m(e,!0)}var u=i.firstChild,h=i.__preactattr_,p=t.children;if(null==h){h=i.__preactattr_={};for(var d=i.attributes,f=d.length;f--;)h[d[f].name]=d[f].value}return!D&&p&&1===p.length&&"string"==typeof p[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=p[0]&&(u.nodeValue=p[0]):(p&&p.length||null!=u)&&g(i,p,n,o,D||null!=h.dangerouslySetInnerHTML),k(i,t.attributes,h),U=s,i}function g(e,t,n,o,r){var i,a,l,c,h,p=e.childNodes,d=[],f={},v=0,g=0,y=p.length,k=0,b=t?t.length:0;if(0!==y)for(L=0;L<y;L++){var x=p[L],w=x.__preactattr_;null!=(S=b&&w?x._component?x._component.__k:w.key:null)?(v++,f[S]=x):(w||(void 0!==x.splitText?!r||x.nodeValue.trim():r))&&(d[k++]=x)}if(0!==b)for(L=0;L<b;L++){h=null;var S=(c=t[L]).key;if(null!=S)v&&void 0!==f[S]&&(h=f[S],f[S]=void 0,v--);else if(!h&&g<k)for(i=g;i<k;i++)if(void 0!==d[i]&&s(a=d[i],c,r)){h=a,d[i]=void 0,i===k-1&&k--,i===g&&g++;break}h=_(h,c,n,o),l=p[L],h&&h!==e&&h!==l&&(null==l?e.appendChild(h):h===l.nextSibling?u(l):e.insertBefore(h,l))}if(v)for(var L in f)void 0!==f[L]&&m(f[L],!1);for(;g<=k;)void 0!==(h=d[k--])&&m(h,!1)}function m(e,t){var n=e._component;n?M(n):(null!=e.__preactattr_&&e.__preactattr_.ref&&e.__preactattr_.ref(null),!1!==t&&null!=e.__preactattr_||u(e),y(e))}function y(e){for(e=e.lastChild;e;){var t=e.previousSibling;m(e,!0),e=t}}function k(e,t,n){var o;for(o in n)t&&null!=t[o]||null==n[o]||h(e,o,n[o],n[o]=void 0,U);for(o in t)"children"===o||"innerHTML"===o||o in n&&t[o]===("value"===o||"checked"===o?e[o]:n[o])||h(e,o,n[o],n[o]=t[o],U)}function b(e){var t=e.constructor.name;(V[t]||(V[t]=[])).push(e)}function x(e,t,n){var o,r=V[e.name];if(e.prototype&&e.prototype.render?(o=new e(t,n),N.call(o,t,n)):((o=new N(t,n)).constructor=e,o.render=w),r)for(var i=r.length;i--;)if(r[i].constructor===e){o.__b=r[i].__b,r.splice(i,1);break}return o}function w(e,t,n){return this.constructor(e,n)}function S(e,t,n,o,i){e.__x||(e.__x=!0,(e.__r=t.ref)&&delete t.ref,(e.__k=t.key)&&delete t.key,!e.base||i?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===I.syncComponentUpdates&&e.base?r(e):L(e,1,i)),e.__r&&e.__r(e))}function L(e,t,n,r){if(!e.__x){var i,s,a,c=e.props,u=e.state,h=e.context,p=e.__p||c,d=e.__s||u,_=e.__c||h,g=e.base,y=e.__b,k=g||y,b=e._component,w=!1;if(g&&(e.props=p,e.state=d,e.context=_,2!==t&&e.shouldComponentUpdate&&!1===e.shouldComponentUpdate(c,u,h)?w=!0:e.componentWillUpdate&&e.componentWillUpdate(c,u,h),e.props=c,e.state=u,e.context=h),e.__p=e.__s=e.__c=e.__b=null,e.__d=!1,!w){i=e.render(c,u,h),e.getChildContext&&(h=o(o({},h),e.getChildContext()));var C,N,A=i&&i.nodeName;if("function"==typeof A){var T=l(i);(s=b)&&s.constructor===A&&T.key==s.__k?S(s,T,1,h,!1):(C=s,e._component=s=x(A,T,h),s.__b=s.__b||y,s.__u=e,S(s,T,0,h,!1),L(s,1,n,!0)),N=s.base}else a=k,(C=b)&&(a=e._component=null),(k||1===t)&&(a&&(a._component=null),N=v(a,i,h,n||!g,k&&k.parentNode,!0));if(k&&N!==k&&s!==b){var O=k.parentNode;O&&N!==O&&(O.replaceChild(N,k),C||(k._component=null,m(k,!1)))}if(C&&M(C),e.base=N,N&&!r){for(var j=e,P=e;P=P.__u;)(j=P).base=N;N._component=j,N._componentConstructor=j.constructor}}if(!g||n?E.unshift(e):w||(e.componentDidUpdate&&e.componentDidUpdate(p,d,_),I.afterUpdate&&I.afterUpdate(e)),null!=e.__h)for(;e.__h.length;)e.__h.pop().call(e);R||r||f()}}function C(e,t,n,o){for(var r=e&&e._component,i=r,s=e,a=r&&e._componentConstructor===t.nodeName,c=a,u=l(t);r&&!c&&(r=r.__u);)c=r.constructor===t.nodeName;return r&&c&&(!o||r._component)?(S(r,u,3,n,o),e=r.base):(i&&!a&&(M(i),e=s=null),r=x(t.nodeName,u,n),e&&!r.__b&&(r.__b=e,s=null),S(r,u,1,n,o),e=r.base,s&&e!==s&&(s._component=null,m(s,!1))),e}function M(e){I.beforeUnmount&&I.beforeUnmount(e);var t=e.base;e.__x=!0,e.componentWillUnmount&&e.componentWillUnmount(),e.base=null;var n=e._component;n?M(n):t&&(t.__preactattr_&&t.__preactattr_.ref&&t.__preactattr_.ref(null),e.__b=t,u(t),b(e),y(t)),e.__r&&e.__r(null)}function N(e,t){this.__d=!0,this.context=t,this.props=e,this.state=this.state||{}}var I={},A=[],T=[],O="function"==typeof Promise?Promise.resolve().then.bind(Promise.resolve()):setTimeout,j=/acit|ex(?:s|g|n|p|$)|rph|ows|mnc|ntw|ine[ch]|zoo|^ord/i,P=[],E=[],R=0,U=!1,D=!1,V={};o(N.prototype,{setState:function(e,t){var n=this.state;this.__s||(this.__s=o({},n)),o(n,"function"==typeof e?e(n,this.props):e),t&&(this.__h=this.__h||[]).push(t),r(this)},forceUpdate:function(e){e&&(this.__h=this.__h||[]).push(e),L(this,2)},render:function(){}});var F={h:n,createElement:n,cloneElement:function(e,t){return n(e.nodeName,o(o({},e.attributes),t),arguments.length>2?[].slice.call(arguments,2):e.children)},Component:N,render:function(e,t,n){return v(n,e,{},!1,t,!1)},rerender:i,options:I};void 0!==t?t.exports=F:self.preact=F}()},{}]},{},[1]);+//# sourceMappingURL=quick-jump.min.js.map
src/Documentation/Haddock.hs view
@@ -39,7 +39,8 @@   DocH(..),   Example(..),   Hyperlink(..),-  DocMarkup(..),+  DocMarkup,+  DocMarkupH(..),   Documentation(..),   ArgMap,   AliasMap,@@ -69,12 +70,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
@@ -27,11 +27,13 @@  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@@ -41,7 +43,8 @@  import Control.Monad hiding (forM_) import Control.Applicative-import Data.Foldable (forM_)+import Data.Foldable (forM_, foldl')+import Data.Traversable (for) import Data.List (isPrefixOf) import Control.Exception import Data.Maybe@@ -65,9 +68,11 @@ import System.Directory (doesDirectoryExist) #endif +import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity)+import ErrUtils import Packages import Panic (handleGhcException) import Module@@ -161,9 +166,13 @@       hPutStrLn stderr warning    ghc flags' $ do-     dflags <- getDynFlags +    forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do+      mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)]+      forM_ mIfaceFile $ \(_, ifaceFile) -> do+        putMsg dflags (renderJson (jsonInterfaceFile ifaceFile))+     if not (null files) then do       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -268,7 +277,7 @@       | 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 ]) @@ -288,30 +297,52 @@      sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') +    installedMap :: Map Module InstalledInterface+    installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ]++    -- 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 { moduleUnitId = unwireUnitId dflags (moduleUnitId m) }++  reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do+    let warn = hPutStrLn stderr . ("Warning: " ++)+    case readP_to_S parseModuleId 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   themes   <- getThemes libDir flags >>= either bye return +  let withQuickjump = Flag_QuickJumpIndex `elem` 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+    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+    copyHtmlBits odir libDir themes withQuickjump    when (Flag_Html `elem` flags) $ do-    ppHtml dflags' title pkgStr visibleIfaces odir+    ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir                 prologue                 themes opt_mathjax sourceUrls' opt_wiki_urls                 opt_contents_url opt_index_url unicode qual-                pretty-    copyHtmlBits odir libDir themes+                pretty withQuickjump+    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@@ -397,23 +428,50 @@     ghcMode   = CompManager,     ghcLink   = NoLink     }-  let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs-+  -- We disable pattern match warnings because than can be very+  -- expensive to check+  let dynflags'' = unsetPatternMatchWarnings $+        updOptLevel 0 $+        gopt_unset dynflags' Opt_SplitObjs   -- 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++    -- 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 => DynFlags -> m DynFlags     parseGhcFlags dynflags = do       -- TODO: handle warnings? -      (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags)+      let flags' = filterRtsFlags flags+      (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')       if not (null rest)-        then throwE ("Couldn't parse GHC options: " ++ unwords flags)+        then throwE ("Couldn't parse GHC options: " ++ unwords flags')         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 -------------------------------------------------------------------------------@@ -438,9 +496,9 @@             exists <- doesDirectoryExist p             pure $ if exists then Just p else Nothing -      dirs <- mapM check res_dirs  +      dirs <- mapM check res_dirs       case [p | Just p <- dirs] of-        (p : _) -> return p +        (p : _) -> return p         _       -> die "Haddock's resource directory does not exist!\n" #endif     fs -> return (last fs)
src/Haddock/Backends/Hoogle.hs view
@@ -18,6 +18,7 @@  import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..))+import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out)@@ -86,7 +87,7 @@         f (HsDocTy a _) = f $ unL a         f x = x -outHsType :: (OutputableBndrId a)+outHsType :: (SourceTextX a, OutputableBndrId a)           => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -117,7 +118,7 @@ --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem Name -> [String]+ppExport :: DynFlags -> ExportItem GhcRn -> [String] ppExport dflags ExportDecl { expItemDecl    = L _ decl                            , expItemMbDoc   = (dc, _)                            , expItemSubDocs = subdocs@@ -135,29 +136,29 @@         ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] -ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String]+ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(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)]+                     ++ [pp_sig dflags [n] (hsSigWcType sig)]          getDoc :: Located Name -> [Documentation Name]         getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)  ppSigWithDoc _ _ _ = [] -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 -> [Located Name] -> LHsType GhcRn -> String pp_sig dflags names (L _ typ)  =     operator prettyNames ++ " :: " ++ outHsType 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 :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs =   (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds}     ++ ppTyFams) :  ppMethods@@ -177,17 +178,17 @@          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 :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn         tyFamEqnToSyn tfe = SynDecl-            { tcdLName = tfe_tycon tfe-            , tcdTyVars = tfe_pats tfe-            , tcdFixity = tfe_fixity tfe-            , tcdRhs = tfe_rhs tfe-            , tcdFVs = emptyNameSet+            { tcdLName  = feqn_tycon tfe+            , tcdTyVars = feqn_pats tfe+            , tcdFixity = feqn_fixity tfe+            , tcdRhs    = feqn_rhs tfe+            , tcdFVs    = emptyNameSet             }  @@ -203,10 +204,10 @@     cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText                                     , isSafeOverlap = False } } -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 :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs     = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :       concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)@@ -227,7 +228,7 @@   Just (d, _) -> ppDocumentation dflags d   _ -> [] -ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]+ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {}   -- AZ:TODO get rid of the concatMap    = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con)@@ -261,7 +262,7 @@   ppFixity :: DynFlags -> (Name, Fixity) -> [String]-ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)]+ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)]   ---------------------------------------------------------------------@@ -327,7 +328,8 @@   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/Ast.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}@@ -11,11 +12,16 @@ import Haddock.Backends.Hyperlinker.Types  import qualified GHC+import qualified SrcLoc  import Control.Applicative+import Control.Monad (guard) import Data.Data+import qualified Data.Map.Strict as Map import Data.Maybe +import Prelude hiding (span)+ everythingInRenamedSource :: (Alternative f, Data x)   => (forall a. Data a => a -> f r) -> x -> f r everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f@@ -28,25 +34,39 @@         , rtkDetails = enrichToken token detailsMap         }   where-    detailsMap = concatMap ($ src)-        [ variables-        , types-        , decls-        , binds-        , imports-        ]+    detailsMap =+      mkDetailsMap (concatMap ($ src)+                     [ variables+                     , types+                     , decls+                     , binds+                     , imports+                     ]) +type LTokenDetails = [(GHC.SrcSpan, TokenDetails)]+ -- | A map containing association between source locations and "details" of -- this location. ----- 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)]+type DetailsMap = Map.Map Position (Span, TokenDetails) +mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap+mkDetailsMap xs =+  Map.fromListWith select_details [ (start, (span, token_details))+                                  | (ghc_span, token_details) <- xs+                                  , GHC.RealSrcSpan span <- [ghc_span]+                                  , let start = SrcLoc.realSrcSpanStart span+                                  ]+  where+    -- favour token details which appear earlier in the list+    select_details _new old = old+ lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)+lookupBySpan span details = do+  let pos = SrcLoc.realSrcSpanStart span+  (_, (tok_span, tok_details)) <- Map.lookupLE pos details+  guard (tok_span `SrcLoc.containsSpan` span)+  return tok_details  enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm@@ -54,28 +74,31 @@ enrichToken _ _ = Nothing  -- | Obtain details map for variables ("normally" used identifiers).-variables :: GHC.RenamedSource -> DetailsMap+variables :: GHC.RenamedSource -> LTokenDetails variables =     everythingInRenamedSource (var `Syb.combine` rec)   where     var term = case cast term of-        (Just (GHC.L sspan (GHC.HsVar name))) ->+        (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) ->             pure (sspan, RtkVar (GHC.unLoc name))         (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->             pure (sspan, RtkVar name)         _ -> empty     rec term = case cast term of-        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->+        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) ->             pure (sspan, RtkVar name)         _ -> empty  -- | Obtain details map for types.-types :: GHC.RenamedSource -> DetailsMap+types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty   where+    ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]     ty term = case cast term of-        (Just (GHC.L sspan (GHC.HsTyVar _ name))) ->+        (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) ->             pure (sspan, RtkType (GHC.unLoc name))+        (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) ->+            (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)         _ -> empty  -- | Obtain details map for identifier bindings.@@ -84,16 +107,21 @@ -- ordinary assignment (in top-level declarations, let-expressions and where -- clauses). -binds :: GHC.RenamedSource -> DetailsMap+binds :: GHC.RenamedSource -> LTokenDetails binds = everythingInRenamedSource       (fun `Syb.combine` pat `Syb.combine` tvar)   where     fun term = case cast term of-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) ->             pure (sspan, RtkBind name)+        (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) ->+            pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args         _ -> empty+    patsyn_binds term = case cast term of+        (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)+        _ -> empty     pat term = case cast term of-        (Just (GHC.L sspan (GHC.VarPat name))) ->+        (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) ->             pure (sspan, RtkBind (GHC.unLoc name))         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->             [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs@@ -101,21 +129,22 @@             pure (sspan, RtkBind name)         _ -> empty     rec term = case cast term of-        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->+        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) ->             pure (sspan, RtkVar name)         _ -> empty     tvar term = case cast term of-        (Just (GHC.L sspan (GHC.UserTyVar name))) ->+        (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->             pure (sspan, RtkBind (GHC.unLoc name))         (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->             pure (sspan, RtkBind name)         _ -> empty  -- | Obtain details map for top-level declarations.-decls :: GHC.RenamedSource -> DetailsMap+decls :: GHC.RenamedSource -> LTokenDetails decls (group, _, _, _) = concatMap ($ group)     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds     , everythingInRenamedSource fun . GHC.hs_valds+    , everythingInRenamedSource fix . GHC.hs_fixds     , everythingInRenamedSource (con `Syb.combine` ins)     ]   where@@ -123,26 +152,40 @@         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+        GHC.ClassDecl{..} ->+          [decl tcdLName]+            ++ concatMap sig tcdSigs+            ++ concatMap tyfam tcdATs     fun term = case cast term of-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn))             | GHC.isExternalName name -> pure (sspan, RtkDecl name)+        (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _)))+            | GHC.isExternalName name -> pure (sspan, RtkDecl name)         _ -> empty     con term = case cast term of-        (Just cdcl) ->+        (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) ->             map decl (GHC.getConNames cdcl)               ++ everythingInRenamedSource fld cdcl         Nothing -> empty     ins term = case cast term of-        (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst-        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->-            pure . tyref $ GHC.tfe_tycon eqn+        (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn))+                :: GHC.InstDecl GHC.GhcRn))+          -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn+        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) ->+            pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn         _ -> empty     fld term = case cast term of-        Just (field :: GHC.ConDeclField GHC.Name)+        Just (field :: GHC.ConDeclField GHC.GhcRn)           -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field         Nothing -> empty+    fix term = case cast term of+        Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn)+          -> map decl names+        Nothing -> empty+    tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]     sig (GHC.L _ (GHC.TypeSig names _)) = map decl names+    sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names+    sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names     sig _ = []     decl (GHC.L sspan name) = (sspan, RtkDecl name)     tyref (GHC.L sspan name) = (sspan, RtkType name)@@ -151,39 +194,21 @@ -- -- This map also includes type and variable details for items in export and -- import lists.-imports :: GHC.RenamedSource -> DetailsMap+imports :: GHC.RenamedSource -> LTokenDetails imports src@(_, imps, _, _) =     everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps   where     ie term = case cast term of-        (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v+        (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v         (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t         (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t         (Just (GHC.IEThingWith t _ vs _fls)) ->           [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs+        (Just (GHC.IEModuleContents m)) -> pure $ modu m         _ -> empty     typ (GHC.L sspan name) = (sspan, RtkType name)     var (GHC.L sspan name) = (sspan, RtkVar name)-    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+    modu (GHC.L sspan name) = (sspan, RtkModule name)+    imp idecl+      | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))+      | otherwise = Nothing
src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -1,11 +1,17 @@ module Haddock.Backends.Hyperlinker.Parser (parse) where +import Data.Either         ( isRight, isLeft )+import Data.List           ( foldl', isPrefixOf, isSuffixOf )+import Data.Maybe          ( maybeToList ) -import Data.Char-import Data.List-import Data.Maybe+import GHC                 ( DynFlags, addSourceToTokens )+import SrcLoc+import FastString          ( mkFastString )+import StringBuffer        ( stringToStringBuffer )+import Lexer               ( Token(..) )+import qualified Lexer as L -import Haddock.Backends.Hyperlinker.Types+import Haddock.Backends.Hyperlinker.Types as T   -- | Turn source code string into a stream of more descriptive tokens.@@ -13,202 +19,404 @@ -- 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+-- prop> concat . map tkValue . parse = id+--+-- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v',+-- characters, since GHC transforms those into ' ' and '\n')+parse :: DynFlags -> FilePath -> String -> [T.Token]+parse dflags fp s = ghcToks (processCPP dflags fp s) --- | Split raw source string to more meaningful chunks.++-- | Parse the source into tokens using the GHC lexer. ----- 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]+--   * CPP lines are removed and reinserted as line-comments+--   * top-level file pragmas are parsed as block comments (see the+--     'ITblockComment' case of 'classify' for more details)+--+processCPP :: DynFlags    -- ^ GHC's flags+           -> FilePath    -- ^ source file name (for position information)+           -> String      -- ^ source file contents+           -> [(Located L.Token, String)]+processCPP dflags fpath s = addSrc . go start . splitCPP $ s   where-    chunk' (c, rest) = c:(chunk rest)+    start = mkRealSrcLoc (mkFastString fpath) 1 1+    addSrc = addSourceToTokens start (stringToStringBuffer s) --- | 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+    -- Transform a list of Haskell/CPP lines into a list of tokens+    go :: RealSrcLoc -> [Either String String] -> [Located L.Token]+    go _   [] = []+    go pos ls =+      let (hLinesRight,  ls')  = span isRight ls+          (cppLinesLeft, rest) = span isLeft ls' --- | Split input to "first line" string and the rest of it.+          hSrc   = concat [ hLine   | Right hLine  <- hLinesRight  ]+          cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ]++      in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of++           -- Stuff that fails to lex gets turned into comments+           L.PFailed _ _ss _msg ->+             let (src_pos, failed) = mkToken ITunknown pos hSrc+                 (new_pos, cpp)    = mkToken ITlineComment src_pos cppSrc+             in failed : cpp : go new_pos rest++           -- Successfully lexed+           L.POk ss toks ->+             let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc+             in toks ++ [cpp] ++ go new_pos rest++    -- Manually make a token from a 'String', advancing the cursor position+    mkToken tok start' str =+      let end = foldl' advanceSrcLoc start' str+      in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str))+++-- | Split apart the initial file into Haskell source lines ('Left' entries) and+-- CPP lines ('Right' entries). ----- 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)+-- All characters in the input are present in the output:+--+-- prop> concat . map (either id id) . splitCPP = id+splitCPP :: String -> [Either String String]+splitCPP "" = []+splitCPP s | isCPPline s = Left l : splitCPP rest+           | otherwise =  Right l : splitCPP rest+  where+    ~(l, rest) = spanToNewline 0 s --- | Split input to whitespace string, (optional) preprocessor directive and--- the rest of it.++-- | Heuristic to decide if a line is going to be a CPP line. This should be a+-- cheap operation since it is going to be run on every line being processed. ----- 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)+-- Right now it just checks if the first non-whitespace character in the first+-- five characters of the line is a '#':+--+-- >>> isCPPline "#define FOO 1"+-- True+--+-- >>> isCPPline "\t\t  #ifdef GHC"+-- True+--+-- >>> isCPPline "       #endif"+-- False+--+isCPPline :: String -> Bool+isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5 --- | Split input to comment content (including delimiters) and the rest.++-- | Split a "line" off the front of a string, supporting newline escapes. ----- 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)+-- By "line", we understand: the shortest substring ending in a '\n' that is not+--+--   1. immediately preceded by a '\\'+--   2. not inside some (possibly nested) block comment+--+-- All characters in the input are present in the output:+--+-- prop> curry (++) . spanToNewLine 0 = id+spanToNewline :: Int                 -- ^ open '{-'+              -> String              -- ^ input+              -> (String, String)+spanToNewline _ [] = ([], [])+spanToNewline n ('\n':str) | n <= 0 = ("\n", str)+spanToNewline n ('\\':'\n':str) =+    let (str', rest) = spanToNewline n str+    in ('\\':'\n':str', rest)+spanToNewline n ('{':'-':str) =+    let (str', rest) = spanToNewline (n+1) str+    in ('{':'-':str', rest)+spanToNewline n ('-':'}':str) =+    let (str', rest) = spanToNewline (n-1) str+    in ('-':'}':str', rest)+spanToNewline n (c:str) =+    let (str', rest) = spanToNewline n str+    in (c:str', rest) --- | 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 } --- | Turn unrecognised chunk stream to more descriptive token stream.-tokenize :: [(Span, String)] -> [Token]-tokenize =-    map aux+-- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of+-- Haddock's 'T.Token'.+ghcToks :: [(Located L.Token, String)] -> [T.Token]+ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False)   where-    aux (sp, str) = Token-        { tkType = classify str-        , tkValue = str-        , tkSpan = sp-        }+    start = mkRealSrcLoc (mkFastString "lexing") 1 1 --- | 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+    go :: (RealSrcLoc, [T.Token], Bool)+       -- ^ current position, tokens accumulated, currently in pragma (or not)+       +       -> (Located L.Token, String)+       -- ^ next token, its content+       +       -> (RealSrcLoc, [T.Token], Bool)+       -- ^ new position, new tokens accumulated, currently in pragma (or not) -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"-    ]+    go (pos, toks, in_prag) (L l tok, raw) =+        ( next_pos+        , classifiedTok ++ maybeToList white ++ toks+        , inPragma in_prag tok+        )+       where+         (next_pos, white) = mkWhitespace pos l+         +         classifiedTok = [ Token (classify' tok) raw rss+                         | RealSrcSpan rss <- [l]+                         , not (null raw)+                         ]+         +         classify' | in_prag = const TkPragma+                   | otherwise = classify -glyphs :: [String]-glyphs =-    [ ".."-    , ":"-    , "::"-    , "="-    , "\\"-    , "|"-    , "<-"-    , "->"-    , "@"-    , "~"-    , "~#"-    , "=>"-    , "-"-    , "!"-    ] -special :: [Char]-special = "()[]{},;`"+-- | Find the correct amount of whitespace between tokens.+mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token)+mkWhitespace prev spn =+  case spn of+    UnhelpfulSpan _ -> (prev,Nothing)+    RealSrcSpan s | null wsstring -> (end, Nothing)+                  | otherwise -> (end, Just (Token TkSpace wsstring wsspan))+      where+        start = realSrcSpanStart s+        end = realSrcSpanEnd s+        wsspan = mkRealSrcSpan prev start+        nls = srcLocLine start - srcLocLine prev+        spaces = if nls == 0 then srcLocCol start - srcLocCol prev+                             else srcLocCol start - 1+        wsstring = replicate nls '\n' ++ replicate spaces ' ' --- 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 = "!#$%&*+./<=>?@\\^|-~:" -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+-- | Classify given tokens as appropriate Haskell token type.+classify :: L.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+    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+    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+    ITgenerated_prag    {} -> TkPragma+    ITcore_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+    ITvect_prag         {} -> TkPragma+    ITvect_scalar_prag  {} -> TkPragma+    ITnovect_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+    ITvbar                 -> TkGlyph+    ITlarrow            {} -> TkGlyph+    ITrarrow            {} -> TkGlyph+    ITat                   -> TkGlyph+    ITtilde                -> TkGlyph+    ITtildehsh             -> TkGlyph+    ITdarrow            {} -> TkGlyph+    ITminus                -> TkGlyph+    ITbang                 -> TkGlyph+    ITdot                  -> TkOperator+    ITtypeApp              -> 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+    ITidEscape          {} -> TkUnknown+    ITparenEscape          -> TkSpecial+    ITidTyEscape        {} -> TkUnknown+    ITparenTyEscape        -> TkSpecial+    ITtyQuote              -> TkSpecial+    ITquasiQuote        {} -> TkUnknown+    ITqQuasiQuote       {} -> TkUnknown++    ITproc                 -> TkKeyword+    ITrec                  -> TkKeyword+    IToparenbar         {} -> TkGlyph+    ITcparenbar         {} -> TkGlyph+    ITlarrowtail        {} -> TkGlyph+    ITrarrowtail        {} -> TkGlyph+    ITLarrowtail        {} -> TkGlyph+    ITRarrowtail        {} -> TkGlyph++    ITunknown           {} -> TkUnknown+    ITeof                  -> TkUnknown++    -- Line comments are only supposed to start with '--'. Starting with '#'+    -- means that this was probably a CPP.+    ITlineComment s+      | isCPPline s        -> TkCpp+      | otherwise          -> TkComment++    ITdocCommentNext    {} -> TkComment+    ITdocCommentPrev    {} -> TkComment+    ITdocCommentNamed   {} -> TkComment+    ITdocSection        {} -> 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+         -> L.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+    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+    ITgenerated_prag    {} -> True+    ITcore_prag         {} -> True+    ITunpack_prag       {} -> True+    ITnounpack_prag     {} -> True+    ITann_prag          {} -> True+    ITcomplete_prag     {} -> True+    IToptions_prag      {} -> True+    ITinclude_prag      {} -> True+    ITlanguage_prag        -> True+    ITvect_prag         {} -> True+    ITvect_scalar_prag  {} -> True+    ITnovect_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
@@ -15,7 +15,6 @@  import Data.List import Data.Maybe-import Data.Monoid import qualified Data.Map as Map  import Text.XHtml (Html, HtmlAttr, (!))@@ -82,7 +81,7 @@  tokenGroup :: SrcMap -> TokenGroup -> Html tokenGroup _ (GrpNormal tok@(Token { .. }))-    | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue+    | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue     | otherwise = tokenSpan tok ! attrs   where     attrs = [ multiclass . tokenStyle $ tkType ]@@ -155,7 +154,7 @@     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]  externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html-externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of+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 !@@ -165,12 +164,14 @@     mdl = GHC.nameModule name  externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html-externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of-    Just SrcLocal -> Html.anchor content !+externalModHyperlink srcs name content =+    let srcs' = Map.mapKeys GHC.moduleName srcs in+    case Map.lookup name srcs' of+      Just SrcLocal -> Html.anchor content !         [ Html.href $ hypSrcModuleUrl' name ]-    Just (SrcExternal path) -> Html.anchor content !+      Just (SrcExternal path) -> Html.anchor content !         [ Html.href $ path </> hypSrcModuleUrl' name ]-    Nothing -> content+      Nothing -> content   renderSpace :: Int -> String -> Html
src/Haddock/Backends/Hyperlinker/Types.hs view
@@ -4,27 +4,16 @@ import qualified GHC  import Data.Map (Map)-import qualified Data.Map as Map - data Token = Token     { tkType :: TokenType     , tkValue :: String-    , tkSpan :: Span-    }-    deriving (Show)--data Position = Position-    { posRow :: !Int-    , posCol :: !Int+    , tkSpan :: {-# UNPACK #-} !Span     }     deriving (Show) -data Span = Span-    { spStart :: Position-    , spEnd :: Position-    }-    deriving (Show)+type Position = GHC.RealSrcLoc+type Span = GHC.RealSrcSpan  data TokenType     = TkIdentifier@@ -74,15 +63,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 SrcMap = Map GHC.Module SrcPath -mkSrcMap :: Map GHC.Module SrcPath -> SrcMap-mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
src/Haddock/Backends/LaTeX.hs view
@@ -16,6 +16,7 @@ ) where  +import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils@@ -36,6 +37,7 @@ import Control.Monad import Data.Maybe import Data.List+import Prelude hiding ((<>))  import Haddock.Doc (combineDocumentation) @@ -178,7 +180,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2  -exportListItem :: ExportItem DocName -> LaTeX+exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }   = sep (punctuate comma . map ppDocBinder $ declNames decl) <>      case subdocs of@@ -196,7 +198,7 @@  -- Deal with a group of undocumented exports together, to avoid lots -- of blank vertical space between them.-processExports :: [ExportItem DocName] -> LaTeX+processExports :: [ExportItem DocNameI] -> LaTeX processExports [] = empty processExports (decl : es)   | Just sig <- isSimpleSig decl@@ -212,19 +214,19 @@   processExport e $$ processExports es  -isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)+isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) 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 :: ExportItem DocNameI -> Maybe Module isExportModule (ExportModule m) = Just m isExportModule _ = Nothing  -processExport :: ExportItem DocName -> LaTeX+processExport :: ExportItem DocNameI -> LaTeX processExport (ExportGroup lev _id0 doc)   = ppDocGroup lev (docToLaTeX doc) processExport (ExportDecl decl pats doc subdocs insts fixities _splice)@@ -247,7 +249,7 @@         sec _ = text "\\paragraph"  -declNames :: LHsDecl DocName -> [DocName]+declNames :: LHsDecl DocNameI -> [DocName] declNames (L _ decl) = case decl of   TyClD d  -> [tcdName d]   SigD (TypeSig lnames _ ) -> map unLoc lnames@@ -257,7 +259,7 @@   _ -> error "declaration not supported by declNames"  -forSummary :: (ExportItem DocName) -> Bool+forSummary :: (ExportItem DocNameI) -> Bool forSummary (ExportGroup _ _ _) = False forSummary (ExportDoc _)       = False forSummary _                    = True@@ -277,10 +279,10 @@ -------------------------------------------------------------------------------  -ppDecl :: LHsDecl DocName-       -> [(HsDecl DocName,DocForDecl DocName)]+ppDecl :: LHsDecl DocNameI+       -> [(HsDecl DocNameI, DocForDecl DocName)]        -> DocForDecl DocName-       -> [DocInstance DocName]+       -> [DocInstance DocNameI]        -> [(DocName, DocForDecl DocName)]        -> [(DocName, Fixity)]        -> LaTeX@@ -308,12 +310,12 @@   ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->-              TyClDecl DocName -> Bool -> LaTeX+              TyClDecl DocNameI -> Bool -> LaTeX ppTyFam _ _ _ _ _ =   error "type family declarations are currently not supported by --latex"  -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX+ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> 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"@@ -326,7 +328,7 @@   -- we skip type patterns for now-ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX+ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX  ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars                          , tcdRhs = ltype }) unicode@@ -345,7 +347,7 @@ -------------------------------------------------------------------------------  -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI          -> Bool -> LaTeX ppFunSig loc doc docnames (L _ typ) unicode =   ppTypeOrFunSig loc docnames typ doc@@ -357,7 +359,7 @@    names = map getName docnames  ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName]-          -> LHsSigType DocName+          -> LHsSigType DocNameI           -> Bool -> LaTeX ppLPatSig _loc (doc, _argDocs) docnames ty unicode   = declWithDoc pref1 (documentationToLaTeX doc)@@ -368,7 +370,7 @@                  , ppLType unicode (hsSigType ty)                  ] -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName+ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI                -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)                -> Bool -> LaTeX ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)@@ -386,7 +388,7 @@       arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs -     do_args :: Int -> LaTeX -> HsType DocName -> LaTeX+     do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX      do_args _n leader (HsForAllTy tvs ltype)        = decltt leader          <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]))@@ -402,18 +404,18 @@        = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl  -ppTypeSig :: [Name] -> HsType DocName  -> Bool -> LaTeX+ppTypeSig :: [Name] -> HsType DocNameI  -> Bool -> LaTeX ppTypeSig nms ty unicode =   hsep (punctuate comma $ map ppSymName nms)     <+> dcolon unicode     <+> ppType unicode ty  -ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]+ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarName)  -tyvarNames :: LHsQTyVars DocName -> [Name]+tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit  @@ -462,8 +464,8 @@ -------------------------------------------------------------------------------  -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName-           -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]+ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName+           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]            -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode =   keyword "class"@@ -481,9 +483,9 @@                            hsep (map (ppDocName . unLoc) vars2)  -ppClassDecl :: [DocInstance DocName] -> SrcSpan+ppClassDecl :: [DocInstance DocNameI] -> SrcSpan             -> Documentation DocName -> [(DocName, DocForDecl DocName)]-            -> TyClDecl DocName -> Bool -> LaTeX+            -> TyClDecl DocNameI -> Bool -> LaTeX ppClassDecl instances loc doc subdocs   (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds              , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode@@ -506,19 +508,17 @@      methodTable =       text "\\haddockpremethods{}\\textbf{Methods}" $$-      vcat  [ ppFunSig loc doc names (hsSigWcType typ) unicode+      vcat  [ ppFunSig loc doc [name] (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?+            , name <- map unLoc lnames+            , let doc = lookupAnySubdoc name subdocs+            ]      instancesBit = ppDocInstances unicode instances  ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX+ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty ppDocInstances unicode (i : rest)   | Just ihead <- isUndocdInstance i@@ -536,22 +536,22 @@ -- | 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 :: Bool -> DocInstance DocNameI -> LaTeX ppDocInstance unicode (instHead, doc, _) =   declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc)  -ppInstDecl :: Bool -> InstHead DocName -> LaTeX+ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead  -ppInstHead :: Bool -> InstHead DocName -> LaTeX+ppInstHead :: Bool -> InstHead DocNameI -> 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+    typ = ppAppNameTypes ihdClsName ihdTypes unicode     tibody = maybe empty (\t -> equals <+> ppType unicode t)  lookupAnySubdoc :: (Eq name1) =>@@ -566,9 +566,9 @@ -------------------------------------------------------------------------------  -ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] ->+ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] ->               [(DocName, DocForDecl DocName)] -> SrcSpan ->-              Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->+              Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool ->               LaTeX ppDataDecl pats instances subdocs _loc doc dataDecl unicode @@ -614,7 +614,7 @@   -- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX+ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode  = (if null tvs then empty else ppForall)    <+>@@ -626,7 +626,7 @@   ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX-                   -> LConDecl DocName -> LaTeX+                   -> LConDecl DocNameI -> LaTeX ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) =   leader <->   case con_details con of@@ -755,7 +755,7 @@     mkFunTy a b = noLoc (HsFunTy a b) -} -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName ->  LaTeX+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI ->  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@@ -813,7 +813,7 @@  -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures-ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX+ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars                        , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode   = -- newtype or data@@ -829,27 +829,27 @@ --------------------------------------------------------------------------------  --- | 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 to its list of HsTypes+ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX+ppAppNameTypes n ts unicode = ppTypeApp n 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+  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+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 ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)+ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)   -------------------------------------------------------------------------------@@ -857,29 +857,29 @@ -------------------------------------------------------------------------------  -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX+ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX ppLContext        = ppContext        . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX+ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode -ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX+ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX ppContextNoArrow cxt unicode = fromMaybe empty $                                ppContextNoLocsMaybe (map unLoc cxt) unicode  -ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX+ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $                               ppContextNoLocsMaybe cxt unicode  -ppContext :: HsContext DocName -> Bool -> LaTeX+ppContext :: HsContext DocNameI -> Bool -> LaTeX ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode  -pp_hs_context :: [HsType DocName] -> Bool -> LaTeX+pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context []  _       = empty pp_hs_context [p] unicode = ppType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)@@ -929,32 +929,32 @@                                | otherwise            = p  -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX+ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> 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, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> 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 :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) -ppKind :: Bool -> HsKind DocName -> LaTeX+ppKind :: Bool -> HsKind DocNameI -> 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 :: Int -> LHsType DocNameI -> 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 :: Int -> HsType DocNameI -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode   = maybeParen ctxt_prec pREC_FUN $     sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot@@ -1017,7 +1017,7 @@   -- XXX: Do something with Unicode parameter?  -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX+ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> 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@@ -1138,7 +1138,8 @@   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)+  markupHeader               = \(Header l h) p -> header l (h p),+  markupTable                = \(Table h b) p -> table h b p   }   where     header 1 d = text "\\section*" <> braces d@@ -1146,6 +1147,8 @@     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
src/Haddock/Backends/Xhtml.hs view
@@ -11,7 +11,7 @@ -- Stability   :  experimental -- Portability :  portable ------------------------------------------------------------------------------{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml (   ppHtml, copyHtmlBits,   ppHtmlIndex, ppHtmlContents,@@ -31,15 +31,18 @@ import Haddock.Types import Haddock.Version import Haddock.Utils+import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote ) import Haddock.GhcUtils  import Control.Monad         ( when, unless )+import qualified Data.ByteString.Builder as Builder import Data.Char             ( toUpper, isSpace )-import Data.List             ( sortBy, intercalate, isPrefixOf, intersperse )+import Data.List             ( sortBy, isPrefixOf, intercalate, intersperse ) import Data.Maybe-import System.FilePath hiding ( (</>) ) import System.Directory+import System.FilePath hiding ( (</>) )+import qualified System.IO as IO import Data.Map              ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set )@@ -48,17 +51,16 @@ import DynFlags (Language(..)) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import Name-import Module  -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- - ppHtml :: DynFlags        -> String                       -- ^ Title        -> Maybe String                 -- ^ Package        -> [Interface]+       -> [InstalledInterface]         -- ^ Reexported interfaces        -> FilePath                     -- ^ Destination directory        -> Maybe (MDoc GHC.RdrName)     -- ^ Prologue text, maybe        -> Themes                       -- ^ Themes@@ -70,12 +72,13 @@        -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)        -> 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 dflags 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+        qual debug withQuickjump =  do   let     visible_ifaces = filter visible ifaces     visible i = OptHide `notElem` ifaceOptions i@@ -83,28 +86,34 @@   when (isNothing maybe_contents_url) $     ppHtmlContents dflags odir doctitle maybe_package         themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url-        (map toInstalledIface visible_ifaces)+        (map toInstalledIface visible_ifaces ++ reexported_ifaces)         False -- we don't want to display the packages in a single-package contents         prologue debug (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+      (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug +    when withQuickjump $+      ppJsonIndex odir maybe_source_url maybe_wiki_url unicode 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  -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 ()  @@ -114,13 +123,9 @@     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.-      << primHtml-          "//<![CDATA[\nwindow.onload = function () {pageLoad();};\n//]]>\n"+    thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml,+    script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml,+    script ! [src mjUrl, thetype "text/javascript"] << noHtml     ]   where     mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url@@ -187,7 +192,6 @@       )     ] - moduleInfo :: Interface -> Html moduleInfo iface =    let@@ -306,33 +310,35 @@   mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html-mkNode qual ss p (Node s leaf pkg srcPkg short ts) =+mkNode 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       (_,   _   ) -> 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     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 qual (s:ss) p ts+      )   @@ -340,7 +346,60 @@ -- * Generate the index -------------------------------------------------------------------------------- +ppJsonIndex :: FilePath+           -> SourceURLs                   -- ^ The source URL (--source)+           -> WikiURLs                     -- ^ The wiki URL (--wiki)+           -> Bool+           -> QualOption+           -> [Interface]+           -> IO ()+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do+  createDirectoryIfMissing True odir+  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do+    Builder.hPutBuilder h (encodeToBuilder modules)+  where+    modules :: Value+    modules = Array (concatMap goInterface ifaces) +    goInterface :: Interface -> [Value]+    goInterface iface =+        concatMap (goExport mdl qual) (ifaceRnExportItems iface)+      where+        aliases = ifaceModuleAliases iface+        qual    = makeModuleQual qual_opt aliases mdl+        mdl     = ifaceMod iface++    goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]+    goExport mdl qual item+      | Just item_html <- processExport True links_info unicode qual item+      = [ Object+            [ "display_html" .= String (showHtmlFragment item_html)+            , "name"         .= String (intercalate " " (map nameString names))+            , "module"       .= String (moduleString mdl)+            , "link"         .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))+            ]+        ]+      | otherwise = []+      where+        names = exportName item ++ exportSubs item++    exportSubs :: ExportItem name -> [IdP name]+    exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs+    exportSubs _ = []++    exportName :: ExportItem name -> [IdP name]+    exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)+    exportName ExportNoDecl { expItemName } = [expItemName]+    exportName _ = []++    nameString :: NamedThing name => name -> String+    nameString = occNameString . nameOccName . getName++    nameLink :: NamedThing name => Module -> name -> String+    nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName++    links_info = (maybe_source_url, maybe_wiki_url)+ ppHtmlIndex :: FilePath             -> String             -> Maybe String@@ -505,6 +564,7 @@ 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) +++@@ -532,10 +592,12 @@       | 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 qual) exports+              ) ! collapseToggle "syn" ""+            )          -- if the documentation doesn't begin with a section header, then         -- add one ("Documentation").@@ -556,7 +618,7 @@   ppModuleContents :: Qualification-                 -> [ExportItem DocName]+                 -> [ExportItem DocNameI]                  -> Bool -- ^ Orphans sections                  -> Html ppModuleContents qual exports orphan@@ -572,7 +634,7 @@     | 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 )@@ -589,9 +651,9 @@  -- 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@@ -600,7 +662,7 @@   processExport :: Bool -> LinksInfo -> Bool -> Qualification-              -> ExportItem DocName -> Maybe Html+              -> ExportItem DocNameI -> 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)@@ -636,7 +698,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
@@ -40,9 +40,9 @@ import BooleanFormula import RdrName ( rdrNameOcc ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocName-       -> [(HsDecl DocName, DocForDecl DocName)]-       -> DocForDecl DocName ->  [DocInstance DocName] -> [(DocName, Fixity)]+ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI+       -> [(HsDecl DocNameI, DocForDecl DocName)]+       -> DocForDecl DocName ->  [DocInstance DocNameI] -> [(DocName, Fixity)]        -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of   TyClD (FamDecl d)            -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual@@ -60,23 +60,23 @@   ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-             [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->+             [Located DocName] -> LHsType DocNameI -> [(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)] ->+            [DocName] -> LHsType DocNameI -> [(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+            splice unicode qual HideEmptyContexts   where-    pp_typ = ppLType unicode qual typ+    pp_typ = ppLType unicode qual HideEmptyContexts typ  ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-             [Located DocName] -> LHsSigType DocName ->+             [Located DocName] -> LHsSigType DocNameI ->              [(DocName, Fixity)] ->              Splice -> Unicode -> Qualification -> Html ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual@@ -87,20 +87,20 @@     pref1 = hsep [ keyword "pattern"                  , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames                  , dcolon unicode-                 , ppLType unicode qual (hsSigType typ)+                 , ppPatSigType unicode qual (hsSigType typ)                  ]  ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->-             [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->-             Splice -> Unicode -> Qualification -> Html+             [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->+             Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)-          splice unicode qual =+          splice unicode qual emptyCtxts =   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+    splice unicode qual emptyCtxts   where     occnames = map (nameOccName . getName) docnames     addFixities html@@ -108,10 +108,10 @@       | otherwise = html <+> ppFixities fixities qual  -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI                -> DocForDecl DocName -> (Html, Html, Html)-               -> Splice -> Unicode -> Qualification -> Html-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual+               -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts   | summary = pref1   | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc   | otherwise = topDeclElem links loc splice docnames pref2 +++@@ -122,7 +122,7 @@      do_largs n leader (L _ t) = do_args n leader t -    do_args :: Int -> Html -> HsType DocName -> [SubDecl]+    do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]     do_args n leader (HsForAllTy tvs ltype)       = do_largs n leader' ltype       where@@ -132,16 +132,16 @@       | null (unLoc lctxt)       = do_largs n leader ltype       | otherwise-      = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])+      = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])         : do_largs n (darrow unicode) ltype      do_args n leader (HsFunTy lt r)-      = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])+      = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, [])         : do_largs (n+1) (arrow unicode) r     do_args n leader t-      = [(leader <+> ppType unicode qual t, argDoc n, [])]+      = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] -ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html+ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual =   case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of     [] -> noHtml@@ -172,15 +172,15 @@   -- | Pretty-print type variables.-ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html]+ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs -tyvarNames :: LHsQTyVars DocName -> [Name]+tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit   ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName-      -> ForeignDecl DocName -> [(DocName, Fixity)]+      -> ForeignDecl DocNameI -> [(DocName, Fixity)]       -> Splice -> Unicode -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities       splice unicode qual@@ -190,18 +190,18 @@  -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan-        -> DocForDecl DocName -> TyClDecl DocName+        -> DocForDecl DocName -> TyClDecl DocNameI         -> 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+                   splice unicode qual ShowEmptyToplevelContexts   where     hdr  = hsep ([keyword "type", ppBinder summary occ]                  ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))-    full = hdr <+> equals <+> ppLType unicode qual ltype+    full = hdr <+> equals <+> ppPatSigType unicode qual ltype     occ  = nameOccName . getName $ name     fixs       | summary   = noHtml@@ -220,14 +220,14 @@ ppTyName = ppName Prefix  -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan-            -> [DocName] -> HsType DocName+ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan+            -> [DocName] -> HsType DocNameI             -> Html-ppSimpleSig links splice unicode qual loc names typ =+ppSimpleSig links splice unicode qual emptyCtxts loc names typ =     topDeclElem' names $ ppTypeSig True occNames ppTyp unicode   where     topDeclElem' = topDeclElem links loc splice-    ppTyp = ppType unicode qual typ+    ppTyp = ppType unicode qual emptyCtxts typ     occNames = map getOccName names  @@ -236,7 +236,7 @@ --------------------------------------------------------------------------------  -ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html+ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html ppFamilyInfo assoc OpenTypeFamily     | assoc = keyword "type"     | otherwise = keyword "type family"@@ -246,7 +246,7 @@ ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"  -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI               -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info                                                , fdResultSig = L _ result@@ -276,28 +276,28 @@      _                  -> mempty   ) -ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html+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 -ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName+ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI                      -> Html ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =     ppFamilyInfo True pfdInfo <+>-    ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>+    ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+>     ppResultSig (unLoc pfdKindSig) unicode qual -ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html+ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> 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] ->+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] ->            [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->-           FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html+           FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppTyFam summary associated links instances fixities loc doc decl splice unicode qual    | summary   = ppTyFamHeader True associated decl unicode qual@@ -318,16 +318,17 @@       = 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)+    ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl+    ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs+                                          , feqn_pats = ts } })+      = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual+          <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)         , Nothing, [] )    ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification-                   -> PseudoFamilyDecl DocName+                   -> PseudoFamilyDecl DocNameI                    -> Html ppPseudoFamilyDecl links splice unicode qual                    decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) =@@ -341,7 +342,7 @@ --------------------------------------------------------------------------------  -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI             -> [(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@@ -352,12 +353,12 @@ --------------------------------------------------------------------------------  -- | Print a type family and its variables-ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html+ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =   ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs)  -- | Print a newtype / data binder and its variables-ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html+ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html ppDataBinderWithVars summ unicode qual decl =   ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) @@ -365,31 +366,30 @@ -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html+ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs =-    ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc)+    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' 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' 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)   -- | General printing of type applications-ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html-ppTypeApp n [] (t1:t2:rest) ppDN ppT+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 ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)+ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)   -------------------------------------------------------------------------------@@ -397,33 +397,36 @@ -------------------------------------------------------------------------------  -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode-                              -> Qualification -> Html+ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode+                              -> Qualification -> HideEmptyContexts -> 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+ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $+                                               ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts  -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html-ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $-                                   ppContextNoLocsMaybe cxt unicode qual+ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $+                                              ppContextNoLocsMaybe cxt unicode qual emptyCtxts  -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html-ppContextNoLocsMaybe []  _       _    = Nothing-ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual+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 DocName -> Unicode -> Qualification -> Html-ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual+ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts  -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html-ppHsContext []  _       _     = noHtml+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) cxt)+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt)   -------------------------------------------------------------------------------@@ -431,12 +434,12 @@ -------------------------------------------------------------------------------  -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName-           -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])]+ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName+           -> LHsQTyVars DocNameI -> [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)+  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)   <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)   <+> ppFds fds unicode qual @@ -449,7 +452,7 @@         fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2         ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan                  -> [(DocName, DocForDecl DocName)]                  -> Splice -> Unicode -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs@@ -481,9 +484,9 @@   -ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)]             -> SrcSpan -> Documentation DocName-            -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName+            -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI             -> Splice -> Unicode -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs         decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars@@ -513,14 +516,14 @@                             doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs                             subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] -    methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ)+    methodBit = subMethods [ ppFunSig summary links loc doc [name] (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 ]+                           , name <- map unLoc lnames+                           , let doc = lookupAnySubdoc name subdocs+                                 subfixs = [ f | f@(n',_) <- fixities+                                               , name == n' ]+                           ]                            -- N.B. taking just the first name is ok. Signatures with multiple names                            -- are expanded so that each name gets its own signature. @@ -554,7 +557,7 @@   ppInstances :: LinksInfo-            -> InstOrigin DocName -> [DocInstance DocName]+            -> InstOrigin DocName -> [DocInstance DocNameI]             -> Splice -> Unicode -> Qualification             -> Html ppInstances links origin instances splice unicode qual@@ -562,22 +565,22 @@   -- force Splice = True to use line URLs   where     instName = getOccString origin-    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)     instDecl no (inst, mdoc, loc) =         ((ppInstHead links splice unicode qual mdoc origin False no inst), loc)   ppOrphanInstances :: LinksInfo-                  -> [DocInstance DocName]+                  -> [DocInstance DocNameI]                   -> 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 :: InstHead name -> InstOrigin (IdP name)     instOrigin inst = OriginClass (ihdClsName inst) -    instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName)+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName)     instDecl no (inst, mdoc, loc) =         ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) @@ -587,12 +590,12 @@            -> InstOrigin DocName            -> Bool -- ^ Is instance orphan            -> Int  -- ^ Normal-           -> InstHead DocName+           -> InstHead DocNameI            -> SubDecl ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) =     case ihdInstType of         ClassInst { .. } ->-            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ+            ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ             , mdoc             , [subInstDetails iid ats sigs]             )@@ -607,7 +610,7 @@           where             ptype = keyword "type" <+> typ             prhs = ptype <+> maybe noHtml-                                   (\t -> equals <+> ppType unicode qual t) rhs+                                   (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs         DataInst dd ->             ( subInstHead iid pdata             , mdoc@@ -617,11 +620,11 @@             pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual   where     iid = instanceId origin no orphan ihd-    typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual+    typ = ppAppNameTypes ihdClsName ihdTypes unicode qual   ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification-                   -> [PseudoFamilyDecl DocName]+                   -> [PseudoFamilyDecl DocNameI]                    -> [Html] ppInstanceAssocTys links splice unicode qual =     map ppFamilyDecl'@@ -630,22 +633,22 @@   ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification-              -> [Sig DocName]+              -> [Sig DocNameI]               -> [Html] ppInstanceSigs links splice unicode qual sigs = do     TypeSig lnames typ <- sigs     let names = map unLoc lnames         L _ rtyp = hsSigWcType typ-    -- Instance methods signatures are synified and thus don't have a useful +    -- 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 (getLoc $ head $ lnames) names rtyp+    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ 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 DocName -> String+instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String instanceId origin no orphan ihd = concat $     [ "o:" | orphan ] ++     [ qual origin@@ -665,8 +668,8 @@   -- TODO: print contexts-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName-                -> [(HsDecl DocName,DocForDecl DocName)]+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI+                -> [(HsDecl DocNameI, DocForDecl DocName)]                 -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl pats unicode qual @@ -698,16 +701,16 @@     pats1 = [ hsep [ keyword "pattern"                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames                    , dcolon unicode-                   , ppLType unicode qual (hsSigType typ)+                   , ppPatSigType unicode qual (hsSigType typ)                    ]             | (SigD (PatSynSig lnames typ),_) <- pats             ]  -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] ->               [(DocName, DocForDecl DocName)] ->-              SrcSpan -> Documentation DocName -> TyClDecl DocName ->-              [(HsDecl DocName,DocForDecl DocName)] ->+              SrcSpan -> Documentation DocName -> TyClDecl DocNameI ->+              [(HsDecl DocNameI, DocForDecl DocName)] ->               Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats            splice unicode qual@@ -744,7 +747,7 @@       [ (hsep [ keyword "pattern"               , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames               , dcolon unicode-              , ppLType unicode qual (hsSigType typ)+              , ppPatSigType unicode qual (hsSigType typ)               ] <+> ppFixities subfixs qual         ,combineDocumentation (fst d), [])       | (SigD (PatSynSig lnames typ),d) <- pats@@ -756,7 +759,7 @@   -ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html+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@@ -764,22 +767,22 @@  -- 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 :: Bool -> Bool -> ConDecl DocNameI -> 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)+            : map (ppLParendType unicode qual HideEmptyContexts) 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],+      (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1,+            ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2],        noHtml, noHtml) -  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml)+  ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml)    where     resTy = hsib_body (con_type con)@@ -805,13 +808,13 @@   -- ppConstrHdr is for (non-GADT) existentials constructors' syntax-ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode+ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> 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+    else ppContextNoArrow ctxt unicode qual HideEmptyContexts          <+> darrow unicode +++ toHtml " ")   where     ppForall | forall_   = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs)@@ -819,7 +822,7 @@              | otherwise = noHtml  ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]-                   -> Unicode -> Qualification -> LConDecl DocName -> SubDecl+                   -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl ppSideBySideConstr subdocs fixities unicode qual (L _ con)  = (decl, mbDoc, fieldPart)  where@@ -827,15 +830,15 @@       ConDeclH98{} -> case con_details con of         PrefixCon args ->           hsep ((header_ +++ ppOcc)-            : map (ppLParendType unicode qual) args)+            : map (ppLParendType unicode qual HideEmptyContexts) args)           <+> fixity          RecCon _ -> header_ +++ ppOcc <+> fixity          InfixCon arg1 arg2 ->-          hsep [header_ +++ ppLParendType unicode qual arg1,+          hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1,             ppOccInfix,-            ppLParendType unicode qual arg2]+            ppLParendType unicode qual HideEmptyContexts arg2]           <+> fixity        ConDeclGADT{} -> doGADTCon resTy@@ -849,10 +852,10 @@     doRecordFields fields = subFields qual       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) -    doGADTCon :: Located (HsType DocName) -> Html+    doGADTCon :: Located (HsType DocNameI) -> Html     doGADTCon ty = ppOcc <+> dcolon unicode         -- ++AZ++ make this prepend "{..}" when it is a record style GADT-        <+> ppLType unicode qual ty+        <+> ppLType unicode qual HideEmptyContexts ty         <+> fixity      fixity  = ppFixities fixities qual@@ -877,26 +880,29 @@   ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification-                  -> ConDeclField DocName -> SubDecl+                  -> ConDeclField DocNameI -> 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,-    [])+  ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))+      <+> 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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst  -ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html+ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> 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+    <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts 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 :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html ppDataHeader summary decl@(DataDecl { tcdDataDefn =                                          HsDataDefn { dd_ND = nd                                                     , dd_ctxt = ctxt@@ -906,7 +912,7 @@     (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })     <+>     -- context-    ppLContext ctxt unicode qual <+>+    ppLContext ctxt unicode qual HideEmptyContexts <+>     -- T a b c ..., or a :+: b     ppDataBinderWithVars summary unicode qual decl     <+> case ks of@@ -958,87 +964,109 @@                                | 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)+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType 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) +ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts -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+ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html+ppType       unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts+ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts+ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts -ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html+ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> 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 -> Qualification -> LHsKind DocNameI -> 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+ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts -ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html+ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html+ppPatSigType unicode qual typ =+  let emptyCtxts =+        if hasNonEmptyContext typ && isFirstContextEmpty typ+          then ShowEmptyToplevelContexts+          else HideEmptyContexts+  in ppLType unicode qual emptyCtxts typ+  where+    hasNonEmptyContext :: LHsType name -> Bool+    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 :: LHsType name -> Bool+    isFirstContextEmpty t =+      case unLoc t of+        HsForAllTy _ s -> isFirstContextEmpty s+        HsQualTy cxt _ -> null (unLoc cxt)+        HsFunTy _ s -> isFirstContextEmpty s+        _ -> False++ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html+ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> 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+ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts   = maybeParen ctxt_prec pREC_FUN $-    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual+    ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual+ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts   = maybeParen ctxt_prec pREC_FUN $-    ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual+    ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts  -- UnicodeSyntax alternatives-ppr_mono_ty _ (HsTyVar _ (L _ name)) True _+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 _         (HsSumTy tys) u q = sumParens (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 (L _ 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 "{..}"+ppr_mono_ty _         (HsBangTy b ty)     u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty+ppr_mono_ty _         (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)   u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e+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 =+    parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)+ppr_mono_ty _         (HsListTy ty)       u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)+ppr_mono_ty _         (HsPArrTy ty)       u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)+ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ =+    maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts+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 Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys-ppr_mono_ty _         (HsExplicitListTy NotPromoted _ tys) u q = 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 _         (HsCoreTy {})       _ _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty _         (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys+ppr_mono_ty _         (HsExplicitListTy 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 _         (HsAppsTy {})       _ _ _ = error "ppr_mono_ty HsAppsTy" -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual+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_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) 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]+    hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) 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+    ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts   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.@@ -1047,25 +1075,24 @@         | otherwise = ppr_op'     ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts --  = parens (ppr_mono_lty pREC_TOP ty)-  = ppr_mono_lty ctxt_prec ty unicode qual+  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual-  = ppr_mono_lty ctxt_prec ty unicode qual+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts+  = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_'-ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n+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+ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts+  = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts+        p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts     in     maybeParen ctxt_prec pREC_FUN $     hsep [p1, arrow unicode <+> p2]
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -20,6 +20,7 @@ ) where  import Data.List+import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types@@ -72,7 +73,8 @@   markupMathDisplay          = \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 +86,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@@ -164,9 +182,9 @@       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_ "caption"+            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
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -199,10 +199,10 @@              -> [(SubDecl,Located DocName)] -> Html subInstances 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 (collapseDetails id_ DetailsOpen (summary +++ contents))+    instTable = subTableSrc qual lnks splice     subSection = thediv ! [theclass "subs instances"]-    subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"+    summary = thesummary << "Instances"     id_ = makeAnchorId $ "i:" ++ nm  @@ -212,7 +212,7 @@ subOrphanInstances qual lnks splice  = maybe noHtml wrap . instTable   where     wrap = ((h1 << "Orphan instances") +++)-    instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice+    instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice     id_ = makeAnchorId $ "orphans"  @@ -222,7 +222,7 @@ 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)@@ -241,7 +241,9 @@ 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
+ 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
@@ -22,7 +22,7 @@ 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 @@ -147,17 +147,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
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -25,7 +25,8 @@    hsep, vcat, -  collapseSection, collapseToggle, collapseControl,+  DetailsState(..), collapseDetails, thesummary,+  collapseToggle, collapseControl, ) where  @@ -213,26 +214,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
@@ -24,6 +24,7 @@ import Data.Either (lefts, rights) import DataCon import FamInstEnv+import FV import HsSyn import Name import NameSet ( emptyNameSet )@@ -39,8 +40,10 @@ import PrelNames ( hasKey, eqTyConKey, ipClassKey                  , tYPETyConKey, liftedRepDataConKey ) import Unique ( getUnique )-import Util ( filterByList, filterOut )+import Util ( chkAppend, compareLength, dropList, filterByList, filterOut+            , splitAtList ) import Var+import VarSet  import Haddock.Types import Haddock.Interface.Specialize@@ -48,7 +51,7 @@   -- the main function here! yay!-tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name))+tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) tyThingToLHsDecl t = case t of   -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.   -- Including built-in functions like seq.@@ -76,7 +79,7 @@        in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl          { tcdCtxt = synifyCtx (classSCTheta cl)          , tcdLName = synifyName cl-         , tcdTyVars = synifyTyVars (classTyVars cl)+         , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl))          , tcdFixity = Prefix          , tcdFDs = map (\ (l,r) -> noLoc                         (map (noLoc . getName) l, map (noLoc . getName) r) ) $@@ -107,25 +110,30 @@     withErrs e x = return (e, x)     allOK x = return (mempty, x) -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name+synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn 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-                                   , hsib_closed = True }-                , tfe_fixity = Prefix-                , tfe_rhs   = hs_rhs }+  = let name            = synifyName tc+        args_types_only = filterOutInvisibleTypes tc args+        typats          = map (synifyType WithinType) args_types_only+        annot_typats    = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)+                                   args_types_only typats+        hs_rhs          = synifyType WithinType rhs+    in HsIB { hsib_vars   = map tyVarName tkvs+            , hsib_closed = True+            , hsib_body   = FamEqn { feqn_tycon  = name+                                   , feqn_pats   = annot_typats+                                   , feqn_fixity = Prefix+                                   , feqn_rhs    = hs_rhs } }+  where+    fam_tvs = tyConVisibleTyVars tc -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name)+synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) 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 }))+  = return $ InstD+           $ TyFamInstD+           $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }    | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc   , getUnique ax' == getUnique ax   -- without the getUniques, type error@@ -135,7 +143,7 @@   = Left "synifyAxiom: closed/open family confusion"  -- | Turn type constructors into type class declarations-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name)+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) synifyTyCon _coax tc   | isFunTyCon tc || isPrimTyCon tc   = return $@@ -155,7 +163,7 @@                                                     -- algebraic data nor newtype:                                       , dd_ctxt = noLoc []                                       , dd_cType = Nothing-                                      , dd_kindSig = Just (synifyKindSig (tyConKind tc))+                                      , dd_kindSig = synifyDataTyConReturnKind tc                                                -- we have their kind accurately:                                       , dd_cons = []  -- No constructors                                       , dd_derivs = noLoc [] }@@ -184,19 +192,19 @@     mkFamDecl i = return $ FamDecl $       FamilyDecl { fdInfo = i                  , fdLName = synifyName tc-                 , fdTyVars = synifyTyVars (tyConTyVars tc)+                 , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)                  , fdFixity = Prefix                  , fdResultSig =                        synifyFamilyResultSig resultVar (tyConResKind tc)                  , fdInjectivityAnn =                        synifyInjectivityAnn  resultVar (tyConTyVars tc)-                                       (familyTyConInjectivityInfo tc)+                                       (tyConInjectivityInfo tc)                  }  synifyTyCon coax tc   | Just ty <- synTyConRhs_maybe tc   = return $ SynDecl { tcdLName = synifyName tc-                     , tcdTyVars = synifyTyVars (tyConTyVars tc)+                     , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)                      , tcdFixity = Prefix                      , tcdRhs = synifyType WithinType ty                      , tcdFVs = placeHolderNamesTc }@@ -209,8 +217,8 @@     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)+  tyvars = synifyTyVars (tyConVisibleTyVars tc)+  kindSig = synifyDataTyConReturnKind tc   -- The data constructors.   --   -- Any data-constructors not exported from the module that *defines* the@@ -235,7 +243,7 @@   defn = HsDataDefn { dd_ND      = alg_nd                     , dd_ctxt    = alg_ctx                     , dd_cType   = Nothing-                    , dd_kindSig = fmap synifyKindSig kindSig+                    , dd_kindSig = kindSig                     , dd_cons    = cons                     , dd_derivs  = alg_deriv }  in case lefts consRaw of@@ -245,15 +253,36 @@                  , tcdDataCusk = False, tcdFVs = placeHolderNamesTc }   dataConErrs -> Left $ unlines dataConErrs +-- 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+  = case splitFunTys (tyConKind tc) of+      (_, ret_kind)+        | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: *+        | otherwise                 -> Just (synifyKindSig ret_kind)+ synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity-                     -> Maybe (LInjectivityAnn Name)+                     -> Maybe (LInjectivityAnn GhcRn) 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 :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig  Nothing    kind =    noLoc $ KindSig  (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =@@ -264,7 +293,7 @@ -- 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 :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn) synifyDataCon use_gadt_syntax dc =  let   -- dataConIsInfix allegedly tells us whether it was declared with@@ -321,22 +350,22 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)  -synifyIdSig :: SynifyTypeState -> Id -> Sig Name+synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name+synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) -synifyCtx :: [PredType] -> LHsContext Name+synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType)  -synifyTyVars :: [TyVar] -> LHsQTyVars Name+synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_implicit = []                            , hsq_explicit = map synifyTyVar ktvs                            , hsq_dependent = emptyNameSet } -synifyTyVar :: TyVar -> LHsTyVarBndr Name+synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv   | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name))   | otherwise             = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind))@@ -344,6 +373,33 @@     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 noLoc (HsKindSig hs_ty hs_ki)+annotHsType _    _ hs_ty = hs_ty++-- | For every type variable in the input,+-- report whether or not the tv is poly-kinded. This is used to eventually+-- feed into 'annotHsType'.+mkIsPolyTvs :: [TyVar] -> [Bool]+mkIsPolyTvs = map is_poly_tv+  where+    is_poly_tv tv = not $+                    isEmptyVarSet $+                    filterVarSet isTyVar $+                    tyCoVarsOfType $+                    tyVarKind tv+ --states of what to do with foralls: data SynifyTypeState   = WithinType@@ -360,53 +416,95 @@   --   the defining class gets to quantify all its functions for free!  -synifySigType :: SynifyTypeState -> Type -> LHsSigType Name+synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn -- 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+synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) -synifyPatSynSigType :: PatSyn -> LHsSigType Name+synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType Name+synifyType :: SynifyTypeState -> Type -> LHsType GhcRn synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys)-  -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)-  | tc `hasKey` tYPETyConKey-  , [TyConApp lev []] <- tys-  , lev `hasKey` liftedRepDataConKey-  = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))-  -- 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 (noLoc $ 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 NotPromoted $ noLoc (getName tc))-      (map (synifyType WithinType) $-       filterOut isCoercionTy tys)+  = maybe_sig res_ty+  where+    res_ty :: LHsType GhcRn+    res_ty+      -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)+      | tc `hasKey` tYPETyConKey+      , [TyConApp lev []] <- tys+      , lev `hasKey` liftedRepDataConKey+      = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName))+      -- 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) vis_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 (noLoc $ HsIPName x) (synifyType WithinType ty)+      -- and equalities+      | tc `hasKey` eqTyConKey+      , [ty1, ty2] <- tys+      = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)+      -- and infix type operators+      | isSymOcc (nameOccName (getName tc))+      , ty1:ty2:tys_rest <- vis_tys+      = mk_app_tys (HsOpTy (synifyType WithinType ty1)+                           (noLoc $ getName tc)+                           (synifyType WithinType ty2))+                   tys_rest+      -- Most TyCons:+      | otherwise+      = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc))+                   vis_tys+      where+        mk_app_tys ty_app ty_args =+          foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2)+                (noLoc ty_app)+                (map (synifyType WithinType) $+                 filterOut isCoercionTy ty_args)++    vis_tys  = filterOutInvisibleTypes tc tys+    binders  = tyConBinders tc+    res_kind = tyConResKind tc++    maybe_sig :: LHsType GhcRn -> LHsType GhcRn+    maybe_sig ty'+      | needs_kind_sig+      = let full_kind  = typeKind (mkTyConApp tc tys)+            full_kind' = synifyType WithinType full_kind+        in noLoc $ HsKindSig ty' full_kind'+      | otherwise = ty'++    needs_kind_sig :: Bool+    needs_kind_sig+      | GT <- compareLength tys binders+      = False+      | otherwise+      = let (dropped_binders, remaining_binders)+                  = splitAtList  tys binders+            result_kind  = mkTyConKind remaining_binders res_kind+            result_vars  = tyCoVarsOfType result_kind+            dropped_vars = fvVarSet $+                           mapUnionFV injectiveVarsOfBinder dropped_binders++        in not (subVarSet result_vars dropped_vars)+ synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let   s1 = synifyType WithinType t1@@ -430,7 +528,7 @@ synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" -synifyPatSynType :: PatSyn -> LHsType Name+synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = let   (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps   req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy]@@ -450,17 +548,16 @@ synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s -synifyKindSig :: Kind -> LHsKind Name+synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead     { ihdClsName = getName cls-    , ihdKinds = map (unLoc . synifyType WithinType) ks-    , ihdTypes = map (unLoc . synifyType WithinType) ts+    , ihdTypes = map unLoc annot_ts     , ihdInstType = ClassInst         { clsiCtx = map (unLoc . synifyType WithinType) preds-        , clsiTyVars = synifyTyVars $ classTyVars cls+        , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)         , clsiSigs = map synifyClsIdSig $ classMethods cls         , clsiAssocTys = do             (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls@@ -468,24 +565,48 @@         }     }   where-    (ks,ts) = partitionInvisibles (classTyCon cls) id types+    cls_tycon = classTyCon cls+    ts  = filterOutInvisibleTypes cls_tycon types+    ts' = map (synifyType WithinType) ts+    annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'+    is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)     synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification  -- Convert a family instance, this could be a type family or data family-synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name)+synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) synifyFamInst fi opaque = do-    ityp' <- ityp $ fi_flavor fi+    ityp' <- ityp fam_flavor     return InstHead         { ihdClsName = fi_fam fi-        , ihdKinds = synifyTypes ks-        , ihdTypes = synifyTypes ts+        , ihdTypes = map unLoc annot_ts         , ihdInstType = ityp'         }   where     ityp SynFamilyInst | opaque = return $ TypeInst Nothing     ityp SynFamilyInst =-        return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi+        return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs     ityp (DataFamilyInst c) =         DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c-    (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi-    synifyTypes = map (unLoc. synifyType WithinType)+    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 TcInstDcls 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 is_poly_tvs ts ts'+    is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
src/Haddock/GhcUtils.hs view
@@ -43,7 +43,7 @@ isConSym = isLexConSym . occNameFS  -getMainDeclBinder :: HsDecl name -> [name]+getMainDeclBinder :: HsDecl name -> [IdP name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) =   case collectHsBindBinders d of@@ -59,21 +59,22 @@ -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)-getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l+getInstLoc (DataFamInstD (DataFamInstDecl+  { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_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+  { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_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 name -> Bool) -> LSig name -> Maybe (LSig name) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)+filterSigNames :: (IdP 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)) =@@ -99,10 +100,10 @@ ifTrueJust True  = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [name]+sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [name]+sigNameNoLoc :: Sig name -> [IdP name] sigNameNoLoc (TypeSig      ns _)       = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _)       = map unLoc ns sigNameNoLoc (PatSynSig    ns _)       = map unLoc ns@@ -128,7 +129,7 @@ isValD _ = False  -declATs :: HsDecl a -> [a]+declATs :: HsDecl a -> [IdP a] declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -164,7 +165,7 @@ -------------------------------------------------------------------------------  -instance NamedThing (TyClDecl Name) where+instance NamedThing (TyClDecl GhcRn) where   getName = tcdName  -------------------------------------------------------------------------------@@ -176,14 +177,14 @@   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)       _             -> [] -instance Parent (TyClDecl Name) where+instance Parent (TyClDecl GhcRn) where   children d     | isDataDecl  d = map unL $ concatMap (getConNames . unL)                               $ (dd_cons . tcdDataDefn) $ d@@ -198,12 +199,12 @@ family = getName &&& children  -familyConDecl :: ConDecl Name -> [(Name, [Name])]+familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] familyConDecl d = zip (map unL (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))   | isClassDecl d = [family d]@@ -211,12 +212,12 @@   -- | 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 :: Name -> HsDecl GhcRn -> [Name] parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = []
src/Haddock/Interface.hs view
@@ -58,6 +58,8 @@ import HscTypes import FastString (unpackFS) import MonadUtils (liftIO)+import TcRnTypes (tcg_rdr_env)+import RdrName (plusGlobalRdrEnv)  #if defined(mingw32_HOST_OS) import System.IO@@ -122,11 +124,7 @@   -- 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+    createIfaces verbosity flags instIfaceMap modGraph    where     useTempDir :: Bool@@ -149,17 +147,6 @@       depanal [] False  -    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'-- createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] createIfaces verbosity flags instIfaceMap mods = do   let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing@@ -178,6 +165,18 @@ processModule verbosity modsum flags modMap instIfaceMap = do   out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."   tm <- loadModule =<< typecheckModule =<< parseModule modsum++  -- We need to modify the interactive context's environment so that when+  -- Haddock later looks for instances, it also looks in the modules it+  -- encountered while typechecking.+  --+  -- See https://github.com/haskell/haddock/issues/469.+  hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession+  let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm+  setSession hsc_env{ hsc_IC = old_IC {+    ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env+  } }+   if not $ isBootSummary modsum then do     out verbosity verbose "Creating interface..."     (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap@@ -194,7 +193,7 @@                                                             , expItemMbDoc = (Documentation Nothing _, _)                                                             } <- ifaceExportItems interface ]           where-            formatName :: SrcSpan -> HsDecl Name -> String+            formatName :: SrcSpan -> HsDecl GhcRn -> String             formatName loc n = p (getMainDeclBinder n) ++ case loc of               RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"               _ -> ""@@ -206,12 +205,13 @@                          then drop (length ms) n                          else n -    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+    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
src/Haddock/Interface/AttachInstances.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Interface.AttachInstances@@ -18,7 +19,6 @@ import Haddock.Convert import Haddock.GhcUtils -import Control.Applicative import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing)@@ -53,7 +53,7 @@ -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] attachInstances expInfo ifaces instIfaceMap = do-  (_msgs, mb_index) <- getNameToInstancesIndex+  (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces)   mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces   where     -- TODO: take an IfaceMap as input@@ -67,7 +67,7 @@                      , ifaceOrphanInstances = orphanInstances                      } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name]+attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =   [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n))   | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ]@@ -82,8 +82,8 @@   -> Interface   -> IfaceMap   -> InstIfaceMap-  -> ExportItem Name-  -> Ghc (ExportItem Name)+  -> ExportItem GhcRn+  -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export =   case attachFixities export of     e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do@@ -117,12 +117,12 @@   where     attachFixities e@ExportDecl{ expItemDecl = L _ d                                , expItemPats = patsyns+                               , expItemSubDocs = subDocs                                } = e { expItemFixities =       nubByName fst $ expItemFixities e ++       [ (n',f) | n <- getMainDeclBinder d-              , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []]-              , n' <- n : (subs ++ patsyn_names)-              , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]+               , n' <- n : (map fst subDocs ++ patsyn_names)+               , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]       ] }       where         patsyn_names = concatMap (getMainDeclBinder . fst) patsyns
src/Haddock/Interface/Create.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- |@@ -30,27 +31,30 @@ import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bifunctor+import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe-import Data.Monoid import Data.Ord import Control.Applicative-import Control.Arrow (second)-import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Traversable +import Avail hiding (avail)+import qualified Avail import qualified Packages import qualified Module import qualified SrcLoc+import ConLike (ConLike(..)) import GHC import HscTypes import Name import NameSet+import NameEnv import Bag import RdrName import TcRnTypes@@ -59,6 +63,7 @@ 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'.@@ -83,48 +88,36 @@        (TcGblEnv { tcg_rdr_env = gre                 , tcg_warns   = warnings-                , tcg_patsyns = patsyns+                , tcg_exports = all_exports                 }, 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) <-+  (group_, imports, 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)+        return (emptyRnGroup, [], Nothing, Nothing)+      Just x -> return x -  opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl-  let opts-        | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0-        | otherwise = opts0+  opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl    -- Process the top-level module header documentation.   (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader    let declsWithDocs = topDecls group_ -      exports0 = fmap (reverse . map unLoc) mayExports+      exports0 = fmap (reverse . map (first unLoc)) mayExports       exports         | OptIgnoreExports `elem` opts = Nothing         | otherwise = exports0-      warningMap = mkWarningMap dflags warnings gre exportedNames -      localBundledPatSyns :: Map Name [Name]-      localBundledPatSyns =-        case exports of-          Nothing  -> M.empty-          Just ies ->-            M.map (nubByName id) $-            M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns)-                                | IEThingWith (L _ ty_name) _ exported _ <- ies-                                , let bundled_patsyns =-                                        filter is_patsyn (map (ieWrappedName . unLoc) exported)-                                , not (null bundled_patsyns)-                                ]-        where-          is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns))+      unrestrictedImportedMods+        -- module re-exports are only possible with+        -- explicit export list+        | Just{} <- exports+        = unrestrictedModuleImports (map unLoc imports)+        | otherwise = M.empty        fixMap = mkFixMap group_       (decls, _) = unzip declsWithDocs@@ -134,15 +127,18 @@       -- Locations of all TH splices       splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] -      maps@(!docMap, !argMap, !subMap, !declMap, _) =-        mkMaps dflags gre localInsts declsWithDocs+  warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) +  maps@(!docMap, !argMap, !declMap, _) <-+    liftErrMsg (mkMaps dflags gre localInsts declsWithDocs)+   let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))    -- The MAIN functionality: compute the export items which will   -- each be the actual documentation of this module.-  exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls-                   maps localBundledPatSyns fixMap splices exports instIfaceMap dflags+  exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre+                   exportedNames decls maps fixMap unrestrictedImportedMods+                   splices exports all_exports instIfaceMap dflags    let !visibleNames = mkVisibleNames maps exportItems opts @@ -161,10 +157,11 @@    let !aliases =         mkAliasMap dflags $ tm_renamed_source tm-      modWarn = moduleWarning dflags gre warnings -  tokenizedSrc <- mkMaybeTokenizedSrc flags tm+  modWarn <- liftErrMsg (moduleWarning dflags gre warnings) +  tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm+   return $! Interface {     ifaceMod               = mdl   , ifaceIsSig             = is_sig@@ -182,8 +179,6 @@   , ifaceExports           = exportedNames   , ifaceVisibleExports    = visibleNames   , ifaceDeclMap           = declMap-  , ifaceBundledPatSynMap  = localBundledPatSyns-  , ifaceSubMap            = subMap   , ifaceFixMap            = fixMap   , ifaceModuleAliases     = aliases   , ifaceInstances         = instances@@ -229,6 +224,41 @@            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 name] -> 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 ideclHiding idecl of+        -- i) no subset selected+        Nothing             -> True+        -- ii) an import with a hiding clause+        -- without any names+        Just (True, L _ []) -> True+        -- iii) any other case of qualification+        _                   -> False+ -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn ::@@ -245,27 +275,29 @@ -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of-  NoWarnings  -> M.empty-  WarnAll _   -> M.empty+  NoWarnings  -> pure M.empty+  WarnAll _   -> pure M.empty   WarnSome ws ->-    let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ+    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'+    in M.fromList <$> traverse (bitraverse pure (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+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))+moduleWarning _ _ NoWarnings = pure Nothing+moduleWarning _ _ (WarnSome _) = pure 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+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)+parseWarning dflags gre w = 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+                  <$> processDocString dflags gre (HsDocString xs)   -------------------------------------------------------------------------------@@ -282,13 +314,17 @@       [] -> 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+  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 :: String -> ErrMsgM (Maybe DocOption) parseOption "hide"            = return (Just OptHide)@@ -304,7 +340,7 @@ --------------------------------------------------------------------------------  -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)+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@@ -312,17 +348,15 @@ 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 (nubByName fst) a)-     , f  (filterMapping (not . M.null) b)-     , f  (filterMapping (not . null) c)-     , f  (filterMapping (not . null) d)-     , instanceMap-     )+       -> [(LHsDecl GhcRn, [HsDocString])]+       -> ErrMsgM Maps+mkMaps dflags gre instances decls = do+  (a, b, c) <- unzip3 <$> traverse mappings decls+  pure ( f' (map (nubByName fst) a)+       , f  (filterMapping (not . M.null) b)+       , f  (filterMapping (not . null) c)+       , instanceMap+       )   where     f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b     f = M.fromListWith (<>) . concat@@ -333,41 +367,46 @@     filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]     filterMapping p = map (filter (p . snd)) -    mappings :: (LHsDecl Name, [HsDocString])-             -> ( [(Name, MDoc Name)]-                , [(Name, Map Int (MDoc Name))]-                , [(Name, [Name])]-                , [(Name,  [LHsDecl Name])]-                )-    mappings (ldecl, docStrs) =+    mappings :: (LHsDecl GhcRn, [HsDocString])+             -> ErrMsgM ( [(Name, MDoc Name)]+                        , [(Name, Map Int (MDoc Name))]+                        , [(Name,  [LHsDecl GhcRn])]+                        )+    mappings (ldecl, docStrs) = do       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)+                  -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))+          declDoc strs m = do+            doc' <- processDocStrings dflags gre strs+            m'   <- traverse (processDocStringParas dflags gre) m+            pure (doc', m')++      (doc, args) <- declDoc docStrs (typeDocs decl)++      let           subs :: [(Name, [HsDocString], Map Int HsDocString)]           subs = subordinates instanceMap decl-          (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs++      (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-          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) +      seqList ns `seq`+        seqList subNs `seq`+        doc `seq`+        seqList subDocs `seq`+        seqList subArgs `seq`+        pure (dm, am, cm)+     instanceMap :: Map SrcSpan Name     instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] -    names :: SrcSpan -> HsDecl Name -> [Name]+    names :: SrcSpan -> HsDecl GhcRn -> [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@@ -392,15 +431,17 @@ -- A subordinate declaration is something like the associate type or data -- family of a type class. subordinates :: InstMap-             -> HsDecl Name+             -> HsDecl GhcRn              -> [(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+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =+      FamEqn { feqn_tycon = L l _+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn -  InstD (DataFamInstD d)  -> dataSubs (dfid_defn d)+  InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d })))+    -> dataSubs (feqn_rhs d)   TyClD d | isClassDecl d -> classSubs d           | isDataDecl  d -> dataSubs (tcdDataDefn d)   _ -> []@@ -408,7 +449,7 @@     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 :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]     dataSubs dd = constrs ++ fields ++ derivs       where         cons = map unL $ (dd_cons dd)@@ -425,7 +466,7 @@                   , Just instName <- [M.lookup l instMap] ]  -- | Extract function argument docs from inside types.-typeDocs :: HsDecl Name -> Map Int HsDocString+typeDocs :: HsDecl GhcRn -> Map Int HsDocString typeDocs d =   let docs = go 0 in   case d of@@ -446,7 +487,7 @@  -- | 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 :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls   where     decls = docs ++ defs ++ sigs ++ ats@@ -458,18 +499,19 @@  -- | 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+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+topDecls =+  filterClasses . filterDecls . collectDocs . sortByLoc . ungroup  -- | Extract a map of fixity declarations only-mkFixMap :: HsGroup Name -> FixMap+mkFixMap :: HsGroup GhcRn -> 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 :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ =   mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD  group_ ++   mkDecls hs_derivds             DerivD group_ ++@@ -519,7 +561,6 @@     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@@ -569,53 +610,78 @@   -> WarningMap   -> GlobalRdrEnv   -> [Name]             -- exported names (orig)-  -> [LHsDecl Name]     -- renamed source declarations+  -> [LHsDecl GhcRn]     -- renamed source declarations   -> Maps-  -> Map Name [Name]   -> FixMap+  -> M.Map ModuleName [ModuleName]   -> [SrcSpan]          -- splice locations-  -> Maybe [IE Name]+  -> Maybe [(IE GhcRn, Avails)]+  -> Avails             -- exported stuff from this module   -> InstIfaceMap   -> DynFlags-  -> ErrMsgGhc [ExportItem Name]+  -> ErrMsgGhc [ExportItem GhcRn] mkExportItems   is_sig modMap thisMod semMod warnings gre exportedNames decls-  maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags =-  case optExports of-    Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls+  maps fixMap unrestricted_imp_mods splices exportList allExports+  instIfaceMap dflags =+  case exportList of+    Nothing      ->+      fullModuleContents is_sig modMap thisMod semMod warnings gre+        exportedNames decls maps fixMap splices instIfaceMap dflags+        allExports     Just exports -> liftM concat $ mapM lookupExport exports   where-    lookupExport (IEVar (L _ x))         = declWith [] $ ieWrappedName x-    lookupExport (IEThingAbs (L _ t))    = declWith [] $ ieWrappedName t-    lookupExport (IEThingAll (L _ t))    = do-      let name     = ieWrappedName t-      pats <- findBundledPatterns name-      declWith pats name-    lookupExport (IEThingWith (L _ t) _ _ _) = do-      let name     = ieWrappedName t-      pats <- findBundledPatterns name-      declWith pats name-    lookupExport (IEModuleContents (L _ m)) =-      -- TODO: We could get more accurate reporting here if IEModuleContents-      -- also recorded the actual names that are exported here.  We CAN-      -- compute this info using @gre@ but 'moduleExports does not seem to-      -- do so.-      -- NB: Pass in identity module, so we can look it up in index correctly-      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 (IEGroup lev docStr, _)  = liftErrMsg $ do+      doc <- processDocString dflags gre docStr+      return [ExportGroup lev "" doc] -    lookupExport (IEDoc docStr)        = return $-      return . ExportDoc $ processDocStringParas dflags gre docStr+    lookupExport (IEDoc docStr, _)        = liftErrMsg $ do+      doc <- processDocStringParas dflags gre docStr+      return [ExportDoc doc] -    lookupExport (IEDocNamed str)      = liftErrMsg $-      findNamedDoc str [ unL d | d <- decls ] >>= return . \case-        Nothing -> []-        Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc+    lookupExport (IEDocNamed str, _)      = liftErrMsg $+      findNamedDoc str [ unL d | d <- decls ] >>= \case+        Nothing -> return  []+        Just docStr -> do+          doc <- processDocStringParas dflags gre docStr+          return [ExportDoc doc] -    declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ]-    declWith pats t = do-      r <- findDecl t+    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++availExportItem :: 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+                -> ErrMsgGhc [ExportItem GhcRn]+availExportItem is_sig modMap thisMod semMod warnings exportedNames+  (docMap, argMap, declMap, _) fixMap splices instIfaceMap+  dflags availInfo = declWith availInfo+  where+    declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ]+    declWith avail = do+      let t = availName avail+      r    <- findDecl avail       case r of         ([L l (ValD _)], (doc, _)) -> do           -- Top-level binding without type signature@@ -625,11 +691,6 @@           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,@@ -651,15 +712,15 @@                     -- 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 pats docs_ ]+                    in availExportDecl avail newDecl docs_                    L loc (TyClD cl@ClassDecl{}) -> do                     mdef <- liftGhcToErrMsgGhc $ minimalDef t                     let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef-                    return [ mkExportDecl t-                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ]+                    availExportDecl avail+                      (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ -                  _ -> return [ mkExportDecl t decl pats docs_ ]+                  _ -> availExportDecl avail decl docs_          -- Declaration from another package         ([], _) -> do@@ -675,34 +736,65 @@                 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 pats (noDocForDecl, subs_) ]+                   let subs_ = availNoDocs avail+                   availExportDecl avail decl (noDocForDecl, subs_)                 Just iface ->-                   return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]+                  availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface))          _ -> return [] +    availExportDecl :: AvailInfo -> LHsDecl GhcRn+                    -> (DocForDecl Name, [(Name, DocForDecl Name)])+                    -> ErrMsgGhc [ ExportItem GhcRn ]+    availExportDecl avail decl (doc, subs)+      | availExportsDecl avail = do+          -- bundled pattern synonyms only make sense if the declaration is+          -- exported (otherwise there would be nothing to bundle to)+          bundledPatSyns <- findBundledPatterns avail -    mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)]-                 -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name-    mkExportDecl name decl pats (doc, subs) = decl'-      where-        decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False-        subs' = filter (isExported . fst) subs-        pats' = [ d | d@(patsyn_decl, _) <- pats-                    , all isExported (getMainDeclBinder patsyn_decl) ]-        sub_names = map fst subs'-        pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl]-        fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ]+          let+            patSynNames =+              concatMap (getMainDeclBinder . fst) bundledPatSyns +            fixities =+                [ (n, f)+                | n <- availName avail : fmap fst subs ++ patSynNames+                , Just f <- [M.lookup n fixMap]+                ]++          return [ ExportDecl {+                       expItemDecl      = restrictTo (fmap fst subs)+                                            (extractDecl declMap (availName avail) decl)+                     , expItemPats      = bundledPatSyns+                     , expItemMbDoc     = doc+                     , expItemSubDocs   = subs+                     , expItemInstances = []+                     , expItemFixities  = fixities+                     , expItemSpliced   = False+                     }+                 ]++      | otherwise =+          return [ ExportDecl {+                       expItemDecl      = extractDecl declMap sub decl+                     , expItemPats      = []+                     , expItemMbDoc     = sub_doc+                     , expItemSubDocs   = []+                     , expItemInstances = []+                     , expItemFixities  = [ (sub, f) | Just f <- [M.lookup sub fixMap] ]+                     , expItemSpliced   = False+                     }+                 | (sub, sub_doc) <- subs+                 ]+     exportedNameSet = mkNameSet exportedNames     isExported n = elemNameSet n exportedNameSet -    findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))-    findDecl n+    findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)]))+    findDecl avail       | m == semMod =           case M.lookup n declMap of-            Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap)+            Just ds -> return (ds, lookupDocs avail warnings docMap argMap)             Nothing               | is_sig -> do                 -- OK, so it wasn't in the local declaration map.  It could@@ -710,57 +802,57 @@                 -- from the type.                 mb_r <- hiDecl dflags n                 case mb_r of-                    Nothing -> return ([], (noDocForDecl, []))+                    Nothing -> return ([], (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 (pkgState)-                    Just decl -> return ([decl], (noDocForDecl, []))+                    Just decl -> return ([decl], (noDocForDecl, availNoDocs avail))               | otherwise ->-                return ([], (noDocForDecl, []))+                return ([], (noDocForDecl, availNoDocs avail))       | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap       , Just ds <- M.lookup n (ifaceDeclMap iface) =-          return (ds, lookupDocs n warnings+          return (ds, lookupDocs avail warnings                             (ifaceDocMap iface)-                            (ifaceArgMap iface)-                            (ifaceSubMap iface))-      | otherwise = return ([], (noDocForDecl, []))+                            (ifaceArgMap iface))+      | otherwise = return ([], (noDocForDecl, availNoDocs avail))       where+        n = availName avail         m = nameModule n -    findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)]-    findBundledPatterns t =-      let-        m = nameModule t--        local_bundled_patsyns =-          M.findWithDefault [] t patSynMap--        iface_bundled_patsyns-          | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap-          , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface)-          = patsyns--          | Just iface <- M.lookup m instIfaceMap-          , Just patsyns <- M.lookup t (instBundledPatSynMap iface)-          = patsyns--          | otherwise-          = []--        patsyn_decls = do-          for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do-            -- call declWith here so we don't have to prepare the pattern synonym for-            -- showing ourselves.-            export_items <- declWith [] patsyn_name+    findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)]+    findBundledPatterns avail = do+      patsyns <- for constructor_names $ \name -> do+        mtyThing <- liftGhcToErrMsgGhc (lookupName name)+        case mtyThing of+          Just (AConLike PatSynCon{}) -> do+            export_items <- declWith (Avail.avail name)             pure [ (unLoc patsyn_decl, patsyn_doc)                  | ExportDecl {                        expItemDecl  = patsyn_decl                      , expItemMbDoc = patsyn_doc                      } <- export_items                  ]+          _ -> pure []+      pure (concat patsyns)+      where+        constructor_names =+          filter isDataConName (availSubordinates avail) -      in concat <$> patsyn_decls+-- this heavily depends on the invariants stated in Avail+availExportsDecl :: AvailInfo -> Bool+availExportsDecl (AvailTC ty_name names _)+  | n : _ <- names = ty_name == n+  | otherwise      = False+availExportsDecl _ = True +availSubordinates :: AvailInfo -> [Name]+availSubordinates avail =+  filter (/= availName avail) (availNamesWithSelectors avail)++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 :: UnitId -> Module -> Module@@ -768,7 +860,7 @@     | Module.isHoleModule m = mkModule this_uid (moduleName m)     | otherwise      = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do   mayTyThing <- liftGhcToErrMsgGhc $ lookupName t   case mayTyThing of@@ -790,7 +882,7 @@ -- 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)+                -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do   mayDecl <- hiDecl dflags name   case mayDecl of@@ -804,48 +896,29 @@   -- | Lookup docs for a declaration from maps.-lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap+lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name            -> (DocForDecl Name, [(Name, DocForDecl Name)])-lookupDocs n warnings docMap argMap subMap =+lookupDocs avail warnings 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 subs = M.findWithDefault [] n subMap in-  let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] 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 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 (identity, NOT semantic)-              -> 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 renamed 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-  | expMod == moduleName thisMod-  = fullModuleContents dflags warnings gre maps fixMap splices decls-  | otherwise =+-- | Export the given module as `ExportModule`. We are not concerned with the+-- single export items of the given module.+moduleExport :: 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+             -> ErrMsgGhc [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@@ -866,7 +939,6 @@     m = mkModule unitId expMod -- Identity module!     unitId = moduleUnitId thisMod - -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if@@ -887,124 +959,149 @@ -- | Simplified variant of 'mkExportItems', where we can assume that -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations.-fullModuleContents :: DynFlags++fullModuleContents :: Bool               -- is it a signature+                   -> IfaceMap+                   -> Module             -- this module+                   -> Module             -- semantic module                    -> WarningMap                    -> GlobalRdrEnv      -- ^ The renaming environment+                   -> [Name]             -- exported names (orig)+                   -> [LHsDecl GhcRn]    -- renamed source declarations                    -> Maps                    -> FixMap-                   -> [SrcSpan]         -- ^ Locations of all TH splices-                   -> [LHsDecl Name]    -- ^ All the renamed declarations-                   -> ErrMsgGhc [ExportItem Name]-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =-  liftM catMaybes $ mapM mkExportItem (expandSigDecls decls)+                   -> [SrcSpan]          -- splice locations+                   -> InstIfaceMap+                   -> DynFlags+                   -> Avails+                   -> ErrMsgGhc [ExportItem GhcRn]+fullModuleContents is_sig modMap 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 <- liftErrMsg (processDocString dflags gre docStr)+        return [[ExportGroup lev "" doc]]+      (L _ (DocD (DocCommentNamed _ docStr))) -> do+        doc <- liftErrMsg (processDocStringParas dflags gre docStr)+        return [[ExportDoc doc]]+      (L _ (ValD valDecl))+        | name:_ <- collectHsBindBinders valDecl+        , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap+        -> return []+      _ ->+        for (getMainDeclBinder (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 [])   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!-    expandSigDecls :: [LHsDecl name] -> [LHsDecl name]-    expandSigDecls = concatMap f-      where-        f (L l (SigD sig))              = [ L l (SigD s) | s <- expandSig sig ]--        -- also expand type signatures for class methods-        f (L l (TyClD cls@ClassDecl{})) =-          [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ]-        f x = [x]--    expandLSig :: LSig name -> [LSig name]-    expandLSig (L l sig) = [ L l s | s <- expandSig sig ]--    expandSig :: Sig name -> [Sig name]-    expandSig (TypeSig names t)      = [ TypeSig [n] t      | n <- names ]-    expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ]-    expandSig (PatSynSig names t)    = [ PatSynSig [n] t    | n <- names ]-    expandSig x                      = [x]--    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 =-        expInst decl l name-    mkExportItem decl@(L l (DerivD {}))-      | Just name <- M.lookup l instMap =-        expInst decl l name-    mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do-      mdef <- liftGhcToErrMsgGhc $ minimalDef name-      let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . 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--    expInst decl l name =-        let (doc, subs) = lookupDocs name warnings docMap argMap subMap in-        return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices))-+    isSigD (L _ SigD{}) = True+    isSigD _            = False  -- | 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 -> LHsDecl Name -> LHsDecl Name-extractDecl name decl+extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn+extractDecl declMap name 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-                      ]+        let+          matchesMethod =+            [ lsig+            | lsig <- tcdSigs d+            , ClassOpSig False _ _ <- pure $ unLoc lsig+              -- Note: exclude `default` declarations (see #505)+            , name `elem` sigName lsig+            ]++          matchesAssociatedType =+            [ lfam_decl+            | lfam_decl <- tcdATs d+            , name == unLoc (fdLName (unLoc lfam_decl))+            ]+             -- 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)+        in case (matchesMethod, matchesAssociatedType)  of+          ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d)+                           L pos sig = addClassContext n tyvar_names s0+                       in L pos (SigD sig)+          (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl))++          ([], [])+            | Just (famInstDecl:_) <- M.lookup name declMap+            -> extractDecl declMap name famInstDecl           _ -> 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))+                                         O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType))       TyClD d@DataDecl {} ->         let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d))-        in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))-      InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n-                                          , dfid_pats = HsIB { hsib_body = tys }-                                          , dfid_defn = defn }) ->+        in if isDataConName name+           then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d))+           else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d))+      TyClD FamDecl {}+        | isValName name+        , Just (famInst:_) <- M.lookup name declMap+        -> extractDecl declMap name famInst+      InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body =+                             FamEqn { feqn_tycon = L _ n+                                    , feqn_pats  = tys+                                    , feqn_rhs   = defn }}))) ->         SigD <$> extractRecSel name 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+        let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))+                               <- insts+                             -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)+                           , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))+                           , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)+                           , L _ n <- ns+                           , selectorFieldOcc n == name                       ]         in case matches of-          [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)+          [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0)           _ -> error "internal: extractDecl (ClsInstD)"       _ -> error "internal: extractDecl" -extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name]-              -> LSig Name++extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn+extractPatternSyn nm t tvs cons =+  case filter matches cons of+    [] -> error "extractPatternSyn: constructor pattern not found"+    con:_ -> 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 getConDetails con of+            PrefixCon args' -> args'+            RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields+            InfixCon arg1 arg2 -> [arg1, arg2]+        typ = longArrow args (data_ty con)+        typ' =+          case con of+            ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)+            _ -> typ+        typ'' = noLoc (HsQualTy (noLoc []) typ')+    in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')++  longArrow :: [LHsType name] -> LHsType name -> LHsType name+  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs++  data_ty con+    | ConDeclGADT{} <- con = hsib_body $ con_type con+    | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs++extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]+              -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found"  extractRecSel nm t tvs (L _ con : rest) =@@ -1013,7 +1110,7 @@       L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))     _ -> extractRecSel nm t tvs rest  where-  matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)]+  matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]   matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds                                  , L l n <- ns, selectorFieldOcc n == nm ]   data_ty@@ -1022,15 +1119,15 @@     | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs  -- | Keep export items with docs.-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]+pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc   where     hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d     hasDoc _ = True  -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]-mkVisibleNames (_, _, _, _, instMap) exports opts+mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name]+mkVisibleNames (_, _, _, instMap) exports opts   | OptHide `elem` opts = []   | otherwise = let ns = concatMap exportName exports                 in seqList ns `seq` ns@@ -1049,12 +1146,12 @@ seqList [] = () seqList (x : xs) = x `seq` seqList xs -mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule+mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule                     -> ErrMsgGhc (Maybe [RichToken])-mkMaybeTokenizedSrc flags tm+mkMaybeTokenizedSrc dflags flags tm     | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of         Just src -> do-            tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src+            tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src))             return $ Just tokens         Nothing -> do             liftErrMsg . tell . pure $ concat@@ -1067,15 +1164,18 @@   where     summary = pm_mod_summary . tm_parsed_module $ tm -mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken]-mkTokenizedSrc ms src = do+mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken]+mkTokenizedSrc dflags ms src = do   -- make sure to read the whole file at once otherwise   -- we run out of file descriptors (see #495)   rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate-  return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc))+  let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc)+  return $ Hyperlinker.enrich src tokens+  where+    filepath = msHsFilePath ms  -- | Find a stand-alone documentation comment by its name.-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)+findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search   where     search [] = do
+ src/Haddock/Interface/Json.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE RecordWildCards #-}+module Haddock.Interface.Json (+    jsonInstalledInterface+  , jsonInterfaceFile+  , renderJson+  ) where++import BasicTypes+import Json+import Module+import Name+import Outputable++import Control.Arrow+import Data.Map (Map)+import Data.Bifunctor+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))])+             , ("doc",  jsonDoc _doc)+             ]++jsonDoc :: Doc Name -> JsonDoc+jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc))++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
@@ -18,7 +18,6 @@   , processModuleHeader   ) where -import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions)@@ -31,23 +30,25 @@ import Name import Outputable ( showPpr ) import RdrName+import EnumSet import RnEnv (dataTcOccs)  processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]-                  -> Maybe (MDoc Name)-processDocStrings dflags gre strs =-  case metaDocConcat $ map (processDocStringParas dflags gre) strs of+                  -> ErrMsgM (Maybe (MDoc Name))+processDocStrings dflags gre strs = do+  mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags 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 { _version = Nothing }, _doc = DocEmpty } -> pure Nothing+    x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags gre (HsDocString fs) =-  overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs)+  overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) =   rename dflags gre $ parseString dflags (unpackFS fs) @@ -60,14 +61,16 @@       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+        !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)+      flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags)   return (hmi { hmi_safety = Just $ showPpr dflags safety               , hmi_language = language dflags               , hmi_extensions = flags@@ -82,12 +85,12 @@ -- 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 :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) rename dflags gre = rn   where     rn d = case d of-      DocAppend a b -> DocAppend (rn a) (rn b)-      DocParagraph doc -> DocParagraph (rn doc)+      DocAppend a b -> DocAppend <$> rn a <*> rn b+      DocParagraph doc -> DocParagraph <$> rn doc       DocIdentifier x -> do         -- Generate the choices for the possible kind of thing this         -- is.@@ -100,7 +103,7 @@           -- We found no names in the env so we start guessing.           [] ->             case choices of-              [] -> DocMonospaced (DocString (showPpr dflags x))+              [] -> pure (DocMonospaced (DocString (showPpr dflags x)))               -- 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,37 +112,38 @@               -- 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:_ -> pure (outOfScope dflags a)            -- There is only one name in the environment that matches so           -- use it.-          [a] -> DocIdentifier a+          [a] -> pure (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:b:_ | isTyConName a -> pure (DocIdentifier a)+                | otherwise -> pure (DocIdentifier b) -      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)+      DocWarning doc -> DocWarning <$> rn doc+      DocEmphasis doc -> DocEmphasis <$> rn doc+      DocBold doc -> DocBold <$> rn doc+      DocMonospaced doc -> DocMonospaced <$> rn doc+      DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs+      DocOrderedList docs -> DocOrderedList <$> traverse rn docs+      DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list+      DocCodeBlock doc -> DocCodeBlock <$> rn doc+      DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)+      DocModule str -> pure (DocModule str)+      DocHyperlink l -> pure (DocHyperlink 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
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -37,21 +37,22 @@       (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+      (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5+      (maintainerOpt,str7) = getKey "Maintainer" str6+      (stabilityOpt,str8) = getKey "Stability" str7+      (portabilityOpt,str9) = getKey "Portability" str8     in (HaddockModInfo {           hmi_description = parseString dflags <$> descriptionOpt,           hmi_copyright = copyrightOpt,-          hmi_license = licenseOpt `mplus` licenceOpt,+          hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` 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 str9)  -- | This function is how we read keys. --
src/Haddock/Interface/Rename.hs view
@@ -21,6 +21,8 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name+import RdrName (RdrName(Exact))+import PrelNames (eqTyCon_RDR)  import Control.Applicative import Control.Monad hiding (mapM)@@ -59,11 +61,18 @@                     (missingNames1 ++ missingNames2 ++ missingNames3                      ++ missingNames4 ++ missingNames5) -      -- 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+      -- Filter out certain built in type constructors using their string+      -- representation.+      --+      -- Note that since the renamed AST represents equality constraints as+      -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to+      -- manually filter out 'eqTyCon_RDR' (aka @~@).+      strings = [ pretty dflags n+                | n <- missingNames+                , not (isSystemName n)+                , not (isBuiltInSyntax n)+                , Exact n /= eqTyCon_RDR+                ]    in do     -- report things that we couldn't link to. Only do this for non-hidden@@ -147,7 +156,7 @@ renameL = mapM rename  -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]+renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem  @@ -172,22 +181,22 @@ 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 :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType -renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName)+renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) renameLSigWcType = renameWc (renameImplicit renameLType) -renameLKind :: LHsKind Name -> RnM (LHsKind DocName)+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 :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc NoSig)     = return (L loc NoSig) renameFamilyResultSig (L loc (KindSig ki))@@ -197,17 +206,17 @@     = do { bndr' <- renameLTyVarBndr bndr          ; return (L loc (TyVarSig bndr')) } -renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName)+renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))     = do { lhs' <- renameL lhs          ; rhs' <- mapM renameL rhs          ; return (L loc (InjectivityAnn 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)+renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of   HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do     tyvars'   <- mapM renameLTyVarBndr tyvars@@ -264,17 +273,28 @@   HsCoreTy a              -> pure (HsCoreTy a)   HsExplicitListTy i a b  -> HsExplicitListTy i a <$> mapM renameLType b   HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b-  HsSpliceTy _ _          -> error "renameType: HsSpliceTy"+  HsSpliceTy s _          -> renameHsSpliceTy s   HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a   HsAppsTy _              -> error "renameType: HsAppsTy" -renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName)+-- | Rename splices, but _only_ those that turn out to be for types.+-- I think this is actually safe for our possible inputs:+--+--  * the input is from after GHC's renamer, so should have an 'HsSpliced'+--  * the input is typechecked, and only 'HsSplicedTy' should get through that+--+renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI)+renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t+renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy"+renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"++renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, 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 -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)+renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar (L l n)))   = do { n' <- rename n        ; return (L loc (UserTyVar (L l n'))) }@@ -283,18 +303,17 @@        ; kind' <- renameLKind kind        ; return (L loc (KindedTyVar (L lv n') kind')) } -renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])+renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do   context' <- mapM renameLType context   return (L loc context') -renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName)+renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) 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   types <- mapM renameType ihdTypes   itype <- case ihdInstType of     ClassInst { .. } -> ClassInst@@ -306,21 +325,20 @@     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 Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)]+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     d' <- renameTyClD d@@ -339,10 +357,10 @@     return (DerivD d')   _ -> error "renameDecl" -renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))+renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) renameLThing fn (L loc x) = return . L 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@@ -384,7 +402,7 @@      renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)+renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname                              , fdTyVars = ltyvars                              , fdFixity = fixity@@ -402,8 +420,8 @@                        , fdInjectivityAnn = injectivity' })  -renamePseudoFamilyDecl :: PseudoFamilyDecl Name-                       -> RnM (PseudoFamilyDecl DocName)+renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn+                       -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) =  PseudoFamilyDecl     <$> renameFamilyInfo pfdInfo     <*> renameL pfdLName@@ -411,14 +429,14 @@     <*> 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 GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType                            , dd_kindSig = k, dd_cons = cons }) = do     lcontext' <- renameLContext lcontext@@ -429,7 +447,7 @@                        , dd_kindSig = k', dd_cons = cons'                        , dd_derivs = noLoc [] }) -renameCon :: ConDecl Name -> RnM (ConDecl DocName)+renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars                            , con_cxt = lcontext, con_details = details                            , con_doc = mbldoc }) = do@@ -460,19 +478,19 @@       return (decl { con_names = lnames'                    , con_type = lty', con_doc = mbldoc' }) -renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)+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') -renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName)+renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc lbl sel)) = do   sel' <- rename sel   return $ L l (FieldOcc lbl sel') -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@@ -496,7 +514,7 @@   _ -> error "expected TypeSig"  -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)+renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport lname ltype co x) = do   lname' <- renameL lname   ltype' <- renameLSigType ltype@@ -507,7 +525,7 @@   return (ForeignExport lname' ltype' co x)  -renameInstD :: InstDecl Name -> RnM (InstDecl DocName)+renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do   d' <- renameClsInstD d   return (ClsInstD { cid_inst = d' })@@ -518,7 +536,7 @@   d' <- renameDataFamInstD d   return (DataFamInstD { dfid_inst = d' }) -renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName)+renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty                         , deriv_strategy = strat                         , deriv_overlap_mode = omode }) = do@@ -527,7 +545,7 @@                     , deriv_strategy = strat                     , deriv_overlap_mode = omode }) -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)+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@@ -540,45 +558,60 @@                       , 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_eqn = eqn' }) } -renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)-renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs }))-  = do { tc' <- renameL tc-       ; pats' <- renameImplicit (mapM renameLType) pats-       ; rhs' <- renameLType rhs-       ; return (L loc (TyFamEqn { tfe_tycon = tc'-                                 , tfe_pats = pats'-                                 , tfe_fixity = fixity-                                 , tfe_rhs = rhs' })) }+renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)+renameTyFamInstEqn eqn+  = renameImplicit rename_ty_fam_eqn eqn+  where+    rename_ty_fam_eqn+      :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)+      -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))+    rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats+                              , feqn_fixity = fixity, feqn_rhs = rhs })+      = do { tc' <- renameL tc+           ; pats' <- mapM renameLType pats+           ; rhs' <- renameLType rhs+           ; return (FamEqn { feqn_tycon  = tc'+                            , 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_fixity = fixity, tfe_rhs = rhs }))+renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)+renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs+                                    , feqn_fixity = fixity, feqn_rhs = rhs }))   = do { tc'  <- renameL tc        ; tvs' <- renameLHsQTyVars tvs        ; rhs' <- renameLType rhs-       ; return (L loc (TyFamEqn { tfe_tycon = tc'-                                 , tfe_pats = tvs'-                                 , tfe_fixity = fixity-                                 , tfe_rhs = rhs' })) }+       ; return (L loc (FamEqn { feqn_tycon  = tc'+                               , feqn_pats   = tvs'+                               , feqn_fixity = fixity+                               , feqn_rhs    = rhs' })) } -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn })-  = do { tc' <- renameL tc-       ; pats' <- renameImplicit (mapM renameLType) pats-       ; defn' <- renameDataDefn defn-       ; return (DataFamInstDecl { dfid_tycon = tc'-                                 , dfid_pats = pats'-                                 , dfid_fixity = fixity-                                 , dfid_defn = defn', dfid_fvs = placeHolderNames }) }+renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)+renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })+  = do { eqn' <- renameImplicit rename_data_fam_eqn eqn+       ; return (DataFamInstDecl { dfid_eqn = eqn' }) }+  where+    rename_data_fam_eqn+      :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)+      -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))+    rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats+                                , feqn_fixity = fixity, feqn_rhs = defn })+      = do { tc' <- renameL tc+           ; pats' <- mapM renameLType pats+           ; defn' <- renameDataDefn defn+           ; return (FamEqn { feqn_tycon  = tc'+                            , feqn_pats   = pats'+                            , feqn_fixity = fixity+                            , feqn_rhs    = defn' }) }  renameImplicit :: (in_thing -> RnM out_thing)-               -> HsImplicitBndrs Name in_thing-               -> RnM (HsImplicitBndrs DocName out_thing)+               -> HsImplicitBndrs GhcRn in_thing+               -> RnM (HsImplicitBndrs DocNameI out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing })   = do { thing' <- rn_thing thing        ; return (HsIB { hsib_body = thing'@@ -586,21 +619,21 @@                       , hsib_closed = PlaceHolder }) }  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 }) } -renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName)+renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do   inst' <- renameInstHead inst   n' <- rename n   idoc' <- mapM renameDoc idoc   return (inst', idoc',L l n') -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)+renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) renameExportItem item = case item of   ExportModule mdl -> return (ExportModule mdl)   ExportGroup lev id_ doc -> do
src/Haddock/Interface/Specialize.hs view
@@ -17,7 +17,6 @@ import FastString  import Control.Monad-import Control.Monad.Trans.Reader import Control.Monad.Trans.State  import Data.Data@@ -29,27 +28,33 @@ import qualified Data.Set as Set  -- | Instantiate all occurrences of given names with corresponding types.-specialize :: forall name a. (Ord name, DataId name, NamedThing name)+specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))             => Data a-            => [(name, HsType name)] -> a -> a-specialize specs = go+            => [(IdP name, HsType name)] -> a -> a+specialize specs = go spec_map0   where-    go :: forall x. Data x => x -> x-    go = everywhereButType @name $ mkT $ sugar . specialize_ty_var-    specialize_ty_var (HsTyVar _ (L _ name'))+    go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x+    go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map++    strip_kind_sig :: HsType name -> HsType name+    strip_kind_sig (HsKindSig (L _ t) _) = t+    strip_kind_sig typ = typ++    specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name+    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 that is guaranteed to terminate-    -- because a type binder cannot be instantiated with a type that depends-    -- on that binder. i.e. @a -> Maybe a@ is invalid-    spec_map = Map.fromList [ (n, go t) | (n, t) <- specs]+    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 + -- | 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 :: (Ord name, DataId name, NamedThing name)+specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))                      => Data a                      => LHsQTyVars name -> [HsType name]                      -> a -> a@@ -61,14 +66,14 @@     bname (KindedTyVar (L _ name) _) = name  -specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name)+specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))                            => LHsQTyVars name -> [HsType name]                            -> PseudoFamilyDecl name                            -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl =   decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name)+specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))               => LHsQTyVars name -> [HsType name]               -> Sig name               -> Sig name@@ -85,7 +90,7 @@  -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type.-specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name)+specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))                    => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =     ihd { ihdInstType = instType' }@@ -105,11 +110,11 @@ -- 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)+sugar :: forall name. (NamedThing (IdP name), DataId name)       => HsType name -> HsType name sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing name => HsType name -> HsType name+sugarLists :: NamedThing (IdP name) => HsType name -> HsType name sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)     | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp   where@@ -118,7 +123,7 @@ sugarLists typ = typ  -sugarTuples :: NamedThing name => HsType name -> HsType name+sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name sugarTuples typ =     aux [] typ   where@@ -135,7 +140,7 @@     aux _ _ = typ  -sugarOperators :: NamedThing name => HsType name -> HsType name+sugarOperators :: NamedThing (IdP 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@@ -203,8 +208,8 @@   -- | Compute set of free variables of given type.-freeVariables :: forall name. (NamedThing name, DataId name)-              => HsType name -> Set NameRep+freeVariables :: forall name. (NamedThing (IdP name), DataId name)+              => HsType name -> Set Name freeVariables =     everythingWithState Set.empty Set.union query   where@@ -213,7 +218,7 @@             (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)+            | otherwise -> (Set.singleton $ getName name, ctx)         _ -> (Set.empty, ctx)     bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) @@ -225,33 +230,36 @@ -- @(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 :: (Eq (IdP name), DataId name, SetName (IdP name))+       => Set Name-> HsType name -> HsType name+rename fv typ = evalState (renameType typ) env+  where+    env = RenameEnv+      { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv+      , rneSigFVs = Set.map getNameRep $ freeVariables 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' ->+renameType :: (Eq (IdP name), SetName (IdP name))+           => HsType name -> Rename (IdP name) (HsType name)+renameType (HsForAllTy bndrs lt) =     HsForAllTy-        <$> pure bndrs'+        <$> mapM (located renameBinder) bndrs         <*> renameLType lt renameType (HsQualTy lctxt lt) =-  HsQualTy+    HsQualTy         <$> located renameContext lctxt         <*> renameLType lt renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name@@ -281,85 +289,58 @@ renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"  -renameLType :: SetName name => LHsType name -> Rename name (LHsType name)+renameLType :: (Eq (IdP name), SetName (IdP name))+            => LHsType name -> Rename (IdP name) (LHsType name) renameLType = located renameType  -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name]+renameLTypes :: (Eq (IdP name), SetName (IdP name))+             => [LHsType name] -> Rename (IdP name) [LHsType name] renameLTypes = mapM renameLType  -renameContext :: SetName name => HsContext name -> Rename name (HsContext name)+renameContext :: (Eq (IdP name), SetName (IdP name))+              => HsContext name -> Rename (IdP name) (HsContext name) renameContext = renameLTypes -{--renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)-renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname--}+renameBinder :: (Eq (IdP name), SetName (IdP name))+             => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)+renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname+renameBinder (KindedTyVar lname lkind) =+  KindedTyVar <$> located renameName lname <*> located renameType lkind  -renameName :: SetName name => name -> Rename name name+-- | Core renaming logic.+renameName :: (Eq name, 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  @@ -371,15 +352,7 @@   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@@ -389,6 +362,6 @@ located f (L loc e) = L loc <$> f e  -tyVarName :: HsTyVarBndr name -> name+tyVarName :: HsTyVarBndr name -> IdP name tyVarName (UserTyVar name) = unLoc name tyVarName (KindedTyVar (L _ name) _) = name
src/Haddock/InterfaceFile.hs view
@@ -82,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804)-binaryInterfaceVersion = 31+#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805)+binaryInterfaceVersion = 32  binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]@@ -158,7 +158,7 @@ type NameCacheAccessor m = (m NameCache, NameCache -> m ())  -nameCacheFromGhc :: NameCacheAccessor Ghc+nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session )   where     read_from_session = do@@ -373,7 +373,7 @@  instance Binary InstalledInterface where   put_ bh (InstalledInterface modu is_sig info docMap argMap-           exps visExps opts subMap patSynMap fixMap) = do+           exps visExps opts fixMap) = do     put_ bh modu     put_ bh is_sig     put_ bh info@@ -381,8 +381,6 @@     put_ bh exps     put_ bh visExps     put_ bh opts-    put_ bh subMap-    put_ bh patSynMap     put_ bh fixMap    get bh = do@@ -393,12 +391,9 @@     exps    <- get bh     visExps <- get bh     opts    <- get bh-    subMap  <- get bh-    patSynMap <- get bh     fixMap  <- get bh-     return (InstalledInterface modu is_sig info docMap argMap-            exps visExps opts subMap patSynMap fixMap)+            exps visExps opts fixMap)   instance Binary DocOption where@@ -464,6 +459,32 @@         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@@ -547,6 +568,9 @@     put_ bh (DocMathDisplay x) = do             putByte bh 22             put_ bh x+    put_ bh (DocTable x) = do+            putByte bh 23+            put_ bh x      get bh = do             h <- getByte bh@@ -620,6 +644,9 @@               22 -> do                     x <- get bh                     return (DocMathDisplay x)+              23 -> do+                    x <- get bh+                    return (DocTable x)               _ -> error "invalid binary data found in the interface file"
src/Haddock/ModuleTree.hs view
@@ -20,39 +20,41 @@ import Packages      ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) +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 ]+  foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ]   where     modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_))                 | otherwise = Nothing     modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString                                      (lookupPackage dflags (moduleUnitId 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
@@ -25,11 +25,13 @@   sourceUrls,   wikiUrls,   optDumpInterfaceFile,+  optShowInterfaceFile,   optLaTeXStyle,   optMathjax,   qualification,   verbosity,   ghcFlags,+  reexportFlags,   readIfaceArgs,   optPackageName,   optPackageVersion@@ -53,6 +55,7 @@ --  | Flag_DocBook   | Flag_ReadInterface String   | Flag_DumpInterface String+  | Flag_ShowInterface String   | Flag_Heading String   | Flag_Html   | Flag_Hoogle@@ -68,6 +71,7 @@   | Flag_WikiEntityURL String   | Flag_LaTeX   | Flag_LaTeXStyle String+  | Flag_QuickJumpIndex   | Flag_HyperlinkedSource   | Flag_SourceCss String   | Flag_Mathjax String@@ -82,6 +86,8 @@   | Flag_GenIndex   | Flag_IgnoreAllExports   | Flag_HideModule String+  | Flag_ShowModule String+  | Flag_ShowAllModules   | Flag_ShowExtensions String   | Flag_OptGhc String   | Flag_GhcLibDir String@@ -96,6 +102,7 @@   | Flag_NoPrintMissingDocs   | Flag_PackageName String   | Flag_PackageVersion String+  | Flag_Reexport String   deriving (Eq, Show)  @@ -112,6 +119,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 +131,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")@@ -173,6 +184,10 @@       "behave as if all modules have the\nignore-exports atribute",     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,6 +205,8 @@       "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")@@ -270,6 +287,8 @@ 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 ]@@ -303,6 +322,9 @@  ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ]++reexportFlags :: [Flag] -> [String]+reexportFlags flags = [ option | Flag_Reexport option <- flags ]   readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
src/Haddock/Types.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.PlaceHolder- {-# OPTIONS_GHC -fno-warn-orphans #-}  -----------------------------------------------------------------------------@@ -59,7 +57,7 @@ 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 DeclMap       = Map Name [LHsDecl GhcRn] type InstMap       = Map SrcSpan Name type FixMap        = Map Name Fixity type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources@@ -101,10 +99,7 @@     -- | 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])--    -- | Bundled pattern synonym declarations for specific types.-  , ifaceBundledPatSynMap :: !(Map Name [Name])+  , ifaceDeclMap         :: !(Map Name [LHsDecl GhcRn])      -- | Documentation of declarations originating from the module (including     -- subordinates).@@ -116,11 +111,10 @@   , 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]@@ -138,8 +132,8 @@   , ifaceFamInstances    :: ![FamInst]      -- | 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.@@ -186,10 +180,6 @@     -- | Haddock options for this module (prune, ignore-exports, etc).   , instOptions          :: [DocOption] -  , instSubMap           :: Map Name [Name]--  , instBundledPatSynMap :: Map Name [Name]-     , instFixMap           :: Map Name Fixity   } @@ -205,8 +195,6 @@   , instExports          = ifaceExports          interface   , instVisibleExports   = ifaceVisibleExports   interface   , instOptions          = ifaceOptions          interface-  , instSubMap           = ifaceSubMap           interface-  , instBundledPatSynMap = ifaceBundledPatSynMap interface   , instFixMap           = ifaceFixMap           interface   } @@ -225,21 +213,21 @@         expItemDecl :: !(LHsDecl name)          -- | Bundled patterns for a data type declaration-      , expItemPats :: ![(HsDecl name, DocForDecl name)]+      , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))]          -- | Maybe a doc comment, and possibly docs for arguments (if this         -- decl is a function or type-synonym).-      , expItemMbDoc :: !(DocForDecl name)+      , expItemMbDoc :: !(DocForDecl (IdP name))          -- | Subordinate names, possibly with documentation.-      , expItemSubDocs :: ![(name, DocForDecl name)]+      , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))]          -- | Instances relevant to this declaration, possibly with         -- documentation.       , expItemInstances :: ![DocInstance name]          -- | Fixity decls relevant to this declaration (including subordinates).-      , expItemFixities :: ![(name, Fixity)]+      , expItemFixities :: ![(IdP name, Fixity)]          -- | Whether the ExportItem is from a TH splice or not, for generating         -- the appropriate type of Source link.@@ -249,10 +237,10 @@   -- | 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.@@ -265,11 +253,11 @@       , 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@@ -309,15 +297,11 @@      -- 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 IdP DocNameI = DocName + instance NamedThing DocName where   getName (Documented name _) = name   getName (Undocumented name) = name@@ -363,7 +347,7 @@   | TypeInst  (Maybe (HsType name)) -- ^ Body (right-hand side)   | DataInst (TyClDecl name)        -- ^ Data constructors -instance (OutputableBndrId a)+instance (SourceTextX a, OutputableBndrId a)          => Outputable (InstType a) where   ppr (ClassInst { .. }) = text "ClassInst"       <+> ppr clsiCtx@@ -382,7 +366,7 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl     { pfdInfo :: FamilyInfo name-    , pfdLName :: Located name+    , pfdLName :: Located (IdP name)     , pfdTyVars :: [LHsType name]     , pfdKindSig :: LFamilyResultSig name     }@@ -404,13 +388,12 @@   -- | 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)) --- | 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     }@@ -443,6 +426,8 @@ type Doc id = DocH (ModuleName, OccName) id type MDoc id = MetaDoc (ModuleName, OccName) id +type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a+ instance (NFData a, NFData mod)          => NFData (DocH mod a) where   rnf doc = case doc of@@ -469,6 +454,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@@ -489,39 +475,19 @@ 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-  }-- data HaddockModInfo name = HaddockModInfo   { hmi_description :: Maybe (Doc name)   , hmi_copyright   :: Maybe String@@ -605,6 +571,12 @@     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  ----------------------------------------------------------------------------- -- * Error handling@@ -688,14 +660,14 @@ -- * Pass sensitive 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+type instance PostRn DocNameI NameSet        = PlaceHolder+type instance PostRn DocNameI Fixity         = PlaceHolder+type instance PostRn DocNameI Bool           = PlaceHolder+type instance PostRn DocNameI Name           = DocName+type instance PostRn DocNameI (Located Name) = Located DocName+type instance PostRn DocNameI [Name]         = PlaceHolder+type instance PostRn DocNameI DocName        = DocName -type instance PostTc DocName Kind     = PlaceHolder-type instance PostTc DocName Type     = PlaceHolder-type instance PostTc DocName Coercion = PlaceHolder+type instance PostTc DocNameI Kind     = PlaceHolder+type instance PostTc DocNameI Type     = PlaceHolder+type instance PostTc DocNameI Coercion = PlaceHolder
src/Haddock/Utils.hs view
@@ -20,10 +20,11 @@    -- * Filename utilities   moduleHtmlFile, moduleHtmlFile',-  contentsHtmlFile, indexHtmlFile,+  contentsHtmlFile, indexHtmlFile, indexJsonFile,   moduleIndexFrameName, mainFrameName, synopsisFrameName,   subIndexHtmlFile,-  jsFile,+  haddockJsFile, jsQuickJumpFile,+  quickJumpCssFile,    -- * Anchor and URL utilities   moduleNameUrl, moduleNameUrl', moduleUrl,@@ -37,8 +38,6 @@   html_xrefs_ref, html_xrefs_ref',    -- * Doc markup-  markup,-  idMarkup,   mkMeta,    -- * List utilities@@ -125,12 +124,12 @@ mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name+mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) -addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name+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 lname (mkEmptySigWcType (go (hsSigType ltype))))@@ -148,7 +147,7 @@  addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name]+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs   = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv)))     | tv <- hsQTvExplicit tvs ]@@ -158,7 +157,7 @@ --------------------------------------------------------------------------------  -restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name+restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of   TyClD d | isDataDecl d  ->     TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })@@ -167,7 +166,7 @@                tcdATs = restrictATs names (tcdATs d) })   _ -> decl -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name+restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })   | DataType <- new_or_data   = defn { dd_cons = restrictCons names cons }@@ -177,7 +176,7 @@       [con] -> defn { dd_cons = [con] }       _ -> error "Should not happen" -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]+restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] 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) =@@ -197,7 +196,7 @@         h98ConDecl c@ConDeclGADT{} = c'           where             (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c)-            c' :: ConDecl Name+            c' :: ConDecl GhcRn             c' = ConDeclH98                    { con_name = head (con_names c)                    , con_qvars = Just $ HsQTvs { hsq_implicit = mempty@@ -208,18 +207,18 @@                    , con_doc = con_doc c                    } -        field_avail :: LConDeclField Name -> Bool+        field_avail :: LConDeclField GhcRn -> 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 :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] restrictDecls names = mapMaybe (filterLSigNames (`elem` names))  -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]+restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]  emptyHsQTvs :: LHsQTyVars Name@@ -256,9 +255,10 @@     Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]  -contentsHtmlFile, indexHtmlFile :: String+contentsHtmlFile, indexHtmlFile, indexJsonFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html"+indexJsonFile = "doc-index.json"   @@ -326,10 +326,15 @@ -------------------------------------------------------------------------------  -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. -------------------------------------------------------------------------------@@ -447,71 +452,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,225 @@+{-# LANGUAGE OverloadedStrings #-}++-- | 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)+    )+    where++import Data.Char+import Data.Int+import Data.String+import Data.Word+import Data.List+import Data.Monoid++import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB++-- 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)++-- | A key\/value pair for an 'Object'+type Pair = (String, Value)++-- | A JSON \"object\" (key/value map).+type Object = [Pair]++infixr 8 .=++-- | A key-value pair for encoding a JSON object.+(.=) :: ToJSON v => String -> v -> Pair+k .= v  = (k, toJSON v)++-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object++instance IsString Value where+  fromString = String+++-- | 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` ['\\','"']
test/Haddock/Backends/Hyperlinker/ParserSpec.hs view
@@ -4,95 +4,149 @@ import Test.Hspec import Test.QuickCheck +import qualified GHC+import Control.Monad.IO.Class++import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types +withDynFlags :: (GHC.DynFlags -> IO ()) -> IO ()+withDynFlags cont = do+  libDir <- fmap snd (getGhcDirs [])+  GHC.runGhc (Just libDir) $ do+    dflags <- GHC.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 "" src) `shouldSatisfy` (>= 0) -    it "retains file layout" $-        property $ \src -> concatMap tkValue (parse src) == src+    it "retains file layout" $ \dflags ->+        property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src      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"+                [TkSpace, 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+            (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 :: String -> [TokenType] -> GHC.DynFlags -> Expectation+    shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens