haddock-api 2.25.1 → 2.26.0

raw patch · 33 files changed

+1273/−1619 lines, 33 filesdep +ghc-boot-thdep −parsecdep ~basedep ~ghcdep ~haddock-library

Dependencies added: ghc-boot-th

Dependencies removed: parsec

Dependency ranges changed: base, ghc, haddock-library, hspec

Files

• haddock-api.cabal +11/−16
• resources/html/haddock-bundle.min.js +1/−1
• src/Haddock.hs +52/−86
• src/Haddock/Backends/Hoogle.hs +85/−65
• src/Haddock/Backends/Hyperlinker.hs +4/−3
• src/Haddock/Backends/Hyperlinker/Parser.hs +13/−12
• src/Haddock/Backends/Hyperlinker/Utils.hs +1/−1
• src/Haddock/Backends/LaTeX.hs +93/−61
• src/Haddock/Backends/Xhtml.hs +36/−101
• src/Haddock/Backends/Xhtml/Decl.hs +135/−109
• src/Haddock/Backends/Xhtml/DocMarkup.hs +1/−1
• src/Haddock/Backends/Xhtml/Layout.hs +6/−6
• src/Haddock/Backends/Xhtml/Names.hs +3/−2
• src/Haddock/Backends/Xhtml/Themes.hs +3/−4
• src/Haddock/Backends/Xhtml/Types.hs +0/−11
• src/Haddock/Convert.hs +157/−135
• src/Haddock/GhcUtils.hs +144/−144
• src/Haddock/Interface.hs +41/−32
• src/Haddock/Interface/AttachInstances.hs +5/−7
• src/Haddock/Interface/Create.hs +128/−106
• src/Haddock/Interface/Json.hs +1/−1
• src/Haddock/Interface/LexParseRn.hs +15/−11
• src/Haddock/Interface/Rename.hs +110/−100
• src/Haddock/Interface/Specialize.hs +85/−41
• src/Haddock/InterfaceFile.hs +4/−6
• src/Haddock/Options.hs +6/−14
• src/Haddock/Parser.hs +3/−2
• src/Haddock/Syb.hs +16/−1
• src/Haddock/Types.hs +89/−40
• src/Haddock/Utils.hs +3/−0
• src/Haddock/Utils/Json.hs +22/−356
• src/Haddock/Utils/Json/Parser.hs +0/−102
• src/Haddock/Utils/Json/Types.hs +0/−42

@@ -1,19 +1,19 @@ cabal-version:        2.0 name:                 haddock-api-version:              2.25.1+version:              2.26.0 synopsis:             A documentation-generation tool for Haskell libraries description:          Haddock is a documentation-generation tool for Haskell                       libraries license:              BSD2 license-file:         LICENSE author:               Simon Marlow, David Waern-maintainer:           Hécate Moonlight <hecate@glitchbra.in>, Alex Biehl <alexbiehl@gmail.com>+maintainer:           Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage:             http://www.haskell.org/haddock/ bug-reports:          https://github.com/haskell/haddock/issues copyright:            (c) Simon Marlow, David Waern category:             Documentation build-type:           Simple-tested-with:          GHC==9.0.*+tested-with:          GHC==9.2.*  extra-source-files:   CHANGES.md@@ -43,12 +43,11 @@   default-language: Haskell2010    -- this package typically supports only single major versions-  build-depends: base            ^>= 4.15.0-               , ghc             ^>= 9.0+  build-depends: base            ^>= 4.16.0+               , ghc             ^>= 9.2                , ghc-paths       ^>= 0.1.0.9-               , haddock-library ^>= 1.10.0+               , haddock-library ^>= 1.9.0                , xhtml           ^>= 3000.2.2-               , parsec          ^>= 3.1.13.0    -- Versions for the dependencies below are transitively pinned by   -- the non-reinstallable `ghc` package and hence need no version@@ -94,8 +93,6 @@     Haddock.Parser     Haddock.Utils     Haddock.Utils.Json-    Haddock.Utils.Json.Types-    Haddock.Utils.Json.Parser     Haddock.Backends.Xhtml     Haddock.Backends.Xhtml.Decl     Haddock.Backends.Xhtml.DocMarkup@@ -172,20 +169,17 @@     Haddock.Types     Haddock.Utils     Haddock.Utils.Json-    Haddock.Utils.Json.Types-    Haddock.Utils.Json.Parser     Haddock.Version     Paths_haddock_api     Haddock.Backends.Hyperlinker.ParserSpec     Haddock.Backends.Hyperlinker.Parser     Haddock.Backends.Hyperlinker.Types -  build-depends: ghc             ^>= 9.0+  build-depends: ghc             ^>= 9.2                , ghc-paths       ^>= 0.1.0.12-               , haddock-library ^>= 1.10.0+               , haddock-library ^>= 1.9.0                , xhtml           ^>= 3000.2.2-               , hspec           >= 2.4.4 && < 2.8-               , parsec       ^>= 3.1.13.0+               , hspec           ^>= 2.8                , QuickCheck      >= 2.11  && ^>= 2.14    -- Versions for the dependencies below are transitively pinned by@@ -200,11 +194,12 @@                , exceptions                , filepath                , ghc-boot+               , ghc-boot-th                , mtl                , transformers    build-tool-depends:-    hspec-discover:hspec-discover >= 2.4.4 && < 2.8+    hspec-discover:hspec-discover ^>= 2.8  source-repository head   type:     git

@@ -1,2 +1,2 @@-!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e<l.length;e++)c(l[e]);return c}({1:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0}),n.setCookie=function(e,t){document.cookie=e+"="+encodeURIComponent(t)+";path=/;"},n.clearCookie=function(e){document.cookie=e+"=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"},n.getCookie=function(e){for(var t=e+"=",n=document.cookie.split(";"),o=0;o<n.length;o++){for(var r=n[o];" "==r.charAt(0);)r=r.substring(1,r.length);if(0==r.indexOf(t))return decodeURIComponent(r.substring(t.length,r.length))}return null}},{}],2:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i,s,a=e("preact"),l=a.h,c=a.Component;(s=i||(i={}))[s.Closed=0]="Closed",s[s.Open=1]="Open";var u={defaultInstanceState:i.Open,rememberToggles:!0},d=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return l("li",null,l("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(c);function h(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),a.render(l(d,{onClick:e,title:"Instances"}),t,n)}var p=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.componentWillMount=function(){var t=this;document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){t.state.isVisible&&"Escape"===e.key&&t.hide()})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||this.setState({isVisible:!0})},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){return l("div",{id:"preferences",class:t.isVisible?"":"hidden"},l("div",{id:"preferences-menu",class:"dropdown-menu",onMouseDown:function(e){e.stopPropagation()}},l(b,null)))},t}(c);function f(){var e=JSON.stringify(u);try{localStorage.setItem("global",e)}catch(e){}}var v=!1;function g(){if(!v){v=!0;var e=localStorage.getItem("global");if(e)try{var t=JSON.parse(e);u.defaultInstanceState=t.defaultInstanceState,u.rememberToggles=t.rememberToggles}catch(e){if(!(e instanceof SyntaxError||e instanceof TypeError))throw e;localStorage.removeItem("global")}}}function m(t){return function(e){u.defaultInstanceState=t,A(),f(),E(),O()}}function y(e){var t=e.target.checked;u.rememberToggles=t,f(),E(),O()}function _(e){var t=document.getElementById("default-collapse-instances");null!==t&&(t.checked?m(i.Closed)(e):m(i.Open)(e))}function b(){return g(),l("div",null,l("div",null,l("button",{type:"button",onClick:j},"Expand All Instances"),l("button",{type:"button",onClick:P},"Collapse All Instances")),l("div",null,l("input",{type:"checkbox",id:"default-collapse-instances",name:"default-instance-state",checked:u.defaultInstanceState===i.Closed,onClick:_}),l("span",null,"Collapse All Instances By Default")),l("div",null,l("input",{type:"checkbox",id:"remember-toggles",name:"remember-toggles",checked:u.rememberToggles,onClick:y}),l("label",{for:"remember-toggles"},"Remember Manually Collapsed/Expanded Instances")))}var k={};function S(e){var t=k[e];if(null==t)throw new Error("could not find <details> element with id '"+e+"'");return t}function x(){return u.defaultInstanceState==i.Open}function w(e){for(var t=S(e.target.id),n=t.element.open,o=0,r=t.toggles;o<r.length;o++){var i=r[o];i.classList.contains("details-toggle-control")&&(i.classList.add(n?"collapser":"expander"),i.classList.remove(n?"expander":"collapser"))}}function C(e){var t=e.getAttribute("data-details-id");if(!t)throw new Error("element with class "+e+" has no 'data-details-id' attribute!");return t}function L(e){var t=S(C(e)).element;t.open=!t.open}var M="local-details-config:";function I(){return M+document.location.pathname}function E(){for(var e=[],t=0;t<localStorage.length;++t){var n=localStorage.key(t);null!==n&&n.startsWith(M)&&e.push(n)}e.forEach(function(e){localStorage.removeItem(e)})}function O(){if(u.rememberToggles){var e=Array.prototype.slice.call(document.getElementsByClassName("instances details-toggle details-toggle-control")),n=[];e.forEach(function(e){var t=C(e);document.getElementById(t).open!=x()&&n.push(t)});var t=JSON.stringify(n);try{localStorage.setItem(I(),t)}catch(e){}}}function A(){switch(u.defaultInstanceState){case i.Closed:N(!0);break;case i.Open:N(!1)}}function T(e){e.preventDefault(),L(e.currentTarget),O()}function N(o){var e=document.getElementsByClassName("subs instances");[].forEach.call(e,function(e){var t=o?"collapser":"expander",n=e.getElementsByClassName("instances "+t)[0];n&&L(n)})}function P(){N(!0),O()}function j(){N(!1),O()}n.init=function(e){!function(){for(var e=0,t=Array.prototype.slice.call(document.getElementsByTagName("details"));e<t.length;e++){var n=t[e];"string"==typeof n.id&&0<n.id.length&&(k[n.id]={element:n,toggles:[]},n.addEventListener("toggle",w))}}(),Array.prototype.slice.call(document.getElementsByClassName("details-toggle")).forEach(function(e){var t=S(C(e));t.toggles.push(e),e.addEventListener("click",T),e.classList.contains("details-toggle-control")&&e.classList.add(t.element.open?"collapser":"expander")}),function(){if(g(),A(),u.rememberToggles){var e=localStorage.getItem(I());if(e)try{JSON.parse(e).forEach(function(e){S(e).element.open=!x()})}catch(e){if(!(e instanceof SyntaxError||e instanceof TypeError))throw e;localStorage.removeItem(I())}}}(),a.render(l(p,{showHideTrigger:e||h}),document.body)}},{preact:7}],3:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0});var o,r=e("./style-menu"),i=e("./details-helper"),s=e("./quick-jump");o=function(){document.body.classList.add("js-enabled"),r.init(),i.init();var e=document.getElementById("head"),t=".";null!==e&&(t=e.getAttribute("data-base-url")||"."),s.init(t)},"interactive"===document.readyState?o():document.addEventListener("readystatechange",function(){"interactive"===document.readyState&&o()})},{"./details-helper":2,"./quick-jump":4,"./style-menu":5}],4:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("fuse.js"),s=e("preact"),a=s.h,l=s.Component;var c=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);function u(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),s.render(a(c,{onClick:e,title:"Quick Jump"}),t,n)}function d(e,t){return t.length<=e?t:t.slice(0,e)}var h=function(t){function e(){var e=null!==t&&t.apply(this,arguments)||this;return e.linkIndex=0,e.focusPlease=!1,e.navigatedByKeyboard=!1,e}return r(e,t),e.prototype.componentWillMount=function(){var e,t,n,o,r=this;this.setState({searchString:"",isVisible:!1,expanded:{},activeLinkIndex:-1,moduleResults:[]}),e=this.props.baseUrl+"/doc-index.json",t=function(e){r.setState({fuse:new i(e,{threshold:.25,caseSensitive:!0,includeScore:!0,tokenize:!0,keys:[{name:"name",weight:.7},{name:"module",weight:.3}]}),moduleResults:[]})},n=function(e){console&&console.error("could not load 'doc-index.json' for searching",e),r.setState({failedLoading:!0})},(o=new XMLHttpRequest).onreadystatechange=function(){if(o.readyState===XMLHttpRequest.DONE)if(200===o.status){if(t)try{t(JSON.parse(o.responseText))}catch(e){n(o)}}else n&&n(o)},o.open("GET",e,!0),o.send(),document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){r.state.isVisible&&("Escape"===e.key?r.hide():"ArrowUp"===e.key||"k"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(-1)):"ArrowDown"===e.key||"j"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(1)):"Enter"===e.key&&0<=r.state.activeLinkIndex&&r.followActiveLink()),"s"===e.key&&"input"!==e.target.tagName.toLowerCase()&&(e.preventDefault(),r.show())})},e.prototype.hide=function(){this.setState({isVisible:!1,searchString:""})},e.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},e.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},e.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},e.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},e.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t=this.state.fuse.search(e),o={};t.forEach(function(e){var t=e.item.module;(o[t]||(o[t]=[])).push(e)});var r=[],n=function(e){var t=o[e],n=0;t.forEach(function(e){n+=1/e.score}),r.push({module:e,totalScore:1/n,items:t})};for(var i in o)n(i);r.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:r})},e.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.top<t&&(this.searchResults.scrollTop-=t-e.top+80)}this.focusPlease&&this.input&&this.input.focus(),this.navigatedByKeyboard=!1,this.focusPlease=!1},e.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},e.prototype.render=function(e,t){var r=this;if(t.failedLoading){var n="file:"==window.location.protocol;return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-results"},a("p",{class:"error"},"Failed to load file 'doc-index.json' containing definitions in this package."),n?a("p",{class:"error"},"To use quick jump, load this page with HTTP (from a local static file web server) instead of using the ",a("code",null,"file://")," protocol. (For security reasons, it is not possible to fetch auxiliary files using JS in a HTML page opened with ",a("code",null,"file://"),".)"):[]))}this.linkIndex=0;var o=function(e){e.stopPropagation()},i=d(10,t.moduleResults).map(function(e){return r.renderResultsInModule(e)});return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-form",onMouseDown:o},a("input",{placeholder:"Search in package by name",ref:function(e){r.input=e},onFocus:this.show.bind(this),onClick:this.show.bind(this),onInput:this.updateResults.bind(this)})),a("div",{id:"search-results",ref:function(e){r.searchResults=e},onMouseDown:o,onMouseOver:function(e){for(var t=e.target;t&&"function"==typeof t.getAttribute;){var n=t.getAttribute("data-link-index");if("string"==typeof n){var o=parseInt(n,10);r.setState({activeLinkIndex:o});break}t=t.parentNode}}},""===t.searchString?[a(v,null),a(f,null)]:0==i.length?a(g,{searchString:t.searchString}):a("ul",null,i)))},e.prototype.renderResultsInModule=function(e){var n=this,t=e.items,o=e.module,r=this.state.expanded[o]||t.length<=10,i=r?t:d(8,t);return a("li",{class:"search-module"},a("h4",null,o),a("ul",null,i.map(function(e){return t=e.item,a("li",{class:"search-result"},n.navigationLink(n.props.baseUrl+"/"+t.link,{},a(p,{html:t.display_html})));var t}),r?[]:a("li",{class:"more-results"},this.actionLink(function(){var e=Object.assign({},n.state.expanded);e[o]=!0,n.setState({expanded:e})},{},"show "+(t.length-i.length)+" more results from this module"))))},e.prototype.navigationLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=Object.assign({href:e,onClick:this.hide.bind(this)},t);return this.menuLink.apply(this,[i,function(){window.location.href=e,n.hide()}].concat(o))},e.prototype.actionLink=function(t,e){for(var n=[],o=2;o<arguments.length;o++)n[o-2]=arguments[o];var r=Object.assign({href:"#",onClick:function(e){e.preventDefault(),t()}},e);return this.menuLink.apply(this,[r,t].concat(n))},e.prototype.menuLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=this.linkIndex;i===this.state.activeLinkIndex&&(e.class=(e.class?e.class+" ":"")+"active-link",e.ref=function(e){e&&(n.activeLink=e)},this.activeLinkAction=t);var s=Object.assign({"data-link-index":i},e);return this.linkIndex+=1,a.apply(void 0,["a",s].concat(o))},e}(l),p=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.shouldComponentUpdate=function(e){return this.props.html!==e.html},t.prototype.render=function(e){return a("div",{dangerouslySetInnerHTML:{__html:e.html}})},t}(l);function f(){return a("table",{class:"keyboard-shortcuts"},a("tr",null,a("th",null,"Key"),a("th",null,"Shortcut")),a("tr",null,a("td",null,a("span",{class:"key"},"s")),a("td",null,"Open this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"esc")),a("td",null,"Close this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"↓"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"j")),a("td",null,"Move down in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↑"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"k")),a("td",null,"Move up in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↵")),a("td",null,"Go to active search result")))}function v(){return a("p",null,"You can find any exported type, constructor, class, function or pattern defined in this package by (approximate) name.")}function g(e){var t=[a("p",null,"Your search for '",e.searchString,"' produced the following list of results: ",a("code",null,"[]"),"."),a("p",null,a("code",null,"Nothing")," matches your query for '",e.searchString,"'."),a("p",null,a("code",null,"Left \"no matches for '",e.searchString,"'\" :: Either String (NonEmpty SearchResult)"))];return t[(e.searchString||"a").charCodeAt(0)%t.length]}function m(e,t){s.render(a(h,{baseUrl:e||".",showHideTrigger:t||u}),document.body)}n.init=m,window.quickNav={init:m}},{"fuse.js":6,preact:7}],5:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("./cookies"),s=e("preact"),a=s.h,l=s.Component;function c(){return Array.prototype.slice.call(document.getElementsByTagName("link")).filter(function(e){return-1!=e.rel.indexOf("style")&&e.title})}function u(e){for(var t=c(),n=null,o=0;o<t.length;o++){var r=t[o];r.disabled=!0,r.title==e&&(n=r)}n?(n.disabled=!1,i.setCookie("haddock-style",e)):(t[0].disabled=!1,i.clearCookie("haddock-style"))}var d=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);var h=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.componentWillMount=function(){var t=this;document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){t.state.isVisible&&"Escape"===e.key&&t.hide()})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||this.setState({isVisible:!0})},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){var n=this;return a("div",{id:"style",class:t.isVisible?"":"hidden"},a("div",{id:"style-menu",class:"dropdown-menu",onMouseDown:function(e){e.stopPropagation()}},e.styles.map(function(t){return a("button",{type:"button",onClick:function(e){n.hide(),u(t)}},t)})))},t}(l);n.init=function(e){var t,n=c().map(function(e){return e.title});(t=i.getCookie("haddock-style"))&&u(t),s.render(a(h,{showHideTrigger:e||function(e){return function(e,t){if(1<e.length){var n=document.querySelector("#page-menu"),o=document.createElement("li");n.appendChild(o),s.render(a(d,{onClick:t,title:"Styles"}),n,o)}}(n,e)},styles:n}),document.body)}},{"./cookies":1,preact:7}],6:[function(e,t,n){var o,r;o=this,r=function(){return function(n){var o={};function r(e){if(o[e])return o[e].exports;var t=o[e]={i:e,l:!1,exports:{}};return n[e].call(t.exports,t,t.exports,r),t.l=!0,t.exports}return r.m=n,r.c=o,r.i=function(e){return e},r.d=function(e,t,n){r.o(e,t)||Object.defineProperty(e,t,{configurable:!1,enumerable:!0,get:n})},r.n=function(e){var t=e&&e.__esModule?function(){return e.default}:function(){return e};return r.d(t,"a",t),t},r.o=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},r.p="",r(r.s=8)}([function(e,t,n){"use strict";e.exports=function(e){return Array.isArray?Array.isArray(e):"[object Array]"===Object.prototype.toString.call(e)}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var u=n(5),d=n(7),_=n(4),r=function(){function y(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.isCaseSensitive,d=void 0!==u&&u,h=t.tokenSeparator,p=void 0===h?/ +/g:h,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,m=void 0===g?1:g;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,y),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:d,tokenSeparator:p,findAllMatches:v,minMatchCharLength:m},this.pattern=this.options.isCaseSensitive?e:e.toLowerCase(),this.pattern.length<=c&&(this.patternAlphabet=_(this.pattern))}return o(y,[{key:"search",value:function(e){if(this.options.isCaseSensitive||(e=e.toLowerCase()),this.pattern===e)return{isMatch:!0,score:0,matchedIndices:[[0,e.length-1]]};var t=this.options,n=t.maxPatternLength,o=t.tokenSeparator;if(this.pattern.length>n)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return d(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l<c;l+=1)e(a[l],s,o);else s&&e(a,s,o);else o.push(a.toString())}else o.push(t);return o}(e,t,[])}},function(e,t,n){"use strict";e.exports=function(){for(var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:[],t=1<arguments.length&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i<s;i+=1){var a=e[i];a&&-1===o?o=i:a||-1===o||(t<=(r=i-1)-o+1&&n.push([o,r]),o=-1)}return e[i-1]&&t<=i-o&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o<n;o+=1)t[e.charAt(o)]=0;for(var r=0;r<n;r+=1)t[e.charAt(r)]|=1<<n-r-1;return t}},function(e,t,n){"use strict";var u=/[\-\[\]\/\{\}\(\)\*\+\?\.\\\^\$\|]/g;e.exports=function(e,t){var n=2<arguments.length&&void 0!==arguments[2]?arguments[2]:/ +/g,o=new RegExp(t.replace(u,"\\$&").replace(n,"|")),r=e.match(o),i=!!r,s=[];if(i)for(var a=0,l=r.length;a<l;a+=1){var c=r[a];s.push([e.indexOf(c),c.length-1])}return{score:i?.5:1,isMatch:i,matchedIndices:s}}},function(e,t,n){"use strict";e.exports=function(e,t){var n=t.errors,o=void 0===n?0:n,r=t.currentLocation,i=void 0===r?0:r,s=t.expectedLocation,a=void 0===s?0:s,l=t.distance,c=void 0===l?100:l,u=o/e.length,d=Math.abs(a-i);return c?u+d/c:d?1:u}},function(e,t,n){"use strict";var V=n(6),D=n(3);e.exports=function(e,t,n,o){for(var r=o.location,i=void 0===r?0:r,s=o.distance,a=void 0===s?100:s,l=o.threshold,c=void 0===l?.6:l,u=o.findAllMatches,d=void 0!==u&&u,h=o.minMatchCharLength,p=void 0===h?1:h,f=i,v=e.length,g=c,m=e.indexOf(t,f),y=t.length,_=[],b=0;b<v;b+=1)_[b]=0;if(-1!==m){var k=V(t,{errors:0,currentLocation:m,expectedLocation:f,distance:a});if(g=Math.min(k,g),-1!==(m=e.lastIndexOf(t,f+y))){var S=V(t,{errors:0,currentLocation:m,expectedLocation:f,distance:a});g=Math.min(S,g)}}m=-1;for(var x=[],w=1,C=y+v,L=1<<y-1,M=0;M<y;M+=1){for(var I=0,E=C;I<E;){V(t,{errors:M,currentLocation:f+E,expectedLocation:f,distance:a})<=g?I=E:C=E,E=Math.floor((C-I)/2+I)}C=E;var O=Math.max(1,f-E+1),A=d?v:Math.min(f+E,v)+y,T=Array(A+2);T[A+1]=(1<<M)-1;for(var N=A;O<=N;N-=1){var P=N-1,j=n[e.charAt(P)];if(j&&(_[P]=1),T[N]=(T[N+1]<<1|1)&j,0!==M&&(T[N]|=(x[N+1]|x[N])<<1|1|x[N+1]),T[N]&L&&(w=V(t,{errors:M,currentLocation:P,expectedLocation:f,distance:a}))<=g){if(g=w,(m=P)<=f)break;O=Math.max(1,2*f-m)}}if(g<V(t,{errors:M+1,currentLocation:f,expectedLocation:f,distance:a}))break;x=T}return{isMatch:0<=m,score:0===w?.001:w,matchedIndices:D(_,p)}}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var i=n(1),R=n(2),V=n(0),r=function(){function U(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.caseSensitive,d=void 0!==u&&u,h=t.tokenSeparator,p=void 0===h?/ +/g:h,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,m=void 0===g?1:g,y=t.id,_=void 0===y?null:y,b=t.keys,k=void 0===b?[]:b,S=t.shouldSort,x=void 0===S||S,w=t.getFn,C=void 0===w?R:w,L=t.sortFn,M=void 0===L?function(e,t){return e.score-t.score}:L,I=t.tokenize,E=void 0!==I&&I,O=t.matchAllTokens,A=void 0!==O&&O,T=t.includeMatches,N=void 0!==T&&T,P=t.includeScore,j=void 0!==P&&P,V=t.verbose,D=void 0!==V&&V;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,U),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:d,tokenSeparator:p,findAllMatches:v,minMatchCharLength:m,id:_,keys:k,includeMatches:N,includeScore:j,shouldSort:x,getFn:C,sortFn:M,verbose:D,tokenize:E,matchAllTokens:A},this.setCollection(e)}return o(U,[{key:"setCollection",value:function(e){return this.list=e}},{key:"search",value:function(e){this._log('---------\nSearch pattern: "'+e+'"');var t=this._prepareSearchers(e),n=t.tokenSearchers,o=t.fullSearcher,r=this._search(n,o),i=r.weights,s=r.results;return this._computeScore(i,s),this.options.shouldSort&&this._sort(s),this._format(s)}},{key:"_prepareSearchers",value:function(){var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o<r;o+=1)t.push(new i(n[o],this.options));return{tokenSearchers:t,fullSearcher:new i(e,this.options)}}},{key:"_search",value:function(){var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:[],t=arguments[1],n=this.list,o={},r=[];if("string"==typeof n[0]){for(var i=0,s=n.length;i<s;i+=1)this._analyze({key:"",value:n[i],record:i,index:i},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t});return{weights:null,results:r}}for(var a={},l=0,c=n.length;l<c;l+=1)for(var u=n[l],d=0,h=this.options.keys.length;d<h;d+=1){var p=this.options.keys[d];if("string"!=typeof p){if(a[p.name]={weight:1-p.weight||1},p.weight<=0||1<p.weight)throw new Error("Key weight has to be > 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,d=void 0===u?[]:u,h=t.resultMap,p=void 0===h?{}:h,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=d.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),k=[],S=0;S<c.length;S+=1){var x=c[S];this._log('\nPattern: "'+x.pattern+'"');for(var w=!1,C=0;C<b.length;C+=1){var L=b[C],M=x.search(L),I={};M.isMatch?(I[L]=M.score,w=g=!0,k.push(M.score)):(I[L]=1,this.options.matchAllTokens||k.push(1)),this._log('Token: "'+L+'", score: '+I[L])}w&&(y+=1)}m=k[0];for(var E=k.length,O=1;O<E;O+=1)m+=k[O];m/=E,this._log("Token score average:",m)}var A=_.score;-1<m&&(A=(A+m)/2),this._log("Score average:",A);var T=!this.options.tokenize||!this.options.matchAllTokens||y>=c.length;if(this._log("\nCheck Matches: "+T),(g||_.isMatch)&&T){var N=p[a];N?N.output.push({key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(V(i))for(var P=0,j=i.length;P<j;P+=1)this._analyze({key:n,arrayIndex:P,value:i[P],record:s,index:a},{resultMap:p,results:v,tokenSearchers:c,fullSearcher:d})}}},{key:"_computeScore",value:function(e,t){this._log("\n\nComputing score:\n");for(var n=0,o=t.length;n<o;n+=1){for(var r=t[n].output,i=r.length,s=1,a=1,l=0;l<i;l+=1){var c=e?e[r[l].key].weight:1,u=(1===c?r[l].score:r[l].score||.001)*c;1!==c?a=Math.min(a,u):s*=r[l].nScore=u}t[n].score=1===a?s:a,this._log(t[n])}}},{key:"_sort",value:function(e){this._log("\n\nSorting...."),e.sort(this.options.sortFn)}},{key:"_format",value:function(e){var t=[];this.options.verbose&&this._log("\n\nOutput:\n\n",JSON.stringify(e));var n=[];this.options.includeMatches&&n.push(function(e,t){var n=e.output;t.matches=[];for(var o=0,r=n.length;o<r;o+=1){var i=n[o];if(0!==i.matchedIndices.length){var s={indices:i.matchedIndices,value:i.value};i.key&&(s.key=i.key),i.hasOwnProperty("arrayIndex")&&-1<i.arrayIndex&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;o<r;o+=1){var i=e[o];if(this.options.id&&(i.item=this.options.getFn(i.item,this.options.id)[0]),n.length){for(var s={item:i.item},a=0,l=n.length;a<l;a+=1)n[a](i,s);t.push(s)}else t.push(i.item)}return t}},{key:"_log",value:function(){var e;this.options.verbose&&(e=console).log.apply(e,arguments)}}]),U}();e.exports=r}])},"object"==typeof n&&"object"==typeof t?t.exports=r():"function"==typeof define&&define.amd?define("Fuse",[],r):"object"==typeof n?n.Fuse=r():o.Fuse=r()},{}],7:[function(e,y,t){!function(){"use strict";function n(e,t){var n,o,r,i,s=d;for(i=arguments.length;2<i--;)u.push(arguments[i]);for(t&&null!=t.children&&(u.length||u.push(t.children),delete t.children);u.length;)if((o=u.pop())&&void 0!==o.pop)for(i=o.length;i--;)u.push(o[i]);else"boolean"==typeof o&&(o=null),(r="function"!=typeof e)&&(null==o?o="":"number"==typeof o?o=String(o):"string"!=typeof o&&(r=!1)),r&&n?s[s.length-1]+=o:s===d?s=[o]:s.push(o),n=r;var a=new c;return a.nodeName=e,a.children=s,a.attributes=null==t?void 0:t,a.key=null==t?void 0:t.key,void 0!==D.vnode&&D.vnode(a),a}function L(e,t){for(var n in t)e[n]=t[n];return e}function i(e){!e.__d&&(e.__d=!0)&&1==p.push(e)&&(D.debounceRendering||r)(t)}function t(){var e,t=p;for(p=[];e=t.pop();)e.__d&&j(e)}function C(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function M(e){var t=L({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var o in n)void 0===t[o]&&(t[o]=n[o]);return t}function I(e){var t=e.parentNode;t&&t.removeChild(e)}function v(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===h.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,l,s):e.removeEventListener(t,l,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e){try{e[t]=null==o?"":o}catch(e){}null!=o&&!1!==o||"spellcheck"==t||e.removeAttribute(t)}else{var a=r&&t!==(t=t.replace(/^xlink:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function l(e){return this.__l[e.type](D.event&&D.event(e)||e)}function E(){for(var e;e=U.pop();)D.afterMount&&D.afterMount(e),e.componentDidMount&&e.componentDidMount()}function O(e,t,n,o,r,i){R++||(g=null!=r&&void 0!==r.ownerSVGElement,m=null!=e&&!("__preactattr_"in e));var s=A(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(m=!1,i||E()),s}function A(e,t,n,o,r){var i=e,s=g;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),T(e,!0))),i.__preactattr_=!0,i;var a,l,c=t.nodeName;if("function"==typeof c)return function(e,t,n,o){var r=e&&e._component,i=r,s=e,a=r&&e._componentConstructor===t.nodeName,l=a,c=M(t);for(;r&&!l&&(r=r.__u);)l=r.constructor===t.nodeName;r&&l&&(!o||r._component)?(P(r,c,3,n,o),e=r.base):(i&&!a&&(V(i),e=s=null),r=N(t.nodeName,c,n),e&&!r.__b&&(r.__b=e,s=null),P(r,c,1,n,o),e=r.base,s&&e!==s&&(s._component=null,T(s,!1)));return e}(e,t,n,o);if(g="svg"===c||"foreignObject"!==c&&g,c=String(c),(!e||!C(e,c))&&(a=c,(l=g?document.createElementNS("http://www.w3.org/2000/svg",a):document.createElement(a)).__n=a,i=l,e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),T(e,!0)}var u=i.firstChild,d=i.__preactattr_,h=t.children;if(null==d){d=i.__preactattr_={};for(var p=i.attributes,f=p.length;f--;)d[p[f].name]=p[f].value}return!m&&h&&1===h.length&&"string"==typeof h[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=h[0]&&(u.nodeValue=h[0]):(h&&h.length||null!=u)&&function(e,t,n,o,r){var i,s,a,l,c,u=e.childNodes,d=[],h={},p=0,f=0,v=u.length,g=0,m=t?t.length:0;if(0!==v)for(var y=0;y<v;y++){var _=u[y],b=_.__preactattr_,k=m&&b?_._component?_._component.__k:b.key:null;null!=k?(p++,h[k]=_):(b||(void 0!==_.splitText?!r||_.nodeValue.trim():r))&&(d[g++]=_)}if(0!==m)for(var y=0;y<m;y++){l=t[y],c=null;var k=l.key;if(null!=k)p&&void 0!==h[k]&&(c=h[k],h[k]=void 0,p--);else if(f<g)for(i=f;i<g;i++)if(void 0!==d[i]&&(S=s=d[i],w=r,"string"==typeof(x=l)||"number"==typeof x?void 0!==S.splitText:"string"==typeof x.nodeName?!S._componentConstructor&&C(S,x.nodeName):w||S._componentConstructor===x.nodeName)){c=s,d[i]=void 0,i===g-1&&g--,i===f&&f++;break}c=A(c,l,n,o),a=u[y],c&&c!==e&&c!==a&&(null==a?e.appendChild(c):c===a.nextSibling?I(a):e.insertBefore(c,a))}var S,x,w;if(p)for(var y in h)void 0!==h[y]&&T(h[y],!1);for(;f<=g;)void 0!==(c=d[g--])&&T(c,!1)}(i,h,n,o,m||null!=d.dangerouslySetInnerHTML),function(e,t,n){var o;for(o in n)t&&null!=t[o]||null==n[o]||v(e,o,n[o],n[o]=void 0,g);for(o in t)"children"===o||"innerHTML"===o||o in n&&t[o]===("value"===o||"checked"===o?e[o]:n[o])||v(e,o,n[o],n[o]=t[o],g)}(i,t.attributes,d),g=s,i}function T(e,t){var n=e._component;n?V(n):(null!=e.__preactattr_&&e.__preactattr_.ref&&e.__preactattr_.ref(null),!1!==t&&null!=e.__preactattr_||I(e),o(e))}function o(e){for(e=e.lastChild;e;){var t=e.previousSibling;T(e,!0),e=t}}function N(e,t,n){var o,r=f.length;for(e.prototype&&e.prototype.render?(o=new e(t,n),a.call(o,t,n)):((o=new a(t,n)).constructor=e,o.render=s);r--;)if(f[r].constructor===e)return o.__b=f[r].__b,f.splice(r,1),o;return o}function s(e,t,n){return this.constructor(e,n)}function P(e,t,n,o,r){e.__x||(e.__x=!0,e.__r=t.ref,e.__k=t.key,delete t.ref,delete t.key,void 0===e.constructor.getDerivedStateFromProps&&(!e.base||r?e.componentWillMount&&e.componentWillMount():e.componentWillReceiveProps&&e.componentWillReceiveProps(t,o)),o&&o!==e.context&&(e.__c||(e.__c=e.context),e.context=o),e.__p||(e.__p=e.props),e.props=t,e.__x=!1,0!==n&&(1!==n&&!1===D.syncComponentUpdates&&e.base?i(e):j(e,1,r)),e.__r&&e.__r(e))}function j(e,t,n,o){if(!e.__x){var r,i,s,a=e.props,l=e.state,c=e.context,u=e.__p||a,d=e.__s||l,h=e.__c||c,p=e.base,f=e.__b,v=p||f,g=e._component,m=!1,y=h;if(e.constructor.getDerivedStateFromProps&&(l=L(L({},l),e.constructor.getDerivedStateFromProps(a,l)),e.state=l),p&&(e.props=u,e.state=d,e.context=h,2!==t&&e.shouldComponentUpdate&&!1===e.shouldComponentUpdate(a,l,c)?m=!0:e.componentWillUpdate&&e.componentWillUpdate(a,l,c),e.props=a,e.state=l,e.context=c),e.__p=e.__s=e.__c=e.__b=null,e.__d=!1,!m){r=e.render(a,l,c),e.getChildContext&&(c=L(L({},c),e.getChildContext())),p&&e.getSnapshotBeforeUpdate&&(y=e.getSnapshotBeforeUpdate(u,d));var _,b,k=r&&r.nodeName;if("function"==typeof k){var S=M(r);(i=g)&&i.constructor===k&&S.key==i.__k?P(i,S,1,c,!1):(_=i,e._component=i=N(k,S,c),i.__b=i.__b||f,i.__u=e,P(i,S,0,c,!1),j(i,1,n,!0)),b=i.base}else s=v,(_=g)&&(s=e._component=null),(v||1===t)&&(s&&(s._component=null),b=O(s,r,c,n||!p,v&&v.parentNode,!0));if(v&&b!==v&&i!==g){var x=v.parentNode;x&&b!==x&&(x.replaceChild(b,v),_||(v._component=null,T(v,!1)))}if(_&&V(_),(e.base=b)&&!o){for(var w=e,C=e;C=C.__u;)(w=C).base=b;b._component=w,b._componentConstructor=w.constructor}}for(!p||n?U.unshift(e):m||(e.componentDidUpdate&&e.componentDidUpdate(u,d,y),D.afterUpdate&&D.afterUpdate(e));e.__h.length;)e.__h.pop().call(e);R||o||E()}}function V(e){D.beforeUnmount&&D.beforeUnmount(e);var t=e.base;e.__x=!0,e.componentWillUnmount&&e.componentWillUnmount(),e.base=null;var n=e._component;n?V(n):t&&(t.__preactattr_&&t.__preactattr_.ref&&t.__preactattr_.ref(null),I(e.__b=t),f.push(e),o(t)),e.__r&&e.__r(null)}function a(e,t){this.__d=!0,this.context=t,this.props=e,this.state=this.state||{},this.__h=[]}var c=function(){},D={},u=[],d=[],r="function"==typeof Promise?Promise.resolve().then.bind(Promise.resolve()):setTimeout,h=/acit|ex(?:s|g|n|p|$)|rph|ows|mnc|ntw|ine[ch]|zoo|^ord/i,p=[],U=[],R=0,g=!1,m=!1,f=[];L(a.prototype,{setState:function(e,t){this.__s||(this.__s=this.state),this.state=L(L({},this.state),"function"==typeof e?e(this.state,this.props):e),t&&this.__h.push(t),i(this)},forceUpdate:function(e){e&&this.__h.push(e),j(this,2)},render:function(){}});var e={h:n,createElement:n,cloneElement:function(e,t){return n(e.nodeName,L(L({},e.attributes),t),2<arguments.length?[].slice.call(arguments,2):e.children)},Component:a,render:function(e,t,n){return O(n,e,{},!1,t,!1)},rerender:t,options:D};void 0!==y?y.exports=e:self.preact=e}()},{}]},{},[3]);+!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e<l.length;e++)c(l[e]);return c}({1:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0}),n.setCookie=function(e,t){document.cookie=e+"="+encodeURIComponent(t)+";path=/;"},n.clearCookie=function(e){document.cookie=e+"=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"},n.getCookie=function(e){for(var t=e+"=",n=document.cookie.split(";"),o=0;o<n.length;o++){for(var r=n[o];" "==r.charAt(0);)r=r.substring(1,r.length);if(0==r.indexOf(t))return decodeURIComponent(r.substring(t.length,r.length))}return null}},{}],2:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i,s,a=e("preact"),l=a.h,c=a.Component;(s=i||(i={}))[s.Closed=0]="Closed",s[s.Open=1]="Open";var u={defaultInstanceState:i.Open,rememberToggles:!0},d=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return l("li",null,l("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(c);function h(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),a.render(l(d,{onClick:e,title:"Instances"}),t,n)}var p=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.componentWillMount=function(){var t=this;document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){t.state.isVisible&&"Escape"===e.key&&t.hide()})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||this.setState({isVisible:!0})},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){return l("div",{id:"preferences",class:t.isVisible?"":"hidden"},l("div",{id:"preferences-menu",class:"dropdown-menu",onMouseDown:function(e){e.stopPropagation()}},l(b,null)))},t}(c);function f(){var e=JSON.stringify(u);try{localStorage.setItem("global",e)}catch(e){}}var v=!1;function g(){if(!v){v=!0;var e=localStorage.getItem("global");if(e)try{var t=JSON.parse(e);u.defaultInstanceState=t.defaultInstanceState,u.rememberToggles=t.rememberToggles}catch(e){if(!(e instanceof SyntaxError||e instanceof TypeError))throw e;localStorage.removeItem("global")}}}function m(t){return function(e){u.defaultInstanceState=t,A(),f(),E(),O()}}function y(e){var t=e.target.checked;u.rememberToggles=t,f(),E(),O()}function _(e){var t=document.getElementById("default-collapse-instances");null!==t&&(t.checked?m(i.Closed)(e):m(i.Open)(e))}function b(){return g(),l("div",null,l("div",null,l("button",{type:"button",onClick:j},"Expand All Instances"),l("button",{type:"button",onClick:P},"Collapse All Instances")),l("div",null,l("input",{type:"checkbox",id:"default-collapse-instances",name:"default-instance-state",checked:u.defaultInstanceState===i.Closed,onClick:_}),l("span",null,"Collapse All Instances By Default")),l("div",null,l("input",{type:"checkbox",id:"remember-toggles",name:"remember-toggles",checked:u.rememberToggles,onClick:y}),l("label",{for:"remember-toggles"},"Remember Manually Collapsed/Expanded Instances")))}var k={};function S(e){var t=k[e];if(null==t)throw new Error("could not find <details> element with id '"+e+"'");return t}function x(){return u.defaultInstanceState==i.Open}function w(e){for(var t=S(e.target.id),n=t.element.open,o=0,r=t.toggles;o<r.length;o++){var i=r[o];i.classList.contains("details-toggle-control")&&(i.classList.add(n?"collapser":"expander"),i.classList.remove(n?"expander":"collapser"))}}function C(e){var t=e.getAttribute("data-details-id");if(!t)throw new Error("element with class "+e+" has no 'data-details-id' attribute!");return t}function L(e){var t=S(C(e)).element;t.open=!t.open}var M="local-details-config:";function I(){return M+document.location.pathname}function E(){for(var e=[],t=0;t<localStorage.length;++t){var n=localStorage.key(t);null!==n&&n.startsWith(M)&&e.push(n)}e.forEach(function(e){localStorage.removeItem(e)})}function O(){if(u.rememberToggles){var e=Array.prototype.slice.call(document.getElementsByClassName("instances details-toggle details-toggle-control")),n=[];e.forEach(function(e){var t=C(e);document.getElementById(t).open!=x()&&n.push(t)});var t=JSON.stringify(n);try{localStorage.setItem(I(),t)}catch(e){}}}function A(){switch(u.defaultInstanceState){case i.Closed:N(!0);break;case i.Open:N(!1)}}function T(e){e.preventDefault(),L(e.currentTarget),O()}function N(o){var e=document.getElementsByClassName("subs instances");[].forEach.call(e,function(e){var t=o?"collapser":"expander",n=e.getElementsByClassName("instances "+t)[0];n&&L(n)})}function P(){N(!0),O()}function j(){N(!1),O()}n.init=function(e){!function(){for(var e=0,t=Array.prototype.slice.call(document.getElementsByTagName("details"));e<t.length;e++){var n=t[e];"string"==typeof n.id&&0<n.id.length&&(k[n.id]={element:n,toggles:[]},n.addEventListener("toggle",w))}}(),Array.prototype.slice.call(document.getElementsByClassName("details-toggle")).forEach(function(e){var t=S(C(e));t.toggles.push(e),e.addEventListener("click",T),e.classList.contains("details-toggle-control")&&e.classList.add(t.element.open?"collapser":"expander")}),function(){if(g(),A(),u.rememberToggles){var e=localStorage.getItem(I());if(e)try{JSON.parse(e).forEach(function(e){S(e).element.open=!x()})}catch(e){if(!(e instanceof SyntaxError||e instanceof TypeError))throw e;localStorage.removeItem(I())}}}(),a.render(l(p,{showHideTrigger:e||h}),document.body)}},{preact:7}],3:[function(e,t,n){"use strict";Object.defineProperty(n,"__esModule",{value:!0});var o,r=e("./style-menu"),i=e("./details-helper"),s=e("./quick-jump");o=function(){document.body.classList.add("js-enabled"),r.init(),s.init(),i.init()},"interactive"===document.readyState?o():document.addEventListener("readystatechange",function(){"interactive"===document.readyState&&o()})},{"./details-helper":2,"./quick-jump":4,"./style-menu":5}],4:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("fuse.js"),s=e("preact"),a=s.h,l=s.Component;var c=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);function u(e){var t=document.querySelector("#page-menu"),n=document.createElement("li");t.insertBefore(n,t.firstChild),s.render(a(c,{onClick:e,title:"Quick Jump"}),t,n)}function d(e,t){return t.length<=e?t:t.slice(0,e)}var h=function(t){function e(){var e=null!==t&&t.apply(this,arguments)||this;return e.linkIndex=0,e.focusPlease=!1,e.navigatedByKeyboard=!1,e}return r(e,t),e.prototype.componentWillMount=function(){var e,t,n,o,r=this;this.setState({searchString:"",isVisible:!1,expanded:{},activeLinkIndex:-1,moduleResults:[]}),e=this.props.baseUrl+"/doc-index.json",t=function(e){r.setState({fuse:new i(e,{threshold:.25,caseSensitive:!0,includeScore:!0,tokenize:!0,keys:[{name:"name",weight:.7},{name:"module",weight:.3}]}),moduleResults:[]})},n=function(e){console&&console.error("could not load 'doc-index.json' for searching",e),r.setState({failedLoading:!0})},(o=new XMLHttpRequest).onreadystatechange=function(){if(o.readyState===XMLHttpRequest.DONE)if(200===o.status){if(t)try{t(JSON.parse(o.responseText))}catch(e){n(o)}}else n&&n(o)},o.open("GET",e,!0),o.send(),document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){r.state.isVisible&&("Escape"===e.key?r.hide():"ArrowUp"===e.key||"k"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(-1)):"ArrowDown"===e.key||"j"===e.key&&e.ctrlKey?(e.preventDefault(),r.navigateLinks(1)):"Enter"===e.key&&0<=r.state.activeLinkIndex&&r.followActiveLink()),"s"===e.key&&"input"!==e.target.tagName.toLowerCase()&&(e.preventDefault(),r.show())})},e.prototype.hide=function(){this.setState({isVisible:!1,searchString:""})},e.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},e.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},e.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},e.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},e.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t=this.state.fuse.search(e),o={};t.forEach(function(e){var t=e.item.module;(o[t]||(o[t]=[])).push(e)});var r=[],n=function(e){var t=o[e],n=0;t.forEach(function(e){n+=1/e.score}),r.push({module:e,totalScore:1/n,items:t})};for(var i in o)n(i);r.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:r})},e.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.top<t&&(this.searchResults.scrollTop-=t-e.top+80)}this.focusPlease&&this.input&&this.input.focus(),this.navigatedByKeyboard=!1,this.focusPlease=!1},e.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},e.prototype.render=function(e,t){var r=this;if(t.failedLoading){var n="file:"==window.location.protocol;return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-results"},a("p",{class:"error"},"Failed to load file 'doc-index.json' containing definitions in this package."),n?a("p",{class:"error"},"To use quick jump, load this page with HTTP (from a local static file web server) instead of using the ",a("code",null,"file://")," protocol. (For security reasons, it is not possible to fetch auxiliary files using JS in a HTML page opened with ",a("code",null,"file://"),".)"):[]))}this.linkIndex=0;var o=function(e){e.stopPropagation()},i=d(10,t.moduleResults).map(function(e){return r.renderResultsInModule(e)});return a("div",{id:"search",class:t.isVisible?"":"hidden"},a("div",{id:"search-form",onMouseDown:o},a("input",{placeholder:"Search in package by name",ref:function(e){r.input=e},onFocus:this.show.bind(this),onClick:this.show.bind(this),onInput:this.updateResults.bind(this)})),a("div",{id:"search-results",ref:function(e){r.searchResults=e},onMouseDown:o,onMouseOver:function(e){for(var t=e.target;t&&"function"==typeof t.getAttribute;){var n=t.getAttribute("data-link-index");if("string"==typeof n){var o=parseInt(n,10);r.setState({activeLinkIndex:o});break}t=t.parentNode}}},""===t.searchString?[a(v,null),a(f,null)]:0==i.length?a(g,{searchString:t.searchString}):a("ul",null,i)))},e.prototype.renderResultsInModule=function(e){var n=this,t=e.items,o=e.module,r=this.state.expanded[o]||t.length<=10,i=r?t:d(8,t);return a("li",{class:"search-module"},a("h4",null,o),a("ul",null,i.map(function(e){return t=e.item,a("li",{class:"search-result"},n.navigationLink(n.props.baseUrl+"/"+t.link,{},a(p,{html:t.display_html})));var t}),r?[]:a("li",{class:"more-results"},this.actionLink(function(){var e=Object.assign({},n.state.expanded);e[o]=!0,n.setState({expanded:e})},{},"show "+(t.length-i.length)+" more results from this module"))))},e.prototype.navigationLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=Object.assign({href:e,onClick:this.hide.bind(this)},t);return this.menuLink.apply(this,[i,function(){window.location.href=e,n.hide()}].concat(o))},e.prototype.actionLink=function(t,e){for(var n=[],o=2;o<arguments.length;o++)n[o-2]=arguments[o];var r=Object.assign({href:"#",onClick:function(e){e.preventDefault(),t()}},e);return this.menuLink.apply(this,[r,t].concat(n))},e.prototype.menuLink=function(e,t){for(var n=this,o=[],r=2;r<arguments.length;r++)o[r-2]=arguments[r];var i=this.linkIndex;i===this.state.activeLinkIndex&&(e.class=(e.class?e.class+" ":"")+"active-link",e.ref=function(e){e&&(n.activeLink=e)},this.activeLinkAction=t);var s=Object.assign({"data-link-index":i},e);return this.linkIndex+=1,a.apply(void 0,["a",s].concat(o))},e}(l),p=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.shouldComponentUpdate=function(e){return this.props.html!==e.html},t.prototype.render=function(e){return a("div",{dangerouslySetInnerHTML:{__html:e.html}})},t}(l);function f(){return a("table",{class:"keyboard-shortcuts"},a("tr",null,a("th",null,"Key"),a("th",null,"Shortcut")),a("tr",null,a("td",null,a("span",{class:"key"},"s")),a("td",null,"Open this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"esc")),a("td",null,"Close this search box")),a("tr",null,a("td",null,a("span",{class:"key"},"↓"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"j")),a("td",null,"Move down in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↑"),",",a("span",{class:"key"},"ctrl")," + ",a("span",{class:"key"},"k")),a("td",null,"Move up in search results")),a("tr",null,a("td",null,a("span",{class:"key"},"↵")),a("td",null,"Go to active search result")))}function v(){return a("p",null,"You can find any exported type, constructor, class, function or pattern defined in this package by (approximate) name.")}function g(e){var t=[a("p",null,"Your search for '",e.searchString,"' produced the following list of results: ",a("code",null,"[]"),"."),a("p",null,a("code",null,"Nothing")," matches your query for '",e.searchString,"'."),a("p",null,a("code",null,"Left \"no matches for '",e.searchString,"'\" :: Either String (NonEmpty SearchResult)"))];return t[(e.searchString||"a").charCodeAt(0)%t.length]}function m(e,t){s.render(a(h,{baseUrl:e||".",showHideTrigger:t||u}),document.body)}n.init=m,window.quickNav={init:m}},{"fuse.js":6,preact:7}],5:[function(e,t,n){"use strict";var o,r=this&&this.__extends||(o=Object.setPrototypeOf||{__proto__:[]}instanceof Array&&function(e,t){e.__proto__=t}||function(e,t){for(var n in t)t.hasOwnProperty(n)&&(e[n]=t[n])},function(e,t){function n(){this.constructor=e}o(e,t),e.prototype=null===t?Object.create(t):(n.prototype=t.prototype,new n)});Object.defineProperty(n,"__esModule",{value:!0});var i=e("./cookies"),s=e("preact"),a=s.h,l=s.Component;function c(){return Array.prototype.slice.call(document.getElementsByTagName("link")).filter(function(e){return-1!=e.rel.indexOf("style")&&e.title})}function u(e){for(var t=c(),n=null,o=0;o<t.length;o++){var r=t[o];r.disabled=!0,r.title==e&&(n=r)}n?(n.disabled=!1,i.setCookie("haddock-style",e)):(t[0].disabled=!1,i.clearCookie("haddock-style"))}var d=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.render=function(t){return a("li",null,a("a",{href:"#",onClick:function(e){e.preventDefault(),t.onClick()}},t.title))},t}(l);var h=function(e){function t(){return null!==e&&e.apply(this,arguments)||this}return r(t,e),t.prototype.componentWillMount=function(){var t=this;document.addEventListener("mousedown",this.hide.bind(this)),document.addEventListener("keydown",function(e){t.state.isVisible&&"Escape"===e.key&&t.hide()})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||this.setState({isVisible:!0})},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.componentDidMount=function(){this.props.showHideTrigger(this.toggleVisibility.bind(this))},t.prototype.render=function(e,t){var n=this;return a("div",{id:"style",class:t.isVisible?"":"hidden"},a("div",{id:"style-menu",class:"dropdown-menu",onMouseDown:function(e){e.stopPropagation()}},e.styles.map(function(t){return a("button",{type:"button",onClick:function(e){n.hide(),u(t)}},t)})))},t}(l);n.init=function(e){var t,n=c().map(function(e){return e.title});(t=i.getCookie("haddock-style"))&&u(t),s.render(a(h,{showHideTrigger:e||function(e){return function(e,t){if(1<e.length){var n=document.querySelector("#page-menu"),o=document.createElement("li");n.appendChild(o),s.render(a(d,{onClick:t,title:"Styles"}),n,o)}}(n,e)},styles:n}),document.body)}},{"./cookies":1,preact:7}],6:[function(e,t,n){var o,r;o=this,r=function(){return function(n){var o={};function r(e){if(o[e])return o[e].exports;var t=o[e]={i:e,l:!1,exports:{}};return n[e].call(t.exports,t,t.exports,r),t.l=!0,t.exports}return r.m=n,r.c=o,r.i=function(e){return e},r.d=function(e,t,n){r.o(e,t)||Object.defineProperty(e,t,{configurable:!1,enumerable:!0,get:n})},r.n=function(e){var t=e&&e.__esModule?function(){return e.default}:function(){return e};return r.d(t,"a",t),t},r.o=function(e,t){return Object.prototype.hasOwnProperty.call(e,t)},r.p="",r(r.s=8)}([function(e,t,n){"use strict";e.exports=function(e){return Array.isArray?Array.isArray(e):"[object Array]"===Object.prototype.toString.call(e)}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var u=n(5),d=n(7),_=n(4),r=function(){function y(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.isCaseSensitive,d=void 0!==u&&u,h=t.tokenSeparator,p=void 0===h?/ +/g:h,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,m=void 0===g?1:g;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,y),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:d,tokenSeparator:p,findAllMatches:v,minMatchCharLength:m},this.pattern=this.options.isCaseSensitive?e:e.toLowerCase(),this.pattern.length<=c&&(this.patternAlphabet=_(this.pattern))}return o(y,[{key:"search",value:function(e){if(this.options.isCaseSensitive||(e=e.toLowerCase()),this.pattern===e)return{isMatch:!0,score:0,matchedIndices:[[0,e.length-1]]};var t=this.options,n=t.maxPatternLength,o=t.tokenSeparator;if(this.pattern.length>n)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return d(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l<c;l+=1)e(a[l],s,o);else s&&e(a,s,o);else o.push(a.toString())}else o.push(t);return o}(e,t,[])}},function(e,t,n){"use strict";e.exports=function(){for(var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:[],t=1<arguments.length&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i<s;i+=1){var a=e[i];a&&-1===o?o=i:a||-1===o||(t<=(r=i-1)-o+1&&n.push([o,r]),o=-1)}return e[i-1]&&t<=i-o&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o<n;o+=1)t[e.charAt(o)]=0;for(var r=0;r<n;r+=1)t[e.charAt(r)]|=1<<n-r-1;return t}},function(e,t,n){"use strict";var u=/[\-\[\]\/\{\}\(\)\*\+\?\.\\\^\$\|]/g;e.exports=function(e,t){var n=2<arguments.length&&void 0!==arguments[2]?arguments[2]:/ +/g,o=new RegExp(t.replace(u,"\\$&").replace(n,"|")),r=e.match(o),i=!!r,s=[];if(i)for(var a=0,l=r.length;a<l;a+=1){var c=r[a];s.push([e.indexOf(c),c.length-1])}return{score:i?.5:1,isMatch:i,matchedIndices:s}}},function(e,t,n){"use strict";e.exports=function(e,t){var n=t.errors,o=void 0===n?0:n,r=t.currentLocation,i=void 0===r?0:r,s=t.expectedLocation,a=void 0===s?0:s,l=t.distance,c=void 0===l?100:l,u=o/e.length,d=Math.abs(a-i);return c?u+d/c:d?1:u}},function(e,t,n){"use strict";var V=n(6),D=n(3);e.exports=function(e,t,n,o){for(var r=o.location,i=void 0===r?0:r,s=o.distance,a=void 0===s?100:s,l=o.threshold,c=void 0===l?.6:l,u=o.findAllMatches,d=void 0!==u&&u,h=o.minMatchCharLength,p=void 0===h?1:h,f=i,v=e.length,g=c,m=e.indexOf(t,f),y=t.length,_=[],b=0;b<v;b+=1)_[b]=0;if(-1!==m){var k=V(t,{errors:0,currentLocation:m,expectedLocation:f,distance:a});if(g=Math.min(k,g),-1!==(m=e.lastIndexOf(t,f+y))){var S=V(t,{errors:0,currentLocation:m,expectedLocation:f,distance:a});g=Math.min(S,g)}}m=-1;for(var x=[],w=1,C=y+v,L=1<<y-1,M=0;M<y;M+=1){for(var I=0,E=C;I<E;){V(t,{errors:M,currentLocation:f+E,expectedLocation:f,distance:a})<=g?I=E:C=E,E=Math.floor((C-I)/2+I)}C=E;var O=Math.max(1,f-E+1),A=d?v:Math.min(f+E,v)+y,T=Array(A+2);T[A+1]=(1<<M)-1;for(var N=A;O<=N;N-=1){var P=N-1,j=n[e.charAt(P)];if(j&&(_[P]=1),T[N]=(T[N+1]<<1|1)&j,0!==M&&(T[N]|=(x[N+1]|x[N])<<1|1|x[N+1]),T[N]&L&&(w=V(t,{errors:M,currentLocation:P,expectedLocation:f,distance:a}))<=g){if(g=w,(m=P)<=f)break;O=Math.max(1,2*f-m)}}if(g<V(t,{errors:M+1,currentLocation:f,expectedLocation:f,distance:a}))break;x=T}return{isMatch:0<=m,score:0===w?.001:w,matchedIndices:D(_,p)}}},function(e,t,n){"use strict";var o=function(){function o(e,t){for(var n=0;n<t.length;n++){var o=t[n];o.enumerable=o.enumerable||!1,o.configurable=!0,"value"in o&&(o.writable=!0),Object.defineProperty(e,o.key,o)}}return function(e,t,n){return t&&o(e.prototype,t),n&&o(e,n),e}}();var i=n(1),R=n(2),V=n(0),r=function(){function U(e,t){var n=t.location,o=void 0===n?0:n,r=t.distance,i=void 0===r?100:r,s=t.threshold,a=void 0===s?.6:s,l=t.maxPatternLength,c=void 0===l?32:l,u=t.caseSensitive,d=void 0!==u&&u,h=t.tokenSeparator,p=void 0===h?/ +/g:h,f=t.findAllMatches,v=void 0!==f&&f,g=t.minMatchCharLength,m=void 0===g?1:g,y=t.id,_=void 0===y?null:y,b=t.keys,k=void 0===b?[]:b,S=t.shouldSort,x=void 0===S||S,w=t.getFn,C=void 0===w?R:w,L=t.sortFn,M=void 0===L?function(e,t){return e.score-t.score}:L,I=t.tokenize,E=void 0!==I&&I,O=t.matchAllTokens,A=void 0!==O&&O,T=t.includeMatches,N=void 0!==T&&T,P=t.includeScore,j=void 0!==P&&P,V=t.verbose,D=void 0!==V&&V;!function(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}(this,U),this.options={location:o,distance:i,threshold:a,maxPatternLength:c,isCaseSensitive:d,tokenSeparator:p,findAllMatches:v,minMatchCharLength:m,id:_,keys:k,includeMatches:N,includeScore:j,shouldSort:x,getFn:C,sortFn:M,verbose:D,tokenize:E,matchAllTokens:A},this.setCollection(e)}return o(U,[{key:"setCollection",value:function(e){return this.list=e}},{key:"search",value:function(e){this._log('---------\nSearch pattern: "'+e+'"');var t=this._prepareSearchers(e),n=t.tokenSearchers,o=t.fullSearcher,r=this._search(n,o),i=r.weights,s=r.results;return this._computeScore(i,s),this.options.shouldSort&&this._sort(s),this._format(s)}},{key:"_prepareSearchers",value:function(){var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o<r;o+=1)t.push(new i(n[o],this.options));return{tokenSearchers:t,fullSearcher:new i(e,this.options)}}},{key:"_search",value:function(){var e=0<arguments.length&&void 0!==arguments[0]?arguments[0]:[],t=arguments[1],n=this.list,o={},r=[];if("string"==typeof n[0]){for(var i=0,s=n.length;i<s;i+=1)this._analyze({key:"",value:n[i],record:i,index:i},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t});return{weights:null,results:r}}for(var a={},l=0,c=n.length;l<c;l+=1)for(var u=n[l],d=0,h=this.options.keys.length;d<h;d+=1){var p=this.options.keys[d];if("string"!=typeof p){if(a[p.name]={weight:1-p.weight||1},p.weight<=0||1<p.weight)throw new Error("Key weight has to be > 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,d=void 0===u?[]:u,h=t.resultMap,p=void 0===h?{}:h,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=d.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),k=[],S=0;S<c.length;S+=1){var x=c[S];this._log('\nPattern: "'+x.pattern+'"');for(var w=!1,C=0;C<b.length;C+=1){var L=b[C],M=x.search(L),I={};M.isMatch?(I[L]=M.score,w=g=!0,k.push(M.score)):(I[L]=1,this.options.matchAllTokens||k.push(1)),this._log('Token: "'+L+'", score: '+I[L])}w&&(y+=1)}m=k[0];for(var E=k.length,O=1;O<E;O+=1)m+=k[O];m/=E,this._log("Token score average:",m)}var A=_.score;-1<m&&(A=(A+m)/2),this._log("Score average:",A);var T=!this.options.tokenize||!this.options.matchAllTokens||y>=c.length;if(this._log("\nCheck Matches: "+T),(g||_.isMatch)&&T){var N=p[a];N?N.output.push({key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(V(i))for(var P=0,j=i.length;P<j;P+=1)this._analyze({key:n,arrayIndex:P,value:i[P],record:s,index:a},{resultMap:p,results:v,tokenSearchers:c,fullSearcher:d})}}},{key:"_computeScore",value:function(e,t){this._log("\n\nComputing score:\n");for(var n=0,o=t.length;n<o;n+=1){for(var r=t[n].output,i=r.length,s=1,a=1,l=0;l<i;l+=1){var c=e?e[r[l].key].weight:1,u=(1===c?r[l].score:r[l].score||.001)*c;1!==c?a=Math.min(a,u):s*=r[l].nScore=u}t[n].score=1===a?s:a,this._log(t[n])}}},{key:"_sort",value:function(e){this._log("\n\nSorting...."),e.sort(this.options.sortFn)}},{key:"_format",value:function(e){var t=[];this.options.verbose&&this._log("\n\nOutput:\n\n",JSON.stringify(e));var n=[];this.options.includeMatches&&n.push(function(e,t){var n=e.output;t.matches=[];for(var o=0,r=n.length;o<r;o+=1){var i=n[o];if(0!==i.matchedIndices.length){var s={indices:i.matchedIndices,value:i.value};i.key&&(s.key=i.key),i.hasOwnProperty("arrayIndex")&&-1<i.arrayIndex&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;o<r;o+=1){var i=e[o];if(this.options.id&&(i.item=this.options.getFn(i.item,this.options.id)[0]),n.length){for(var s={item:i.item},a=0,l=n.length;a<l;a+=1)n[a](i,s);t.push(s)}else t.push(i.item)}return t}},{key:"_log",value:function(){var e;this.options.verbose&&(e=console).log.apply(e,arguments)}}]),U}();e.exports=r}])},"object"==typeof n&&"object"==typeof t?t.exports=r():"function"==typeof define&&define.amd?define("Fuse",[],r):"object"==typeof n?n.Fuse=r():o.Fuse=r()},{}],7:[function(e,y,t){!function(){"use strict";function n(e,t){var n,o,r,i,s=d;for(i=arguments.length;2<i--;)u.push(arguments[i]);for(t&&null!=t.children&&(u.length||u.push(t.children),delete t.children);u.length;)if((o=u.pop())&&void 0!==o.pop)for(i=o.length;i--;)u.push(o[i]);else"boolean"==typeof o&&(o=null),(r="function"!=typeof e)&&(null==o?o="":"number"==typeof o?o=String(o):"string"!=typeof o&&(r=!1)),r&&n?s[s.length-1]+=o:s===d?s=[o]:s.push(o),n=r;var a=new c;return a.nodeName=e,a.children=s,a.attributes=null==t?void 0:t,a.key=null==t?void 0:t.key,void 0!==D.vnode&&D.vnode(a),a}function L(e,t){for(var n in t)e[n]=t[n];return e}function i(e){!e.__d&&(e.__d=!0)&&1==p.push(e)&&(D.debounceRendering||r)(t)}function t(){var e,t=p;for(p=[];e=t.pop();)e.__d&&j(e)}function C(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function M(e){var t=L({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var o in n)void 0===t[o]&&(t[o]=n[o]);return t}function I(e){var t=e.parentNode;t&&t.removeChild(e)}function v(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===h.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,l,s):e.removeEventListener(t,l,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e){try{e[t]=null==o?"":o}catch(e){}null!=o&&!1!==o||"spellcheck"==t||e.removeAttribute(t)}else{var a=r&&t!==(t=t.replace(/^xlink:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function l(e){return this.__l[e.type](D.event&&D.event(e)||e)}function E(){for(var e;e=U.pop();)D.afterMount&&D.afterMount(e),e.componentDidMount&&e.componentDidMount()}function O(e,t,n,o,r,i){R++||(g=null!=r&&void 0!==r.ownerSVGElement,m=null!=e&&!("__preactattr_"in e));var s=A(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(m=!1,i||E()),s}function A(e,t,n,o,r){var i=e,s=g;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),T(e,!0))),i.__preactattr_=!0,i;var a,l,c=t.nodeName;if("function"==typeof c)return function(e,t,n,o){var r=e&&e._component,i=r,s=e,a=r&&e._componentConstructor===t.nodeName,l=a,c=M(t);for(;r&&!l&&(r=r.__u);)l=r.constructor===t.nodeName;r&&l&&(!o||r._component)?(P(r,c,3,n,o),e=r.base):(i&&!a&&(V(i),e=s=null),r=N(t.nodeName,c,n),e&&!r.__b&&(r.__b=e,s=null),P(r,c,1,n,o),e=r.base,s&&e!==s&&(s._component=null,T(s,!1)));return e}(e,t,n,o);if(g="svg"===c||"foreignObject"!==c&&g,c=String(c),(!e||!C(e,c))&&(a=c,(l=g?document.createElementNS("http://www.w3.org/2000/svg",a):document.createElement(a)).__n=a,i=l,e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),T(e,!0)}var u=i.firstChild,d=i.__preactattr_,h=t.children;if(null==d){d=i.__preactattr_={};for(var p=i.attributes,f=p.length;f--;)d[p[f].name]=p[f].value}return!m&&h&&1===h.length&&"string"==typeof h[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=h[0]&&(u.nodeValue=h[0]):(h&&h.length||null!=u)&&function(e,t,n,o,r){var i,s,a,l,c,u=e.childNodes,d=[],h={},p=0,f=0,v=u.length,g=0,m=t?t.length:0;if(0!==v)for(var y=0;y<v;y++){var _=u[y],b=_.__preactattr_,k=m&&b?_._component?_._component.__k:b.key:null;null!=k?(p++,h[k]=_):(b||(void 0!==_.splitText?!r||_.nodeValue.trim():r))&&(d[g++]=_)}if(0!==m)for(var y=0;y<m;y++){l=t[y],c=null;var k=l.key;if(null!=k)p&&void 0!==h[k]&&(c=h[k],h[k]=void 0,p--);else if(f<g)for(i=f;i<g;i++)if(void 0!==d[i]&&(S=s=d[i],w=r,"string"==typeof(x=l)||"number"==typeof x?void 0!==S.splitText:"string"==typeof x.nodeName?!S._componentConstructor&&C(S,x.nodeName):w||S._componentConstructor===x.nodeName)){c=s,d[i]=void 0,i===g-1&&g--,i===f&&f++;break}c=A(c,l,n,o),a=u[y],c&&c!==e&&c!==a&&(null==a?e.appendChild(c):c===a.nextSibling?I(a):e.insertBefore(c,a))}var S,x,w;if(p)for(var y in h)void 0!==h[y]&&T(h[y],!1);for(;f<=g;)void 0!==(c=d[g--])&&T(c,!1)}(i,h,n,o,m||null!=d.dangerouslySetInnerHTML),function(e,t,n){var o;for(o in n)t&&null!=t[o]||null==n[o]||v(e,o,n[o],n[o]=void 0,g);for(o in t)"children"===o||"innerHTML"===o||o in n&&t[o]===("value"===o||"checked"===o?e[o]:n[o])||v(e,o,n[o],n[o]=t[o],g)}(i,t.attributes,d),g=s,i}function T(e,t){var n=e._component;n?V(n):(null!=e.__preactattr_&&e.__preactattr_.ref&&e.__preactattr_.ref(null),!1!==t&&null!=e.__preactattr_||I(e),o(e))}function o(e){for(e=e.lastChild;e;){var t=e.previousSibling;T(e,!0),e=t}}function N(e,t,n){var o,r=f.length;for(e.prototype&&e.prototype.render?(o=new e(t,n),a.call(o,t,n)):((o=new a(t,n)).constructor=e,o.render=s);r--;)if(f[r].constructor===e)return o.__b=f[r].__b,f.splice(r,1),o;return o}function s(e,t,n){return this.constructor(e,n)}function P(e,t,n,o,r){e.__x||(e.__x=!0,e.__r=t.ref,e.__k=t.key,delete t.ref,delete t.key,void 0===e.constructor.getDerivedStateFromProps&&(!e.base||r?e.componentWillMount&&e.componentWillMount():e.componentWillReceiveProps&&e.componentWillReceiveProps(t,o)),o&&o!==e.context&&(e.__c||(e.__c=e.context),e.context=o),e.__p||(e.__p=e.props),e.props=t,e.__x=!1,0!==n&&(1!==n&&!1===D.syncComponentUpdates&&e.base?i(e):j(e,1,r)),e.__r&&e.__r(e))}function j(e,t,n,o){if(!e.__x){var r,i,s,a=e.props,l=e.state,c=e.context,u=e.__p||a,d=e.__s||l,h=e.__c||c,p=e.base,f=e.__b,v=p||f,g=e._component,m=!1,y=h;if(e.constructor.getDerivedStateFromProps&&(l=L(L({},l),e.constructor.getDerivedStateFromProps(a,l)),e.state=l),p&&(e.props=u,e.state=d,e.context=h,2!==t&&e.shouldComponentUpdate&&!1===e.shouldComponentUpdate(a,l,c)?m=!0:e.componentWillUpdate&&e.componentWillUpdate(a,l,c),e.props=a,e.state=l,e.context=c),e.__p=e.__s=e.__c=e.__b=null,e.__d=!1,!m){r=e.render(a,l,c),e.getChildContext&&(c=L(L({},c),e.getChildContext())),p&&e.getSnapshotBeforeUpdate&&(y=e.getSnapshotBeforeUpdate(u,d));var _,b,k=r&&r.nodeName;if("function"==typeof k){var S=M(r);(i=g)&&i.constructor===k&&S.key==i.__k?P(i,S,1,c,!1):(_=i,e._component=i=N(k,S,c),i.__b=i.__b||f,i.__u=e,P(i,S,0,c,!1),j(i,1,n,!0)),b=i.base}else s=v,(_=g)&&(s=e._component=null),(v||1===t)&&(s&&(s._component=null),b=O(s,r,c,n||!p,v&&v.parentNode,!0));if(v&&b!==v&&i!==g){var x=v.parentNode;x&&b!==x&&(x.replaceChild(b,v),_||(v._component=null,T(v,!1)))}if(_&&V(_),(e.base=b)&&!o){for(var w=e,C=e;C=C.__u;)(w=C).base=b;b._component=w,b._componentConstructor=w.constructor}}for(!p||n?U.unshift(e):m||(e.componentDidUpdate&&e.componentDidUpdate(u,d,y),D.afterUpdate&&D.afterUpdate(e));e.__h.length;)e.__h.pop().call(e);R||o||E()}}function V(e){D.beforeUnmount&&D.beforeUnmount(e);var t=e.base;e.__x=!0,e.componentWillUnmount&&e.componentWillUnmount(),e.base=null;var n=e._component;n?V(n):t&&(t.__preactattr_&&t.__preactattr_.ref&&t.__preactattr_.ref(null),I(e.__b=t),f.push(e),o(t)),e.__r&&e.__r(null)}function a(e,t){this.__d=!0,this.context=t,this.props=e,this.state=this.state||{},this.__h=[]}var c=function(){},D={},u=[],d=[],r="function"==typeof Promise?Promise.resolve().then.bind(Promise.resolve()):setTimeout,h=/acit|ex(?:s|g|n|p|$)|rph|ows|mnc|ntw|ine[ch]|zoo|^ord/i,p=[],U=[],R=0,g=!1,m=!1,f=[];L(a.prototype,{setState:function(e,t){this.__s||(this.__s=this.state),this.state=L(L({},this.state),"function"==typeof e?e(this.state,this.props):e),t&&this.__h.push(t),i(this)},forceUpdate:function(e){e&&this.__h.push(e),j(this,2)},render:function(){}});var e={h:n,createElement:n,cloneElement:function(e,t){return n(e.nodeName,L(L({},e.attributes),t),2<arguments.length?[].slice.call(arguments,2):e.children)},Component:a,render:function(e,t,n){return O(n,e,{},!1,t,!1)},rerender:t,options:D};void 0!==y?y.exports=e:self.preact=e}()},{}]},{},[3]); //# sourceMappingURL=haddock-bundle.min.js.map

@@ -1,10 +1,6 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-}-{-# OPTIONS_GHC -Wwarn           #-}+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock@@ -50,7 +46,7 @@ import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for)-import Data.List (find, isPrefixOf, nub)+import Data.List (isPrefixOf) import Control.Exception import Data.Maybe import Data.IORef@@ -73,12 +69,11 @@ import GHC hiding (verbosity) import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity)-import GHC.Utils.Outputable (defaultUserStyle, withPprStyle)+import GHC.Driver.Env import GHC.Utils.Error import GHC.Unit import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString-import qualified Debug.Trace as Debug  -------------------------------------------------------------------------------- -- * Exception handling@@ -189,11 +184,13 @@    ghc flags' $ withDir $ do     dflags <- getDynFlags+    logger <- getLogger+    unit_state <- hsc_units <$> getSession      forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do       mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks-      forM_ mIfaceFile $ \(_, _, ifaceFile) -> do-        logOutput dflags $ withPprStyle defaultUserStyle (renderJson (jsonInterfaceFile ifaceFile))+      forM_ mIfaceFile $ \(_, ifaceFile) -> do+        putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)      if not (null files) then do       (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files@@ -206,7 +203,7 @@           }        -- Render the interfaces.-      liftIO $ renderStep dflags flags sinceQual qual packages ifaces+      liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces      else do       when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $@@ -216,7 +213,7 @@       packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks        -- Render even though there are no input files (usually contents/index).-      liftIO $ renderStep dflags flags sinceQual qual packages []+      liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []  -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a@@ -252,65 +249,48 @@   readPackagesAndProcessModules :: [Flag] -> [String]-                              -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv)+                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do     -- Get packages supplied with --read-interface.     let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags     packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks      -- Create the interfaces -- this is the core part of Haddock.-    let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages+    let ifaceFiles = map snd packages     (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles      return (packages, ifaces, homeLinks)  -renderStep :: DynFlags -> [Flag] -> SinceQual -> QualOption-           -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO ()-renderStep dflags flags sinceQual nameQual pkgs interfaces = do-  updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) ->-                          ( case baseUrl flags of-                              Nothing  -> fst docPath-                              Just url -> Debug.traceShowId $-                                url </> packageName (unitState dflags) (ifUnitId ifaceFile)-                          , ifaceFile)) pkgs)+renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption+           -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()+renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do+  updateHTMLXRefs pkgs   let-    installedIfaces =-      concatMap-        (\(_, ifaceFilePath, ifaceFile)-          -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)-        pkgs+    ifaceFiles = map snd pkgs+    installedIfaces = concatMap ifInstalledIfaces ifaceFiles     extSrcMap = Map.fromList $ do-      ((_, Just path), _, ifile) <- pkgs+      ((_, Just path), ifile) <- pkgs       iface <- ifInstalledIfaces ifile       return (instMod iface, path)-  render dflags flags sinceQual nameQual interfaces installedIfaces extSrcMap-  where-    -- get package name from unit-id-    packageName :: UnitState -> Unit -> String-    packageName state unit =-      case lookupUnit state unit of-        Nothing  -> show unit-        Just pkg -> unitPackageNameString pkg+  render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap  -- | Render the interfaces with whatever backend is specified in the flags.-render :: DynFlags -> [Flag] -> SinceQual -> QualOption -> [Interface]-       -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()-render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do+render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]+       -> [InstalledInterface] -> Map Module FilePath -> IO ()+render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do    let     title                = fromMaybe "" (optTitle flags)     unicode              = Flag_UseUnicode `elem` flags     pretty               = Flag_PrettyHtml `elem` flags     opt_wiki_urls        = wikiUrls          flags-    opt_base_url         = baseUrl           flags     opt_contents_url     = optContentsUrl    flags     opt_index_url        = optIndexUrl       flags     odir                 = outputDir         flags     opt_latex_style      = optLaTeXStyle     flags     opt_source_css       = optSourceCssFile  flags     opt_mathjax          = optMathjax        flags-    pkgs                 = unitState dflags     dflags'       | unicode          = gopt_set dflags Opt_PrintUnicodeSyntax       | otherwise        = dflags@@ -318,13 +298,13 @@     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]      -- /All/ visible interfaces including external package modules.-    allIfaces        = map toInstalledIface ifaces ++ map snd installedIfaces+    allIfaces        = map toInstalledIface ifaces ++ installedIfaces     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]      pkgMod           = fmap ifaceMod (listToMaybe ifaces)     pkgKey           = fmap moduleUnit pkgMod     pkgStr           = fmap unitString pkgKey-    pkgNameVer       = modulePackageInfo dflags flags pkgMod+    pkgNameVer       = modulePackageInfo unit_state flags pkgMod     pkgName          = fmap (unpackFS . (\(PackageName n) -> n)) (fst pkgNameVer)     sincePkg         = case sinceQual of                          External -> pkgName@@ -363,13 +343,13 @@     sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')      installedMap :: Map Module InstalledInterface-    installedMap = Map.fromList [ (unwire (instMod iface), iface) | (_, iface) <- installedIfaces ]+    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 { moduleUnit = unwireUnit (unitState dflags) (moduleUnit m) }+    unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) }    reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do     let warn = hPutStrLn stderr . ("Warning: " ++)@@ -386,53 +366,38 @@   themes   <- getThemes libDir flags >>= either bye return    let withQuickjump = Flag_QuickJumpIndex `elem` flags-      withBaseURL = isJust-                  . find (\flag -> case flag of-                           Flag_BaseURL base_url ->-                             base_url /= "." && base_url /= "./"-                           _ -> False-                         )-                  $ flags    when (Flag_GenIndex `elem` flags) $ do-    withTiming dflags' "ppHtmlIndex" (const ()) $ do+    withTiming logger dflags' "ppHtmlIndex" (const ()) $ do       _ <- {-# SCC ppHtmlIndex #-}            ppHtmlIndex odir title pkgStr                   themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls                   allVisibleIfaces pretty       return () -    unless withBaseURL $-      copyHtmlBits odir libDir themes withQuickjump+    copyHtmlBits odir libDir themes withQuickjump    when (Flag_GenContents `elem` flags) $ do-    withTiming dflags' "ppHtmlContents" (const ()) $ do+    withTiming logger dflags' "ppHtmlContents" (const ()) $ do       _ <- {-# SCC ppHtmlContents #-}-           ppHtmlContents pkgs odir title pkgStr+           ppHtmlContents unit_state odir title pkgStr                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls                      allVisibleIfaces True prologue pretty                      sincePkg (makeContentsQual qual)       return ()     copyHtmlBits odir libDir themes withQuickjump -  when withQuickjump $ void $-            ppJsonIndex odir sourceUrls' opt_wiki_urls-                        unicode Nothing qual-                        ifaces-                        (nub $ map fst installedIfaces)-   when (Flag_Html `elem` flags) $ do-    withTiming dflags' "ppHtml" (const ()) $ do+    withTiming logger dflags' "ppHtml" (const ()) $ do       _ <- {-# SCC ppHtml #-}-           ppHtml pkgs title pkgStr visibleIfaces reexportedIfaces odir+           ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir                   prologue-                  themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url+                  themes opt_mathjax sourceUrls' opt_wiki_urls                   opt_contents_url opt_index_url unicode sincePkg qual                   pretty withQuickjump       return ()-    unless withBaseURL $ do-      copyHtmlBits odir libDir themes withQuickjump-      writeHaddockMeta odir 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@@ -445,7 +410,7 @@              pkgVer =               fromMaybe (makeVersion []) mpkgVer-          in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)+          in ppHoogle dflags' unit_state pkgNameStr pkgVer title (fmap _doc prologue)                visibleIfaces odir       _ -> putStrLn . unlines $           [ "haddock: Unable to find a package providing module "@@ -458,14 +423,14 @@           ]    when (Flag_LaTeX `elem` flags) $ do-    withTiming dflags' "ppLatex" (const ()) $ do+    withTiming logger dflags' "ppLatex" (const ()) $ do       _ <- {-# SCC ppLatex #-}            ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style                    libDir       return ()    when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do-    withTiming dflags' "ppHyperlinkedSource" (const ()) $ do+    withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do       _ <- {-# SCC ppHyperlinkedSource #-}            ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces       return ()@@ -480,7 +445,7 @@                    => NameCacheAccessor m                    -> [(DocPaths, FilePath)]                    -> Bool-                   -> m [(DocPaths, FilePath, InterfaceFile)]+                   -> m [(DocPaths, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs bypass_version_check = do   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs   where@@ -492,7 +457,7 @@           putStrLn ("   " ++ err)           putStrLn "Skipping this interface."           return Nothing-        Right f -> return (Just (paths, file, f))+        Right f -> return $ Just (paths, f)   -------------------------------------------------------------------------------@@ -504,7 +469,8 @@ -- compilation and linking. Then run the given 'Ghc' action. withGhc' :: String -> Bool -> [String] -> (DynFlags -> Ghc a) -> IO a withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do-  dynflags' <- parseGhcFlags =<< getSessionDynFlags+  logger <- getLogger+  dynflags' <- parseGhcFlags logger =<< getSessionDynFlags    -- We disable pattern match warnings because than can be very   -- expensive to check@@ -528,20 +494,20 @@             go arg    func True = arg : func True  -    parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags-    parseGhcFlags dynflags = do+    parseGhcFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+    parseGhcFlags logger dynflags = do       -- TODO: handle warnings?        let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]                      | otherwise = [Opt_Haddock]           dynflags' = (foldl' gopt_set dynflags extra_opts)-                        { hscTarget = HscNothing-                        , ghcMode   = CompManager-                        , ghcLink   = NoLink+                        { backend = NoBackend+                        , ghcMode = CompManager+                        , ghcLink = NoLink                         }           flags' = filterRtsFlags flags -      (dynflags'', rest, _) <- parseDynamicFlags dynflags' (map noLoc flags')+      (dynflags'', rest, _) <- parseDynamicFlags logger dynflags' (map noLoc flags')       if not (null rest)         then throwE ("Couldn't parse GHC options: " ++ unwords flags')         else return dynflags''@@ -712,12 +678,12 @@     isSourceCssFlag _ = False  -updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()+updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () updateHTMLXRefs packages = do   writeIORef html_xrefs_ref (Map.fromList mapping)   writeIORef html_xrefs_ref' (Map.fromList mapping')   where-    mapping = [ (instMod iface, html) | (html, ifaces) <- packages+    mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages               , iface <- ifInstalledIfaces ifaces ]     mapping' = [ (moduleName m, html) | (m, html) <- mapping ] 

@@ -18,8 +18,9 @@     ppHoogle   ) where -import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..), SourceText(..)-                  , PromotionFlag(..), TopLevelFlag(..) )+import GHC.Types.Basic ( OverlapFlag(..), OverlapMode(..),+                         PromotionFlag(..), TopLevelFlag(..) )+import GHC.Types.SourceText import GHC.Core.InstEnv (ClsInst(..)) import Documentation.Haddock.Markup import Haddock.GhcUtils@@ -27,8 +28,11 @@ import Haddock.Utils hiding (out)  import GHC+import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Parser.Annotation (IsUnicodeSyntax(..))+import GHC.Unit.State  import Data.Char import Data.List (intercalate, isPrefixOf)@@ -37,15 +41,14 @@  import System.Directory import System.FilePath- prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock"          ,"-- See Hoogle, http://www.haskell.org/hoogle/"          ,""]  -ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()-ppHoogle dflags package version synopsis prologue ifaces odir = do+ppHoogle :: DynFlags -> UnitState -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()+ppHoogle dflags unit_state package version synopsis prologue ifaces odir = do     let -- Since Hoogle is line based, we want to avoid breaking long lines.         dflags' = dflags{ pprCols = maxBound }         filename = package ++ ".txt"@@ -54,44 +57,47 @@                    ["@package " ++ package] ++                    ["@version " ++ showVersion version                    | not (null (versionBranch version)) ] ++-                   concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i]+                   concat [ppModule dflags' unit_state i | i <- ifaces, OptHide `notElem` ifaceOptions i]     createDirectoryIfMissing True odir     writeUtf8File (odir </> filename) (unlines contents) -ppModule :: DynFlags -> Interface -> [String]-ppModule dflags iface =+ppModule :: DynFlags -> UnitState -> Interface -> [String]+ppModule dflags unit_state iface =   "" : ppDocumentation dflags (ifaceDoc iface) ++   ["module " ++ moduleString (ifaceMod iface)] ++   concatMap (ppExport dflags) (ifaceExportItems iface) ++-  concatMap (ppInstance dflags) (ifaceInstances iface)+  concatMap (ppInstance dflags unit_state) (ifaceInstances iface)   --------------------------------------------------------------------- -- Utility functions -dropHsDocTy :: HsType a -> HsType a-dropHsDocTy = f+dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn+dropHsDocTy = drop_sig_ty     where-        g (L src x) = L src (f x)-        f (HsForAllTy x a e) = HsForAllTy x a (g e)-        f (HsQualTy x a e) = HsQualTy x a (g e)-        f (HsBangTy x a b) = HsBangTy x a (g b)-        f (HsAppTy x a b) = HsAppTy x (g a) (g b)-        f (HsAppKindTy x a b) = HsAppKindTy x (g a) (g b)-        f (HsFunTy x w a b) = HsFunTy x w (g a) (g b)-        f (HsListTy x a) = HsListTy x (g a)-        f (HsTupleTy x a b) = HsTupleTy x a (map g b)-        f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)-        f (HsParTy x a) = HsParTy x (g a)-        f (HsKindSig x a b) = HsKindSig x (g a) b-        f (HsDocTy _ a _) = f $ unLoc a-        f x = x+        drop_sig_ty (HsSig x a b)  = HsSig x a (drop_lty b)+        drop_sig_ty x@XHsSigType{} = x -outHsType :: (OutputableBndrId p)-          => DynFlags -> HsType (GhcPass p) -> String-outHsType dflags = out dflags . reparenType . dropHsDocTy+        drop_lty (L src x) = L src (drop_ty x) +        drop_ty (HsForAllTy x a e) = HsForAllTy x a (drop_lty e)+        drop_ty (HsQualTy x a e) = HsQualTy x a (drop_lty e)+        drop_ty (HsBangTy x a b) = HsBangTy x a (drop_lty b)+        drop_ty (HsAppTy x a b) = HsAppTy x (drop_lty a) (drop_lty b)+        drop_ty (HsAppKindTy x a b) = HsAppKindTy x (drop_lty a) (drop_lty b)+        drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b)+        drop_ty (HsListTy x a) = HsListTy x (drop_lty a)+        drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)+        drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)+        drop_ty (HsParTy x a) = HsParTy x (drop_lty a)+        drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b+        drop_ty (HsDocTy _ a _) = drop_ty $ unL a+        drop_ty x = x +outHsSigType :: DynFlags -> HsSigType GhcRn -> String+outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy++ dropComment :: String -> String dropComment (' ':'-':'-':' ':_) = [] dropComment (x:xs) = x : dropComment xs@@ -106,14 +112,14 @@         f [] = []  out :: Outputable a => DynFlags -> a -> String-out dflags = outWith $ showSDocUnqual dflags+out dflags = outWith $ showSDoc dflags  operator :: String -> String operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" operator x = x  commaSeparate :: Outputable a => DynFlags -> [a] -> String-commaSeparate dflags = showSDocUnqual dflags . interpp'SP+commaSeparate dflags = showSDoc dflags . interpp'SP  --------------------------------------------------------------------- -- How to print each export@@ -133,8 +139,8 @@         f (TyClD _ d@SynDecl{})   = ppSynonym dflags d         f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs         f (TyClD _ (FamDecl _ d)) = ppFam dflags d-        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]-        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)]+        f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] typ]+        f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] typ]         f (SigD _ sig) = ppSig dflags sig         f _ = [] @@ -143,19 +149,19 @@  ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags sig subdocs = case sig of-    TypeSig _ names t -> concatMap (mkDocSig "" (hsSigWcType t)) names-    PatSynSig _ names t -> concatMap (mkDocSig "pattern " (hsSigType t)) names+    TypeSig _ names t -> concatMap (mkDocSig "" (dropWildCards t)) names+    PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names     _ -> []   where-    mkDocSig leader typ n = mkSubdoc dflags n subdocs-                                     [leader ++ pp_sig dflags [n] typ]+    mkDocSig leader typ n = mkSubdocN dflags n subdocs+                                      [leader ++ pp_sig dflags [n] typ]  ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x  = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String+pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String pp_sig dflags names (L _ typ)  =-    operator prettyNames ++ " :: " ++ outHsType dflags typ+    operator prettyNames ++ " :: " ++ outHsSigType dflags typ     where       prettyNames = intercalate ", " $ map (out dflags) names @@ -173,14 +179,14 @@          ppTyFams             | null $ tcdATs decl = ""-            | otherwise = (" " ++) . showSDocUnqual dflags . whereWrapper $ concat+            | otherwise = (" " ++) . showSDoc dflags . whereWrapper $ concat                 [ map pprTyFam (tcdATs decl)                 , map (pprTyFamInstDecl NotTopLevel . unLoc) (tcdATDefs decl)                 ]          pprTyFam :: LFamilyDecl GhcRn -> SDoc         pprTyFam (L _ at) = vcat' $ map text $-            mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at)+            mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at)          whereWrapper elems = vcat'             [ text "where" <+> lbrace@@ -198,9 +204,9 @@               ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily }               _                  -> decl -ppInstance :: DynFlags -> ClsInst -> [String]-ppInstance dflags x =-  [dropComment $ outWith (showSDocForUser dflags alwaysQualify) cls]+ppInstance :: DynFlags -> UnitState -> ClsInst -> [String]+ppInstance dflags unit_state x =+  [dropComment $ outWith (showSDocForUser dflags unit_state alwaysQualify) cls]   where     -- As per #168, we don't want safety information about the class     -- in Hoogle output. The easiest way to achieve this is to set the@@ -215,7 +221,7 @@  ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs-    = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :+    = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} :       concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)     where @@ -228,50 +234,61 @@ ppData _ _ _ = panic "ppData"  -- | for constructors, and named-fields...-lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String] lookupCon dflags subdocs (L _ name) = case lookup name subdocs of   Just (d, _) -> ppDocumentation dflags d   _ -> []  ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String]-ppCtor dflags dat subdocs con@ConDeclH98 {}+ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }   -- AZ:TODO get rid of the concatMap-   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con)+   = concatMap (lookupCon dflags subdocs) [con_name con] ++ f con_args'     where-        f (PrefixCon args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]-        f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]-        f (RecCon (L _ recs)) = f (PrefixCon $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat-                          [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) +++        f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]+        f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]+        f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat+                          [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++                            [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]                           | r <- map unLoc recs] -        funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)+        funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)         apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) -        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)+        typeSig nm flds = operator nm ++ " :: " +++                          outHsSigType dflags (unL $ mkEmptySigType $ funs flds)          -- We print the constructors as comma-separated list. See GHC         -- docs for con_names on why it is a list to begin with.-        name = commaSeparate dflags . map unLoc $ getConNames con+        name = commaSeparate dflags . map unL $ getConNames con -        tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n-        tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty+        tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n+        tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty         tyVarArg _ = panic "ppCtor"          resType = apps $ map reL $-                        (HsTyVar noExtField NotPromoted (reL (tcdName dat))) :+                        (HsTyVar noAnn NotPromoted (reL (tcdName dat))) :                         map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) -ppCtor dflags _dat subdocs con@(ConDeclGADT { })-   = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f+ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names+                                        , con_bndrs = L _ outer_bndrs+                                        , con_mb_cxt = mcxt+                                        , con_g_args = args+                                        , con_res_ty = res_ty })+   = concatMap (lookupCon dflags subdocs) names ++ [typeSig]     where-        f = [typeSig name (getGADTConTypeG con)]--        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)-        name = out dflags $ map unLoc $ getConNames con+        typeSig = operator name ++ " :: " ++ outHsSigType dflags con_sig_ty+        name = out dflags $ map unL names+        con_sig_ty = HsSig noExtField outer_bndrs theta_ty where+          theta_ty = case mcxt of+            Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })+            Nothing -> tau_ty+          tau_ty = foldr mkFunTy res_ty $+            case args of PrefixConGADT pos_args -> map hsScaledThing pos_args+                         RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds+          mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)  ppFixity :: DynFlags -> (Name, Fixity) -> [String]-ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)]+ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]   ---------------------------------------------------------------------@@ -294,7 +311,10 @@     lines header ++ ["" | header /= "" && isJust d] ++     maybe [] (showTags . markup (markupTag dflags)) d -mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String]+mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s++mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s  where    getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} module Haddock.Backends.Hyperlinker     ( ppHyperlinkedSource     , module Haddock.Backends.Hyperlinker.Types@@ -18,7 +19,7 @@ import System.Directory import System.FilePath -import GHC.Iface.Ext.Types  ( HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )+import GHC.Iface.Ext.Types  ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) import GHC.Types.SrcLoc     ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M@@ -70,10 +71,10 @@         -- Get the AST and tokens corresponding to the source file we want         let fileFs = mkFastString file             mast | M.size asts == 1 = snd <$> M.lookupMin asts-                 | otherwise        = M.lookup fileFs asts+                 | otherwise        = M.lookup (HiePath (mkFastString file)) asts+            tokens = parse df file rawSrc             ast = fromMaybe (emptyHieAst fileFs) mast             fullAst = recoverFullIfaceTypes df types ast-            tokens = parse df file rawSrc          -- Warn if we didn't find an AST, but there were still ASTs         if M.null asts

@@ -10,15 +10,18 @@  import qualified Data.ByteString as BS -import GHC.Types.Basic     ( IntegralLit(..) )+import GHC.Types.SourceText import GHC.Driver.Session-import GHC.Utils.Error     ( pprLocErrMsg )+import GHC.Utils.Error     ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString )+import GHC.Parser.Errors.Ppr ( pprError ) import GHC.Parser.Lexer    as Lexer                            ( P(..), ParseResult(..), PState(..), Token(..)-                           , mkPStatePure, lexer, mkParserFlags', getErrorMessages)+                           , initParserState, lexer, mkParserOpts, getErrorMessages) import GHC.Data.Bag         ( bagToList )-import GHC.Utils.Outputable ( showSDoc, panic, text, ($$) )+import GHC.Utils.Outputable ( text, ($$) )+import GHC.Utils.Panic      ( panic )+import GHC.Driver.Ppr       ( showSDoc ) import GHC.Types.SrcLoc import GHC.Data.StringBuffer ( StringBuffer, atEnd ) @@ -37,17 +40,16 @@ parse dflags fpath bs = case unP (go False []) initState of     POk _ toks -> reverse toks     PFailed pst ->-      let err:_ = bagToList (getErrorMessages pst dflags) in+      let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in       panic $ showSDoc dflags $-        text "Hyperlinker parse error:" $$ pprLocErrMsg err+        text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err   where -    initState = mkPStatePure pflags buf start+    initState = initParserState pflags buf start     buf = stringBufferFromByteString bs     start = mkRealSrcLoc (mkFastString fpath) 1 1-    pflags = mkParserFlags' (warningFlags dflags)+    pflags = mkParserOpts   (warningFlags dflags)                             (extensionFlags dflags)-                            (homeUnitId dflags)                             (safeImportsOn dflags)                             False -- lex Haddocks as comment tokens                             True  -- produce comment tokens@@ -240,7 +242,6 @@     ITline_prag         {} -> TkPragma     ITcolumn_prag       {} -> TkPragma     ITscc_prag          {} -> TkPragma-    ITgenerated_prag    {} -> TkPragma     ITunpack_prag       {} -> TkPragma     ITnounpack_prag     {} -> TkPragma     ITann_prag          {} -> TkPragma@@ -273,6 +274,7 @@     ITprefixminus          -> TkGlyph     ITbang                 -> TkGlyph     ITdot                  -> TkOperator+    ITproj              {} -> TkOperator     ITstar              {} -> TkOperator     ITtypeApp              -> TkGlyph     ITpercent              -> TkGlyph@@ -358,7 +360,7 @@     -- 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+    ITblockComment c _       | isPrefixOf "{-#" c       , isSuffixOf "#-}" c -> TkPragma       | otherwise          -> TkComment@@ -381,7 +383,6 @@     ITline_prag         {} -> True     ITcolumn_prag       {} -> True     ITscc_prag          {} -> True-    ITgenerated_prag    {} -> True     ITunpack_prag       {} -> True     ITnounpack_prag     {} -> True     ITann_prag          {} -> True

@@ -21,7 +21,7 @@ import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat ) import GHC.Iface.Type import GHC.Types.Name      ( getOccFS, getOccString )-import GHC.Utils.Outputable( showSDoc )+import GHC.Driver.Ppr      ( showSDoc ) import GHC.Types.Var       ( VarBndr(..) )  import System.FilePath.Posix ((</>), (<.>))

@@ -25,13 +25,13 @@ import qualified GHC.Utils.Ppr as Pretty  import GHC.Types.Basic        ( PromotionFlag(..) )-import GHC+import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name        ( nameOccName ) import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Core.Type         ( Specificity(..) ) import GHC.Data.FastString   ( unpackFS )-import GHC.Utils.Outputable  ( panic)+import GHC.Utils.Panic       ( panic)  import qualified Data.Map as Map import System.Directory@@ -108,7 +108,7 @@ -- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 -- often overflows the line). latex2String :: LaTeX -> String-latex2String = fullRender PageMode 90 1 txtPrinter ""+latex2String = fullRender (PageMode True) 90 1 txtPrinter ""  ppLaTeXTop    :: String@@ -177,7 +177,7 @@        body = processExports exports   ---  writeUtf8File (odir </> moduleLaTeXFile mdl) (show tex)+  writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender (PageMode True) 80 1 txtPrinter "" tex)  -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX@@ -215,10 +215,10 @@   processExport e $$ processExports es  -isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI)+isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsSigType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t))                        , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }-  | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t))+  | Map.null argDocs = Just (map unLoc lnames, unLoc (dropWildCards t)) isSimpleSig _ = Nothing  @@ -301,7 +301,7 @@ --    | Just _  <- tcdTyPats d    -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now   TyClD _ d@ClassDecl{}          -> ppClassDecl instances doc subdocs d unicode-  SigD _ (TypeSig _ lnames ty)   -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode+  SigD _ (TypeSig _ lnames ty)   -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (dropWildCards ty) unicode   SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode   ForD _ d                       -> ppFor (doc, fnArgsDoc) d unicode   InstD _ _                      -> empty@@ -313,7 +313,7 @@  ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode =-  ppFunSig Nothing doc [name] (hsSigTypeI typ) unicode+  ppFunSig Nothing doc [name] typ unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" --  error "foreign declarations are currently not supported by --latex" @@ -350,9 +350,9 @@      -- Individual equations of a closed type family     ppFamDeclEqn :: TyFamInstEqn DocNameI -> LaTeX-    ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n-                                            , feqn_rhs = rhs-                                            , feqn_pats = ts } })+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n+                         , feqn_rhs = rhs+                         , feqn_pats = ts })       = hsep [ ppAppNameTypeArgs n ts unicode              , equals              , ppType unicode (unLoc rhs)@@ -390,10 +390,11 @@      injAnn = case injectivity of       Nothing -> empty-      Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|")-                                                  : ppLDocName lhs-                                                  : arrow unicode-                                                  : map ppLDocName rhs)+      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|")+                                                    : ppLDocName lhs+                                                    : arrow unicode+                                                    : map ppLDocName rhs)+      Just _ -> empty   @@ -407,7 +408,7 @@  ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars                          , tcdRhs = ltype }) unicode-  = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode+  = ppTypeOrFunSig (mkHsImplicitSigTypeI ltype) doc (full, hdr, char '=') unicode   where     hdr  = hsep (keyword "type"                  : ppDocBinder name@@ -426,7 +427,7 @@   :: Maybe LaTeX         -- ^ a prefix to put right before the signature   -> DocForDecl DocName  -- ^ documentation   -> [DocName]           -- ^ pattern names in the pattern signature-  -> LHsType DocNameI    -- ^ type of the pattern synonym+  -> LHsSigType DocNameI -- ^ type of the pattern synonym   -> Bool                -- ^ unicode   -> LaTeX ppFunSig leader doc docnames (L _ typ) unicode =@@ -447,11 +448,11 @@           -> Bool                -- ^ unicode           -> LaTeX ppLPatSig doc docnames ty unicode-  = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigTypeI ty) unicode+  = ppFunSig (Just (keyword "pattern")) doc docnames ty unicode  -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed.-ppTypeOrFunSig :: HsType DocNameI+ppTypeOrFunSig :: HsSigType DocNameI                -> DocForDecl DocName  -- ^ documentation                -> ( LaTeX             --   first-line (no-argument docs only)                   , LaTeX             --   first-line (argument docs only)@@ -471,13 +472,24 @@ -- to the arguments. The output is a list of (leader/seperator, argument and -- its doc) ppSubSigLike :: Bool                  -- ^ unicode-             -> HsType DocNameI       -- ^ type signature+             -> HsSigType DocNameI    -- ^ type signature              -> FnArgsDoc DocName     -- ^ docs to add              -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`)              -> LaTeX                 -- ^ seperator (beginning of first line)              -> [(LaTeX, LaTeX)]      -- ^ arguments (leader/sep, type)-ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ+ppSubSigLike unicode typ argDocs subdocs leader = do_sig_args 0 leader typ   where+    do_sig_args :: Int -> LaTeX -> HsSigType DocNameI -> [(LaTeX, LaTeX)]+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =+      case outer_bndrs of+        HsOuterExplicit{hso_bndrs = bndrs} ->+          [ ( decltt leader+            , decltt (ppHsForAllTelescope (mkHsForAllInvisTeleI bndrs) unicode)+                <+> ppLType unicode ltype+            ) ]+        HsOuterImplicit{} -> do_largs n leader ltype++    do_largs :: Int -> LaTeX -> LHsType DocNameI -> [(LaTeX, LaTeX)]     do_largs n leader (L _ t) = do_args n leader t      arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs@@ -515,12 +527,16 @@     gadtOpen = char '{'  -ppTypeSig :: [Name] -> HsType DocNameI  -> Bool -> LaTeX+ppTypeSig :: [Name] -> HsSigType DocNameI  -> Bool -> LaTeX ppTypeSig nms ty unicode =   hsep (punctuate comma $ map ppSymName nms)     <+> dcolon unicode-    <+> ppType unicode ty+    <+> ppSigType unicode ty +ppHsOuterTyVarBndrs :: HsOuterTyVarBndrs flag DocNameI -> Bool -> LaTeX+ppHsOuterTyVarBndrs (HsOuterImplicit{}) _ = empty+ppHsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) unicode =+    hsep (forallSymbol unicode : ppTyVars bndrs) <> dot  ppHsForAllTelescope :: HsForAllTelescope DocNameI -> Bool -> LaTeX ppHsForAllTelescope tele unicode = case tele of@@ -582,23 +598,25 @@ -------------------------------------------------------------------------------  -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName-           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName+           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]            -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode =   keyword "class"-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)+  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty)   <+> ppAppDocNameNames summ n (tyvarNames tvs)   <+> ppFds fds unicode --ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX+-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX+ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX ppFds fds unicode =   if null fds then empty else     char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))   where-    fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>+    fundep (FunDep _ vars1 vars2)+                         = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>                            hsep (map (ppDocName . unLoc) vars2)+    fundep (XFunDep _) = error "ppFds"   -- TODO: associated type defaults, docs on default methods@@ -635,7 +653,7 @@      methodTable =       text "\\haddockpremethods{}" <> emph (text "Methods") $$-      vcat  [ ppFunSig leader doc names (hsSigTypeI typ) unicode+      vcat  [ ppFunSig leader doc names typ unicode             | L _ (ClassOpSig _ is_def lnames typ) <- lsigs             , let doc | is_def = noDocForDecl                       | otherwise = lookupAnySubdoc (head names) subdocs@@ -789,13 +807,13 @@     decl = case con of       ConDeclH98{ con_args = det                 , con_ex_tvs = tyVars-                , con_forall = L _ forall_+                , con_forall = forall_                 , con_mb_cxt = cxt-                } -> let context = unLoc (fromMaybe (noLoc []) cxt)+                } -> let context = fromMaybeContext cxt                          header_ = ppConstrHdr forall_ tyVars context unicode                      in case det of         -- Prefix constructor, e.g. 'Just a'-        PrefixCon args+        PrefixCon _ args           | hasArgDocs -> header_ <+> ppOcc           | otherwise -> hsep [ header_                               , ppOcc@@ -819,23 +837,25 @@         | otherwise -> hsep [ ppOcc                             , dcolon unicode                             -- ++AZ++ make this prepend "{..}" when it is a record style GADT-                            , ppLType unicode (getGADTConType con)+                            , ppLSigType unicode (getGADTConType con)                             ] -    fieldPart = case (con, getConArgsI con) of-        -- Record style GADTs-        (ConDeclGADT{}, RecCon _)            -> doConstrArgsWithDocs []--        -- Regular record declarations-        (_, RecCon (L _ fields))             -> doRecordFields fields--        -- Any GADT or a regular H98 prefix data constructor-        (_, PrefixCon args)     | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)--        -- An infix H98 data constructor-        (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])+    fieldPart = case con of+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of+          -- GADT record declarations+          RecConGADT _                    -> doConstrArgsWithDocs []+          -- GADT prefix data constructors+          PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args)+          _                               -> empty -        _ -> empty+        ConDeclH98{con_args = con_args'} -> case con_args' of+          -- H98 record declarations+          RecCon (L _ fields)             -> doRecordFields fields+          -- H98 prefix data constructors+          PrefixCon _ args | hasArgDocs   -> doConstrArgsWithDocs (map hsScaledThing args)+          -- H98 infix data constructor+          InfixCon arg1 arg2 | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing [arg1,arg2])+          _                               -> empty      doRecordFields fields =       vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl@@ -876,7 +896,7 @@   -- | Pretty-print a bundled pattern synonym-ppSideBySidePat :: [Located DocName]    -- ^ pattern name(s)+ppSideBySidePat :: [LocatedN DocName]   -- ^ pattern name(s)                 -> LHsSigType DocNameI  -- ^ type of pattern(s)                 -> DocForDecl DocName   -- ^ doc map                 -> Bool                 -- ^ unicode@@ -892,18 +912,16 @@          | otherwise = hsep [ keyword "pattern"                             , ppOcc                             , dcolon unicode-                            , ppLType unicode (hsSigTypeI typ)+                            , ppLSigType unicode typ                             ]      fieldPart       | not hasArgDocs = empty       | otherwise = vcat           [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r-          | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode)+          | (l,r) <- ppSubSigLike unicode (unLoc typ) argDocs [] (dcolon unicode)           ] -    patTy = hsSigTypeI typ-     mDoc = fmap _doc $ combineDocumentation doc  @@ -965,9 +983,11 @@ -------------------------------------------------------------------------------  -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX-ppLContext        = ppContext        . unLoc-ppLContextNoArrow = ppContextNoArrow . unLoc+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX+ppLContext        Nothing _ = empty+ppLContext        (Just ctxt) unicode  = ppContext        (unLoc ctxt) unicode+ppLContextNoArrow Nothing _ = empty+ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode  ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing@@ -1019,17 +1039,23 @@ -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX+ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX ppLType       unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y) +ppLSigType :: Bool -> LHsSigType DocNameI -> LaTeX+ppLSigType unicode y = ppSigType unicode (unLoc y)+ ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType       unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode-ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode ppFunLhType  unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType    unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode +ppSigType :: Bool -> HsSigType DocNameI -> LaTeX+ppSigType unicode sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode+ ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <>@@ -1061,6 +1087,11 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell +ppr_sig_ty :: HsSigType DocNameI -> Bool -> LaTeX+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode+  = sep [ ppHsOuterTyVarBndrs outer_bndrs unicode+        , ppr_mono_lty ltype unicode ]+ ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode @@ -1076,9 +1107,9 @@   = sep [ ppr_mono_lty ty1 u         , arr <+> ppr_mono_lty ty2 u ]    where arr = case mult of-                 HsLinearArrow _ -> lollipop u+                 HsLinearArrow _ _ -> lollipop u                  HsUnrestrictedArrow _ -> arrow u-                 HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u+                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u  ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name@@ -1090,7 +1121,7 @@ ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u ppr_mono_ty (HsSpliceTy v _)    _ = absurd v ppr_mono_ty (HsRecTy {})        _ = text "{..}"-ppr_mono_ty (XHsType (NHsCoreTy {}))  _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (XHsType {})        _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys@@ -1123,6 +1154,7 @@ ppr_tylit :: HsTyLit -> Bool -> LaTeX ppr_tylit (HsNumTy _ n) _ = integer n ppr_tylit (HsStrTy _ s) _ = text (show s)+ppr_tylit (HsCharTy _ c) _ = text (show c)   -- XXX: Ok in verbatim, but not otherwise   -- XXX: Do something with Unicode parameter? @@ -1158,7 +1190,7 @@ ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName -ppLDocName :: Located DocName -> LaTeX+ppLDocName :: GenLocated l DocName -> LaTeX ppLDocName (L _ d) = ppDocName d  

@@ -11,11 +11,10 @@ -- Stability   :  experimental -- Portability :  portable ------------------------------------------------------------------------------{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-}+{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml (   ppHtml, copyHtmlBits,   ppHtmlIndex, ppHtmlContents,-  ppJsonIndex ) where  @@ -39,22 +38,18 @@  import Control.Monad         ( when, unless ) import qualified Data.ByteString.Builder as Builder-import Data.Bifunctor        ( bimap ) import Data.Char             ( toUpper, isSpace )-import Data.Either           ( partitionEithers )-import Data.Foldable         ( traverse_) import Data.List             ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( (</>) ) import qualified System.IO as IO-import qualified System.FilePath as FilePath import Data.Map              ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) import Data.Ord              ( comparing ) -import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )+import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor ) import GHC.Types.Name import GHC.Unit.State @@ -73,7 +68,6 @@        -> Maybe String                 -- ^ The mathjax URL (--mathjax)        -> SourceURLs                   -- ^ The source URL (--source)        -> WikiURLs                     -- ^ The wiki URL (--wiki)-       -> BaseURL                      -- ^ The base URL (--base-url)        -> Maybe String                 -- ^ The contents URL (--use-contents)        -> Maybe String                 -- ^ The index URL (--use-index)        -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)@@ -85,7 +79,7 @@  ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue         themes maybe_mathjax_url maybe_source_url maybe_wiki_url-        maybe_base_url maybe_contents_url maybe_index_url unicode+        maybe_contents_url maybe_index_url unicode         pkg qual debug withQuickjump = do   let     visible_ifaces = filter visible ifaces@@ -103,12 +97,12 @@       themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url       (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug -  when withQuickjump $-    ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual-      visible_ifaces []+    when withQuickjump $+      ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual+        visible_ifaces    mapM_ (ppHtmlModule odir doctitle themes-           maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+           maybe_mathjax_url maybe_source_url maybe_wiki_url            maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces  @@ -125,23 +119,16 @@   return ()  -headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html-headHtml docTitle themes mathjax_url base_url =-      header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url)-    <<+headHtml :: String -> Themes -> Maybe String -> Html+headHtml docTitle themes mathjax_url =+  header <<     [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"]     , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"]     , thetitle << docTitle-    , styleSheet base_url themes-    , thelink ! [ rel "stylesheet"-                , thetype "text/css"-                , href (withBaseURL base_url quickJumpCssFile) ]-             << noHtml+    , styleSheet themes+    , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml     , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml-    , script ! [ src (withBaseURL base_url haddockJsFile)-               , emptyAttr "async"-               , thetype "text/javascript" ]-            << noHtml+    , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml     , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf     , script ! [src mjUrl, thetype "text/javascript"] << noHtml     ]@@ -294,7 +281,7 @@          | iface <- ifaces          , instIsSig iface]       html =-        headHtml doctitle themes mathjax_url Nothing ++++        headHtml doctitle themes mathjax_url +++         bodyHtml doctitle Nothing           maybe_source_url maybe_wiki_url           Nothing maybe_index_url << [@@ -374,35 +361,6 @@ -- * Generate the index -------------------------------------------------------------------------------- -data JsonIndexEntry = JsonIndexEntry {-      jieHtmlFragment :: String,-      jieName         :: String,-      jieModule       :: String,-      jieLink         :: String-    }-  deriving Show--instance ToJSON JsonIndexEntry where-    toJSON JsonIndexEntry-        { jieHtmlFragment-        , jieName-        , jieModule-        , jieLink } =-      Object-        [ "display_html" .= String jieHtmlFragment-        , "name"         .= String jieName-        , "module"       .= String jieModule-        , "link"         .= String jieLink-        ]--instance FromJSON JsonIndexEntry where-    parseJSON = withObject "JsonIndexEntry" $ \v ->-      JsonIndexEntry-        <$> v .: "display_html"-        <*> v .: "name"-        <*> v .: "module"-        <*> v .: "link"- ppJsonIndex :: FilePath            -> SourceURLs                   -- ^ The source URL (--source)            -> WikiURLs                     -- ^ The wiki URL (--wiki)@@ -410,50 +368,34 @@            -> Maybe Package            -> QualOption            -> [Interface]-           -> [FilePath]                   -- ^ file paths to interface files-                                           -- (--read-interface)            -> IO ()-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do   createDirectoryIfMissing True odir-  (errors, installedIndexes) <--    partitionEithers-      <$> traverse-            (\ifaceFile ->-              let indexFile = takeDirectory ifaceFile-                    FilePath.</> "doc-index.json" in-                  bimap (indexFile,) (map (fixLink ifaceFile))-              <$> eitherDecodeFile @[JsonIndexEntry] indexFile)-            installedIfacesPaths-  traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)-            errors-  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->-      Builder.hPutBuilder-        h (encodeToBuilder (encodeIndexes (concat installedIndexes)))+  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do+    Builder.hPutBuilder h (encodeToBuilder modules)   where-    encodeIndexes :: [JsonIndexEntry] -> Value-    encodeIndexes installedIndexes =-      toJSON-        (concatMap fromInterface ifaces-         ++ installedIndexes)+    modules :: Value+    modules = Array (concatMap goInterface ifaces) -    fromInterface :: Interface -> [JsonIndexEntry]-    fromInterface iface =-        mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface+    goInterface :: Interface -> [Value]+    goInterface iface =+        concatMap (goExport mdl qual) (ifaceRnExportItems iface)       where         aliases = ifaceModuleAliases iface         qual    = makeModuleQual qual_opt aliases mdl         mdl     = ifaceMod iface -    mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry-    mkIndex mdl qual item+    goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]+    goExport mdl qual item       | Just item_html <- processExport True links_info unicode pkg qual item-      = Just JsonIndexEntry-          { jieHtmlFragment = showHtmlFragment item_html-          , jieName         = unwords (map getOccString names)-          , jieModule       = moduleString mdl-          , jieLink         = fromMaybe "" (listToMaybe (map (nameLink mdl) names))-          }-      | otherwise = Nothing+      = [ Object+            [ "display_html" .= String (showHtmlFragment item_html)+            , "name"         .= String (unwords (map getOccString names))+            , "module"       .= String (moduleString mdl)+            , "link"         .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))+            ]+        ]+      | otherwise = []       where         names = exportName item ++ exportSubs item @@ -471,13 +413,6 @@      links_info = (maybe_source_url, maybe_wiki_url) -    -- update link using relative path to output directory-    fixLink :: FilePath-            -> JsonIndexEntry -> JsonIndexEntry-    fixLink ifaceFile jie = -      jie { jieLink = makeRelative odir (takeDirectory ifaceFile)-                        FilePath.</> jieLink jie }- ppHtmlIndex :: FilePath             -> String             -> Maybe String@@ -506,7 +441,7 @@    where     indexPage showLetters ch items =-      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing ++++      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++       bodyHtml doctitle Nothing         maybe_source_url maybe_wiki_url         maybe_contents_url Nothing << [@@ -606,11 +541,11 @@  ppHtmlModule         :: FilePath -> String -> Themes-        -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL+        -> Maybe String -> SourceURLs -> WikiURLs         -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption         -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes-  maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+  maybe_mathjax_url maybe_source_url maybe_wiki_url   maybe_contents_url maybe_index_url unicode pkg qual debug iface = do   let       mdl = ifaceMod iface@@ -628,7 +563,7 @@         = toHtml mdl_str       real_qual = makeModuleQual qual aliases mdl       html =-        headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url ++++        headHtml mdl_str_annot themes maybe_mathjax_url +++         bodyHtml doctitle (Just iface)           maybe_source_url maybe_wiki_url           maybe_contents_url maybe_index_url << [

@@ -37,7 +37,7 @@  import GHC.Core.Type ( Specificity(..) ) import GHC.Types.Basic (PromotionFlag(..), isPromoted)-import GHC hiding (LexicalFixity(..))+import GHC hiding (LexicalFixity(..), fromMaybeContext) import GHC.Exts import GHC.Types.Name import GHC.Data.BooleanFormula@@ -58,40 +58,40 @@        -> Qualification        -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of-  TyClD _ (FamDecl _ d)          -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual-  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual-  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual-  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual-  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames-                                         (hsSigWcType lty) fixities splice unicode pkg qual-  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames-                                         (hsSigTypeI lty) fixities splice unicode pkg qual-  ForD _ d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual+  TyClD _ (FamDecl _ d)          -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual+  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual+  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual+  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual+  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames+                                         (dropWildCards lty) fixities splice unicode pkg qual+  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames+                                         lty fixities splice unicode pkg qual+  ForD _ d                       -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual   InstD _ _                      -> noHtml   DerivD _ _                     -> noHtml   _                              -> error "declaration not supported by ppDecl"   ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->-             [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->+             [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->              Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =   ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities            splice unicode pkg qual  ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->-            [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] ->+            [DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->             Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual =   ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ)             splice unicode pkg qual HideEmptyContexts   where-    pp_typ = ppLType unicode qual HideEmptyContexts typ+    pp_typ = ppLSigType unicode qual HideEmptyContexts typ  -- | Pretty print a pattern synonym ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName-          -> [Located DocName]     -- ^ names of patterns in declaration-          -> LHsType DocNameI      -- ^ type of patterns in declaration+          -> [LocatedN DocName]     -- ^ names of patterns in declaration+          -> LHsSigType DocNameI   -- ^ type of patterns in declaration           -> [(DocName, Fixity)]           -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual =@@ -102,7 +102,7 @@   ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->-             [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) ->+             [DocName] -> [(DocName, Fixity)] -> (HsSigType DocNameI, Html) ->              Splice -> Unicode -> Maybe Package -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)           splice unicode pkg qual emptyCtxts =@@ -119,7 +119,7 @@       | otherwise = html <+> ppFixities fixities qual  -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsSigType DocNameI                -> DocForDecl DocName -> (Html, Html, Html)                -> Splice -> Unicode -> Maybe Package -> Qualification                -> HideEmptyContexts -> Html@@ -140,15 +140,24 @@ -- If one passes in a list of the available subdocs, any top-level `HsRecTy` -- found will be expanded out into their fields. ppSubSigLike :: Unicode -> Qualification-             -> HsType DocNameI                  -- ^ type signature+             -> HsSigType DocNameI               -- ^ type signature              -> FnArgsDoc DocName                -- ^ docs to add              -> [(DocName, DocForDecl DocName)]  -- ^ all subdocs (useful when                                                  -- we expand an `HsRecTy`)              -> Html -> HideEmptyContexts -> [SubDecl]-ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ+ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep typ   where+    do_sig_args :: Int -> Html -> HsSigType DocNameI -> [SubDecl]+    do_sig_args n leader (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) =+      case outer_bndrs of+        HsOuterExplicit{hso_bndrs = bndrs} -> do_largs n (leader' bndrs) ltype+        HsOuterImplicit{}                  -> do_largs n leader          ltype+      where+        leader' bndrs = leader <+> ppForAllPart unicode qual (mkHsForAllInvisTeleI bndrs)+     argDoc n = Map.lookup n argDocs +    do_largs :: Int -> Html -> LHsType DocNameI -> [SubDecl]     do_largs n leader (L _ t) = do_args n leader t      do_args :: Int -> Html -> HsType DocNameI -> [SubDecl]@@ -158,7 +167,7 @@         leader' = leader <+> ppForAllPart unicode qual tele      do_args n leader (HsQualTy _ lctxt ltype)-      | null (unLoc lctxt)+      | null (fromMaybeContext lctxt)       = do_largs n leader ltype       | otherwise       = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])@@ -222,7 +231,7 @@       -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities       splice unicode pkg qual-  = ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ) fixities splice unicode pkg qual+  = ppFunSig summary links loc noHtml doc [name] typ fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor"  @@ -233,13 +242,14 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars                                                 , tcdRhs = ltype })         splice unicode pkg qual-  = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc+  = ppTypeOrFunSig summary links loc [name] sig_type doc                    (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)                    splice unicode pkg qual ShowEmptyToplevelContexts   where+    sig_type = mkHsImplicitSigTypeI ltype     hdr  = hsep ([keyword "type", ppBinder summary occ]                  ++ ppTyVars unicode qual (hsQTvExplicit ltyvars))-    full = hdr <+> equals <+> ppPatSigType unicode qual ltype+    full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type)     occ  = nameOccName . getName $ name     fixs       | summary   = noHtml@@ -253,15 +263,14 @@   where     htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan-            -> [DocName] -> HsType DocNameI+            -> [DocName] -> HsSigType DocNameI             -> Html ppSimpleSig links splice unicode qual emptyCtxts loc names typ =     topDeclElem' names $ ppTypeSig True occNames ppTyp unicode   where     topDeclElem' = topDeclElem links loc splice-    ppTyp = ppType unicode qual emptyCtxts typ+    ppTyp = ppSigType unicode qual emptyCtxts typ     occNames = map getOccName names  @@ -301,9 +310,9 @@      -- Individual equation of a closed type family     ppFamDeclEqn :: TyFamInstEqn DocNameI -> SubDecl-    ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n-                                            , feqn_rhs = rhs-                                            , feqn_pats = ts } })+    ppFamDeclEqn (FamEqn { feqn_tycon = L _ n+                         , feqn_rhs = rhs+                         , feqn_pats = ts })       = ( ppAppNameTypeArgs n ts unicode qual           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)         , Nothing@@ -321,7 +330,7 @@                                   , pfdTyVars = tvs                                   , pfdLName = L loc name })                 unicode qual =-    topDeclElem links loc splice [name] leader+    topDeclElem links (locA loc) splice [name] leader   where     leader = hsep [ ppFamilyLeader True info                   , ppAppNameTypes name (map unLoc tvs) unicode qual@@ -352,10 +361,11 @@      injAnn = case injectivity of       Nothing -> noHtml-      Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|"-                                                  : ppLDocName qual Raw lhs-                                                  : arrow unicode-                                                  : map (ppLDocName qual Raw) rhs)+      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|"+                                                    : ppLDocName qual Raw lhs+                                                    : arrow unicode+                                                    : map (ppLDocName qual Raw) rhs)+      Just _ -> error "ppFamHeader:XInjectivityAnn"  -- | Print the keywords that begin the family declaration ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html@@ -426,10 +436,12 @@ -------------------------------------------------------------------------------  -ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode                               -> Qualification -> HideEmptyContexts -> Html-ppLContext        = ppContext        . unLoc-ppLContextNoArrow = ppContextNoArrow . unLoc+ppLContext        Nothing  u q h = ppContext        []        u q h+ppLContext        (Just c) u q h = ppContext        (unLoc c) u q h+ppLContextNoArrow Nothing  u q h = ppContextNoArrow []        u q h+ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h  ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $@@ -463,22 +475,23 @@ -------------------------------------------------------------------------------  -ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName-           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName+           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]            -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual =   keyword "class"-  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)+  <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)   <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)   <+> ppFds fds unicode qual  -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html+ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html ppFds fds unicode qual =   if null fds then noHtml else         char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))   where-        fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2+        fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2+        fundep (XFunDep _) = error "ppFds"         ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)  ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan@@ -497,7 +510,7 @@                  -- ToDo: add associated type defaults -            [ ppFunSig summary links loc noHtml doc names (hsSigTypeI typ)+            [ ppFunSig summary links loc noHtml doc names typ                        [] splice unicode pkg qual               | L _ (ClassOpSig _ False lnames typ) <- sigs               , let doc = lookupAnySubdoc (head names) subdocs@@ -561,14 +574,14 @@     lookupDAT name = Map.lookup (getName name) defaultAssocTys     defaultAssocTys = Map.fromList       [ (getName name, (vs, typ))-      | L _ (TyFamInstDecl (HsIB _ (FamEqn { feqn_rhs = typ-                                           , feqn_tycon = L _ name-                                           , feqn_pats = vs }))) <- atsDefs+      | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ+                                     , feqn_tycon = L _ name+                                     , feqn_pats = vs })) <- atsDefs       ]      -- Methods     methodBit = subMethods-      [ ppFunSig summary links loc noHtml doc [name] (hsSigTypeI typ)+      [ ppFunSig summary links loc noHtml doc [name] typ                  subfixs splice unicode pkg qual           <+>         subDefaults (maybeToList defSigs)@@ -583,7 +596,7 @@      -- Default methods     ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default")-      d' [n] (hsSigTypeI t) [] splice unicode pkg qual+      d' [n] t [] splice unicode pkg qual      lookupDM name = Map.lookup (getOccString name) defaultMethods     defaultMethods = Map.fromList@@ -634,13 +647,11 @@   -- force Splice = True to use line URLs   where     instName = getOccString origin-    instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName)+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)     instDecl no (inst, mdoc, loc, mdl) =-        (instanceAnchor, mModule, mdl, loc)-      where-        instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"-        mModule = ppInstHead links splice unicode qual mdoc origin False no inst mdl+        ((ppInstHead links splice unicode qual mdoc origin False no inst mdl), mdl, loc) + ppOrphanInstances :: LinksInfo                   -> [DocInstance DocNameI]                   -> Splice -> Unicode -> Maybe Package -> Qualification@@ -651,12 +662,9 @@     instOrigin :: InstHead name -> InstOrigin (IdP name)     instOrigin inst = OriginClass (ihdClsName inst) -    instDecl :: Int -> DocInstance DocNameI -> (String, SubDecl, Maybe Module, Located DocName)+    instDecl :: Int -> DocInstance DocNameI -> (SubDecl, Maybe Module, Located DocName)     instDecl no (inst, mdoc, loc, mdl) =-        (instanceAnchor, mModule, mdl, loc)-      where-        instanceAnchor = getOccString (ihdClsName inst) <> "_" <> show no <> ":"-        mModule = ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing+        ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst Nothing), mdl, loc)   ppInstHead :: LinksInfo -> Splice -> Unicode -> Qualification@@ -714,10 +722,10 @@ ppInstanceSigs links splice unicode qual sigs = do     TypeSig _ lnames typ <- sigs     let names = map unLoc lnames-        L _ rtyp = hsSigWcType typ+        L _ rtyp = dropWildCards typ     -- Instance methods signatures are synified and thus don't have a useful     -- SrcSpan value. Use the methods name location instead.-    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp+    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp   lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2@@ -777,7 +785,7 @@     pats1 = [ hsep [ keyword "pattern"                    , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames                    , dcolon unicode-                   , ppPatSigType unicode qual (hsSigTypeI typ)+                   , ppPatSigType unicode qual typ                    ]             | (SigD _ (PatSynSig _ lnames typ),_) <- pats             ]@@ -822,7 +830,7 @@       [ ppSideBySideConstr subdocs subfixs unicode pkg qual c       | c <- cons       , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)-                                            (map unLoc (getConNamesI (unLoc c)))) fixities+                                            (map unL (getConNamesI (unLoc c)))) fixities       ]      patternBit = subPatterns pkg qual@@ -849,14 +857,14 @@   = case con of       ConDeclH98{ con_args = det                 , con_ex_tvs = tyVars-                , con_forall = L _ forall_+                , con_forall = forall_                 , con_mb_cxt = cxt-                } -> let context = unLoc (fromMaybe (noLoc []) cxt)+                } -> let context = fromMaybeContext cxt                          header_ = ppConstrHdr forall_ tyVars context unicode qual                      in case det of          -- Prefix constructor, e.g. 'Just a'-        PrefixCon args ->+        PrefixCon _ args ->           ( header_ <+> hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)           , noHtml           , noHtml@@ -883,13 +891,13 @@        -- GADT constructor, e.g. 'Foo :: Int -> Foo'       ConDeclGADT {} ->-          ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ]+          ( hsep [ ppOcc, dcolon unicode, ppLSigType unicode qual HideEmptyContexts (getGADTConType con) ]           , noHtml           , noHtml           )    where-    occ        = map (nameOccName . getName . unLoc) $ getConNamesI con+    occ        = map (nameOccName . getName . unL) $ getConNamesI con     ppOcc      = hsep (punctuate comma (map (ppBinder summary) occ))     ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -906,10 +914,10 @@    )  where     -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)-    aConName = unLoc (head (getConNamesI con))+    aConName = unL (head (getConNamesI con))      fixity   = ppFixities fixities qual-    occ      = map (nameOccName . getName . unLoc) $ getConNamesI con+    occ      = map (nameOccName . getName . unL) $ getConNamesI con      ppOcc      = hsep (punctuate comma (map (ppBinder False) occ))     ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))@@ -921,13 +929,13 @@     decl = case con of       ConDeclH98{ con_args = det                 , con_ex_tvs = tyVars-                , con_forall = L _ forall_+                , con_forall = forall_                 , con_mb_cxt = cxt-                } -> let context = unLoc (fromMaybe (noLoc []) cxt)+                } -> let context = fromMaybeContext cxt                          header_ = ppConstrHdr forall_ tyVars context unicode qual                      in case det of         -- Prefix constructor, e.g. 'Just a'-        PrefixCon args+        PrefixCon _ args           | hasArgDocs -> header_ <+> ppOcc <+> fixity           | otherwise -> hsep [ header_ <+> ppOcc                               , hsep (map (ppLParendType unicode qual HideEmptyContexts . hsScaledThing) args)@@ -952,24 +960,26 @@           | otherwise -> hsep [ ppOcc                               , dcolon unicode                               -- ++AZ++ make this prepend "{..}" when it is a record style GADT-                              , ppLType unicode qual HideEmptyContexts (getGADTConType con)+                              , ppLSigType unicode qual HideEmptyContexts (getGADTConType con)                               , fixity                               ] -    fieldPart = case (con, getConArgsI con) of-        -- Record style GADTs-        (ConDeclGADT{}, RecCon _)            -> [ doConstrArgsWithDocs [] ]--        -- Regular record declarations-        (_, RecCon (L _ fields))             -> [ doRecordFields fields ]--        -- Any GADT or a regular H98 prefix data constructor-        (_, PrefixCon args)     | hasArgDocs -> [ doConstrArgsWithDocs args ]--        -- An infix H98 data constructor-        (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]+    fieldPart = case con of+        ConDeclGADT{con_g_args = con_args'} -> case con_args' of+          -- GADT record declarations+          RecConGADT _                    -> [ doConstrArgsWithDocs [] ]+          -- GADT prefix data constructors+          PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ]+          _                               -> [] -        _ -> []+        ConDeclH98{con_args = con_args'} -> case con_args' of+          -- H98 record declarations+          RecCon (L _ fields)             -> [ doRecordFields fields ]+          -- H98 prefix data constructors+          PrefixCon _ args | hasArgDocs   -> [ doConstrArgsWithDocs args ]+          -- H98 infix data constructor+          InfixCon arg1 arg2 | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ]+          _                               -> []      doRecordFields fields = subFields pkg qual       (map (ppSideBySideField subdocs unicode qual) (map unLoc fields))@@ -986,7 +996,7 @@      -- don't use "con_doc con", in case it's reconstructed from a .hi file,     -- or also because we want Haddock to do the doc-parsing, not GHC.-    mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>=+    mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>=             combineDocumentation . fst  @@ -1036,7 +1046,7 @@  -- | Pretty print an expanded pattern (for bundled patterns) ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification-                   -> [Located DocName]    -- ^ pattern name(s)+                   -> [LocatedN DocName]   -- ^ pattern name(s)                    -> LHsSigType DocNameI  -- ^ type of pattern(s)                    -> DocForDecl DocName   -- ^ doc map                    -> SubDecl@@ -1054,18 +1064,17 @@          | otherwise = hsep [ keyword "pattern"                             , ppOcc                             , dcolon unicode-                            , ppPatSigType unicode qual (hsSigTypeI typ)+                            , ppPatSigType unicode qual typ                             , fixity                             ]      fieldPart       | not hasArgDocs = []-      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy)+      | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc typ)                                                         argDocs [] (dcolon unicode)                                                         emptyCtxt) ] -    patTy = hsSigTypeI typ-    emptyCtxt = patSigContext patTy+    emptyCtxt = patSigContext typ   -- | Print the LHS of a data\/newtype declaration.@@ -1114,11 +1123,14 @@ -- * Rendering of HsType -------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppLSigType ::  Unicode -> Qualification -> HideEmptyContexts -> LHsSigType DocNameI -> Html+ppLSigType unicode qual emptyCtxts y = ppSigType unicode qual emptyCtxts (unLoc y)+ ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts @@ -1127,6 +1139,9 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts +ppSigType ::  Unicode -> Qualification -> HideEmptyContexts -> HsSigType DocNameI -> Html+ppSigType unicode qual emptyCtxts sig_ty = ppr_sig_ty (reparenSigType sig_ty) unicode qual emptyCtxts+ ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <>@@ -1140,7 +1155,7 @@   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 <+>+      parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>               ppLKind unicode qual kind)  instance RenderableBndrFlag Specificity where@@ -1149,10 +1164,10 @@   ppHsTyVarBndr _       qual (UserTyVar _ InferredSpec (L _ name)) =       braces $ ppDocName qual Raw False name   ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =-      parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+      parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>               ppLKind unicode qual kind)   ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =-      braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>+      braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>               ppLKind unicode qual kind)  ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html@@ -1161,32 +1176,38 @@ ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -patSigContext :: LHsType name -> HideEmptyContexts-patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts-                  | otherwise = HideEmptyContexts+patSigContext :: LHsSigType DocNameI -> HideEmptyContexts+patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ =  ShowEmptyToplevelContexts+                      | otherwise = HideEmptyContexts   where-    hasNonEmptyContext :: LHsType name -> Bool+    typ = sig_body (unLoc sig_typ)+     hasNonEmptyContext t =       case unLoc t of         HsForAllTy _ _ s -> hasNonEmptyContext s-        HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True+        HsQualTy _ cxt s -> if null (fromMaybeContext 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)+        HsQualTy _ cxt _ -> null (fromMaybeContext cxt)         HsFunTy _ _ _ s    -> isFirstContextEmpty s         _ -> False   -- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in -- the right 'HideEmptyContext' value)-ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html+ppPatSigType :: Unicode -> Qualification -> LHsSigType DocNameI -> Html ppPatSigType unicode qual typ =-  let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ+  let emptyCtxts = patSigContext typ in ppLSigType unicode qual emptyCtxts typ +ppHsOuterTyVarBndrs :: RenderableBndrFlag flag+                    => Unicode -> Qualification -> HsOuterTyVarBndrs flag DocNameI -> Html+ppHsOuterTyVarBndrs unicode qual outer_bndrs = case outer_bndrs of+  HsOuterImplicit{} -> noHtml+  HsOuterExplicit{hso_bndrs = bndrs} ->+    hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot  ppForAllPart :: Unicode -> Qualification -> HsForAllTelescope DocNameI -> Html ppForAllPart unicode qual tele = case tele of@@ -1196,6 +1217,10 @@   HsForAllInvis { hsf_invis_bndrs = bndrs } ->     hsep (forallSymbol unicode : ppTyVars unicode qual bndrs) +++ dot +ppr_sig_ty :: HsSigType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html+ppr_sig_ty (HsSig { sig_bndrs = outer_bndrs, sig_body = ltype }) unicode qual emptyCtxts+  = ppHsOuterTyVarBndrs unicode qual outer_bndrs <+> ppr_mono_lty ltype unicode qual emptyCtxts+ ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ty = ppr_mono_ty (unLoc ty) @@ -1223,9 +1248,9 @@        , arr <+> ppr_mono_lty ty2 u q e        ]    where arr = case mult of-                 HsLinearArrow _ -> lollipop u+                 HsLinearArrow _ _ -> lollipop u                  HsUnrestrictedArrow _ -> arrow u-                 HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u+                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u  ppr_mono_ty (HsTupleTy _ con tys) u q _ =   tupleParens con (map (ppLType u q HideEmptyContexts) tys)@@ -1241,7 +1266,7 @@        -- Can now legally occur in ConDeclGADT, the output here is to provide a        -- placeholder in the signature, which is followed by the field        -- declarations.-ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty (XHsType {})        _ _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys@@ -1260,7 +1285,7 @@     -- `(:)` is valid in type signature only as constructor to promoted list     -- and needs to be quoted in code so we explicitly quote it here too.     ppr_op-        | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'+        | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'         | otherwise = ppr_op'     ppr_op' = ppLDocName qual Infix op @@ -1277,3 +1302,4 @@ ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s)+ppr_tylit (HsCharTy _ c) = toHtml (show c)

@@ -31,7 +31,7 @@ import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) -import GHC+import GHC hiding (anchor) import GHC.Types.Name  

@@ -51,7 +51,7 @@ import Data.Maybe (fromMaybe)  import GHC.Data.FastString ( unpackFS )-import GHC+import GHC hiding (anchor) import GHC.Types.Name (nameOccName)  --------------------------------------------------------------------------------@@ -153,16 +153,16 @@  -- | Sub table with source information (optional). subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool-            -> [(String, SubDecl, Maybe Module, Located DocName)] -> Maybe Html+            -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html subTableSrc _ _ _ _ [] = Nothing subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls)   where-    subRow (instanchor, (decl, mdoc, subs), mdl, L loc dn) =+    subRow ((decl, mdoc, subs), mdl, L loc dn) =       (td ! [theclass "src clearfix"] <<         (thespan ! [theclass "inst-left"] << decl)         <+> linkHtml loc mdl dn       <->-      docElement td << fmap (docToHtml (Just instanchor) pkg qual) mdoc+      docElement td << fmap (docToHtml Nothing pkg qual) mdoc       )       : map (cell . (td <<)) subs @@ -201,7 +201,7 @@ subInstances :: Maybe Package -> Qualification              -> String -- ^ Class name, used for anchor generation              -> LinksInfo -> Bool-             -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html+             -> [(SubDecl, Maybe Module, Located DocName)] -> Html subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable   where     wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents))@@ -214,7 +214,7 @@  subOrphanInstances :: Maybe Package -> Qualification                    -> LinksInfo -> Bool-                   -> [(String, SubDecl, Maybe Module, Located DocName)] -> Html+                   -> [(SubDecl, Maybe Module, Located DocName)] -> Html subOrphanInstances pkg qual lnks splice  = maybe noHtml wrap . instTable   where     wrap = ((h1 << "Orphan instances") +++)

@@ -27,7 +27,7 @@ import qualified Data.Map as M import Data.List ( stripPrefix ) -import GHC hiding (LexicalFixity(..))+import GHC hiding (LexicalFixity(..), anchor) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Data.FastString (unpackFS)@@ -57,8 +57,9 @@     occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName  -- The Bool indicates if it is to be rendered in infix notation-ppLDocName :: Qualification -> Notation -> Located DocName -> Html+ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html ppLDocName qual notation (L _ d) = ppDocName qual notation True d+  ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html ppDocName qual notation insertAnchors docName =

@@ -17,7 +17,6 @@     where  import Haddock.Options-import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL )  import Control.Monad (liftM) import Data.Char (toLower)@@ -177,13 +176,13 @@ cssFiles ts = nub $ concatMap themeFiles ts  -styleSheet :: BaseURL -> Themes -> Html-styleSheet base_url ts = toHtml $ zipWith mkLink rels ts+styleSheet :: Themes -> Html+styleSheet ts = toHtml $ zipWith mkLink rels ts   where     rels = "stylesheet" : repeat "alternate stylesheet"     mkLink aRel t =       thelink-        ! [ href (withBaseURL base_url (themeHref t)),  rel aRel, thetype "text/css",+        ! [ href (themeHref t),  rel aRel, thetype "text/css",             XHtml.title (themeName t)           ]         << noHtml

@@ -12,8 +12,6 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types (   SourceURLs, WikiURLs,-  BaseURL,-  withBaseURL,   LinksInfo,   Splice,   Unicode,@@ -22,21 +20,12 @@  import Data.Map import GHC-import qualified System.FilePath as FilePath   -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) --- | base url for loading js, json, css resources.  The default is "."----type BaseURL = Maybe String---- TODO: we shouldn't use 'FilePath.</>'-withBaseURL :: BaseURL -> String -> String-withBaseURL Nothing        uri = uri-withBaseURL (Just baseUrl) uri = baseUrl FilePath.</> uri  -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs)

@@ -22,8 +22,9 @@ #include "HsVersions.h"  import GHC.Data.Bag ( emptyBag )-import GHC.Types.Basic ( TupleSort(..), SourceText(..), LexicalFixity(..)-                  , PromotionFlag(..), DefMethSpec(..) )+import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )+import GHC.Types.SourceText (SourceText(..))+import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.ConLike@@ -31,6 +32,7 @@ import GHC.Core.DataCon import GHC.Core.FamInstEnv import GHC.Hs+import GHC.Types.TyThing import GHC.Types.Name import GHC.Types.Name.Set    ( emptyNameSet ) import GHC.Types.Name.Reader ( mkVarUnqual )@@ -43,19 +45,18 @@ import GHC.Builtin.Types ( eqTyConName, listTyConName, liftedTypeKindTyConName                   , unitTy, promotedNilDataCon, promotedConsDataCon ) import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey-                 , liftedRepDataConKey )+                 , liftedDataConKey, boxedRepDataConKey ) import GHC.Types.Unique ( getUnique ) import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength                       , filterByList, filterOut )-import GHC.Utils.Outputable ( assertPanic )+import GHC.Utils.Panic ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc-import GHC.Parser.Annotation (IsUnicodeSyntax(..))  import Haddock.Types import Haddock.Interface.Specialize-import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars )+import Haddock.GhcUtils                      ( orderedFVs, defaultRuntimeRepVars, mkEmptySigType )  import Data.Maybe                            ( catMaybes, mapMaybe, maybeToList ) @@ -90,26 +91,26 @@            extractFamilyDecl _           =              Left "tyThingToLHsDecl: impossible associated tycon" -           cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n-           cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField-              (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind-           cvt (XTyVarBndr nec) = noExtCon nec+           cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn+             -- Without this signature, we trigger GHC#18932+           cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n+           cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn+              (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind             -- | Convert a LHsTyVarBndr to an equivalent LHsType.-           hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p)+           hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn            hsLTyVarBndrToType = mapLoc cvt             extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn            extractFamDefDecl fd rhs =-             TyFamInstDecl $ HsIB { hsib_ext = hsq_ext (fdTyVars fd)-                                  , hsib_body = FamEqn-             { feqn_ext = noExtField+             TyFamInstDecl noAnn $ FamEqn+             { feqn_ext = noAnn              , feqn_tycon = fdLName fd-             , feqn_bndrs = Nothing+             , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)}              , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $                            hsq_explicit $ fdTyVars fd              , feqn_fixity = fdFixity fd-             , feqn_rhs = synifyType WithinType [] rhs }}+             , feqn_rhs = synifyType WithinType [] rhs }             extractAtItem              :: ClassATItem@@ -117,8 +118,8 @@            extractAtItem (ATI at_tc def) = do              tyDecl <- synifyTyCon prr Nothing at_tc              famDecl <- extractFamilyDecl tyDecl-             let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def-             pure (noLoc famDecl, defEqnTy)+             let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def+             pure (noLocA famDecl, defEqnTy)             atTyClDecls = map extractAtItem (classATItems cl)            (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls)@@ -126,14 +127,14 @@         in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl          { tcdCtxt = synifyCtx (classSCTheta cl)-         , tcdLName = synifyName cl+         , tcdLName = synifyNameN cl          , tcdTyVars = synifyTyVars vs          , tcdFixity = synifyFixity cl-         , tcdFDs = map (\ (l,r) -> noLoc-                        (map (noLoc . getName) l, map (noLoc . getName) r) ) $+         , tcdFDs = map (\ (l,r) -> noLocA+                        (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $                          snd $ classTvsFds cl-         , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) :-                      [ noLoc tcdSig+         , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) :+                      [ noLocA tcdSig                       | clsOp <- classOpItems cl                       , tcdSig <- synifyTcIdSig vs clsOp ]          , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature@@ -150,30 +151,30 @@   ACoAxiom ax -> synifyAxiom ax >>= allOK    -- a data-constructor alone just gets rendered as a function:-  AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc]+  AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc]     (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc)))    AConLike (PatSynCon ps) ->-    allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps)+    allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps)   where     withErrs e x = return (e, x)     allOK x = return (mempty, x)  synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })-  = let name            = synifyName tc+  = let name            = synifyNameN tc         args_types_only = filterOutInvisibleTypes tc args         typats          = map (synifyType WithinType []) args_types_only         annot_typats    = zipWith3 annotHsType args_poly args_types_only typats         hs_rhs          = synifyType WithinType [] rhs-    in HsIB { hsib_ext = map tyVarName tkvs-            , hsib_body   = FamEqn { feqn_ext    = noExtField-                                   , feqn_tycon  = name-                                   , feqn_bndrs  = Nothing+        outer_bndrs     = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}                                        -- TODO: this must change eventually-                                   , feqn_pats   = map HsValArg annot_typats-                                   , feqn_fixity = synifyFixity name-                                   , feqn_rhs    = hs_rhs } }+    in FamEqn { feqn_ext    = noAnn+              , feqn_tycon  = name+              , feqn_bndrs  = outer_bndrs+              , feqn_pats   = map HsValArg annot_typats+              , feqn_fixity = synifyFixity name+              , feqn_rhs    = hs_rhs }   where     args_poly = tyConArgsPolyKinded tc @@ -183,7 +184,7 @@   , Just branch <- coAxiomSingleBranch_maybe ax   = return $ InstD noExtField            $ TyFamInstD noExtField-           $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch }+           $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch }    | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc   , getUnique ax' == getUnique ax   -- without the getUniques, type error@@ -201,7 +202,7 @@ synifyTyCon prr _coax tc   | isFunTyCon tc || isPrimTyCon tc   = return $-    DataDecl { tcdLName = synifyName tc+    DataDecl { tcdLName = synifyNameN tc              , tcdTyVars = HsQTvs  { hsq_ext = []   -- No kind polymorphism                                    , hsq_explicit = zipWith mk_hs_tv                                                             (map scaledThing tyVarKinds)@@ -213,21 +214,21 @@            , tcdDataDefn = HsDataDefn { dd_ext = noExtField                                       , dd_ND = DataType  -- arbitrary lie, they are neither                                                     -- algebraic data nor newtype:-                                      , dd_ctxt = noLoc []+                                      , dd_ctxt = Nothing                                       , dd_cType = Nothing                                       , dd_kindSig = synifyDataTyConReturnKind tc                                                -- we have their kind accurately:                                       , dd_cons = []  -- No constructors-                                      , dd_derivs = noLoc [] }+                                      , dd_derivs = [] }            , tcdDExt = DataDeclRn False emptyNameSet }   where     -- tyConTyVars doesn't work on fun/prim, but we can make them up:     mk_hs_tv realKind fakeTyVar-      | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar))-      | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind)+      | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar))+      | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind)      conKind = defaultType prr (tyConKind tc)-    tyVarKinds = fst . splitFunTys . snd . splitPiTysInvisible $ conKind+    tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind  synifyTyCon _prr _coax tc   | Just flav <- famTyConFlav_maybe tc@@ -237,7 +238,7 @@       ClosedSynFamilyTyCon mb         | Just (CoAxiom { co_ax_branches = branches }) <- mb           -> mkFamDecl $ ClosedTypeFamily $ Just-            $ map (noLoc . synifyAxBranch tc) (fromBranches branches)+            $ map (noLocA . synifyAxBranch tc) (fromBranches branches)         | otherwise           -> mkFamDecl $ ClosedTypeFamily $ Just []       BuiltInSynFamTyCon {}@@ -249,9 +250,10 @@   where     resultVar = famTcResVar tc     mkFamDecl i = return $ FamDecl noExtField $-      FamilyDecl { fdExt = noExtField+      FamilyDecl { fdExt = noAnn                  , fdInfo = i-                 , fdLName = synifyName tc+                 , fdTopLevel = TopLevel+                 , fdLName = synifyNameN tc                  , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)                  , fdFixity = synifyFixity tc                  , fdResultSig =@@ -264,7 +266,7 @@ synifyTyCon _prr coax tc   | Just ty <- synTyConRhs_maybe tc   = return $ SynDecl { tcdSExt   = emptyNameSet-                     , tcdLName  = synifyName tc+                     , tcdLName  = synifyNameN tc                      , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)                      , tcdFixity = synifyFixity tc                      , tcdRhs = synifyType WithinType [] ty }@@ -274,9 +276,9 @@   alg_nd = if isNewTyCon tc then NewType else DataType   alg_ctx = synifyCtx (tyConStupidTheta tc)   name = case coax of-    Just a -> synifyName a -- Data families are named according to their+    Just a -> synifyNameN a -- Data families are named according to their                            -- CoAxioms, not their TyCons-    _ -> synifyName tc+    _ -> synifyNameN tc   tyvars = synifyTyVars (tyConVisibleTyVars tc)   kindSig = synifyDataTyConReturnKind tc   -- The data constructors.@@ -299,7 +301,7 @@   consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)   cons = rights consRaw   -- "deriving" doesn't affect the signature, no need to specify any.-  alg_deriv = noLoc []+  alg_deriv = []   defn = HsDataDefn { dd_ext     = noExtField                     , dd_ND      = alg_nd                     , dd_ctxt    = alg_ctx@@ -340,15 +342,15 @@ 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+    let rhs = map (noLocA . tyVarName) (filterByList inj tvs)+    in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs  synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig  Nothing    kind    | isLiftedTypeKind kind = noLoc $ NoSig noExtField    | otherwise = noLoc $ KindSig  noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =-   noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind))+   noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))  -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its@@ -362,59 +364,77 @@   -- infix *syntax*.   use_infix_syntax = dataConIsInfix dc   use_named_field_syntax = not (null field_tys)-  name = synifyName dc+  name = synifyNameN dc   -- con_qvars means a different thing depending on gadt-syntax   (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc   user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors +  outer_bndrs | null user_tvbndrs+              = HsOuterImplicit { hso_ximplicit = [] }+              | otherwise+              = HsOuterExplicit { hso_xexplicit = noExtField+                                , hso_bndrs = map synifyTyVarBndr user_tvbndrs }+   -- skip any EqTheta, use 'orig'inal syntax   ctx | null theta = Nothing-      | otherwise = Just $ synifyCtx theta+      | otherwise = synifyCtx theta    linear_tys =     zipWith (\ty bang ->                let tySyn = synifyType WithinType [] (scaledThing ty)                in case bang of                     (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn-                    bang' -> noLoc $ HsBangTy noExtField bang' tySyn)+                    bang' -> noLocA $ HsBangTy noAnn bang' tySyn)             arg_tys (dataConSrcBangs dc)    field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys-  con_decl_field fl synTy = noLoc $-    ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy+  con_decl_field fl synTy = noLocA $+    ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy                  Nothing-  hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of-          (True,True) -> Left "synifyDataCon: contradiction!"-          (True,False) -> return $ RecCon (noLoc field_tys)-          (False,False) -> return $ PrefixCon (map hsUnrestricted linear_tys)-          (False,True) -> case linear_tys of-                           [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)-                           _ -> Left "synifyDataCon: infix with non-2 args?"++  mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)+  mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of+    (True,True) -> Left "synifyDataCon: contradiction!"+    (True,False) -> return $ RecCon (noLocA field_tys)+    (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)+    (False,True) -> case linear_tys of+                     [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b)+                     _ -> Left "synifyDataCon: infix with non-2 args?"++  mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn+  mk_gadt_arg_tys+    | use_named_field_syntax = RecConGADT (noLocA field_tys)+    | otherwise              = PrefixConGADT (map hsUnrestricted linear_tys)+  -- finally we get synifyDataCon's result!- in hs_arg_tys >>=-      \hat ->-        if use_gadt_syntax-           then return $ noLoc $-              ConDeclGADT { con_g_ext  = []-                          , con_names  = [name]-                          , con_forall = noLoc $ not $ null user_tvbndrs-                          , con_qvars  = map synifyTyVarBndr user_tvbndrs-                          , con_mb_cxt = ctx-                          , con_args   = hat-                          , con_res_ty = synifyType WithinType [] res_ty-                          , con_doc    = Nothing }-           else return $ noLoc $-              ConDeclH98 { con_ext    = noExtField-                         , con_name   = name-                         , con_forall = noLoc False-                         , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs-                         , con_mb_cxt = ctx-                         , con_args   = hat-                         , con_doc    = Nothing }+ in if use_gadt_syntax+       then do+         let hat = mk_gadt_arg_tys+         return $ noLocA $ ConDeclGADT+           { con_g_ext  = noAnn+           , con_names  = [name]+           , con_bndrs  = noLocA outer_bndrs+           , con_mb_cxt = ctx+           , con_g_args = hat+           , con_res_ty = synifyType WithinType [] res_ty+           , con_doc    = Nothing }+       else do+         hat <- mk_h98_arg_tys+         return $ noLocA $ ConDeclH98+           { con_ext    = noAnn+           , con_name   = name+           , con_forall = False+           , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs+           , con_mb_cxt = ctx+           , con_args   = hat+           , con_doc    = Nothing } -synifyName :: NamedThing n => n -> Located Name-synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n)+synifyNameN :: NamedThing n => n -> LocatedN Name+synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) +-- synifyName :: NamedThing n => n -> LocatedA Name+-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)+ -- | Guess the fixity of a something with a name. This isn't quite right, since -- a user can always declare an infix name in prefix form or a prefix name in -- infix form. Unfortunately, that is not something we can usually reconstruct.@@ -428,7 +448,7 @@   -> [TyVar]          -- ^ free variables in the type to convert   -> Id               -- ^ the 'Id' from which to get the type signature   -> Sig GhcRn-synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t)+synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t)   where     t = defaultType prr (varType i) @@ -437,15 +457,15 @@ -- 'ClassOpSig'. synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn] synifyTcIdSig vs (i, dm) =-  [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++-  [ ClassOpSig noExtField True [noLoc dn] (defSig dt)+  [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] +++  [ ClassOpSig noAnn True [noLocA dn] (defSig dt)   | Just (dn, GenericDM dt) <- [dm] ]   where     mainSig t = synifySigType DeleteTopLevelQuantification vs t     defSig t = synifySigType ImplicitizeForAll vs t -synifyCtx :: [PredType] -> LHsContext GhcRn-synifyCtx = noLoc . map (synifyType WithinType [])+synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)+synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))   synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn@@ -466,8 +486,8 @@ synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn synify_ty_var no_kinds flag tv   | isLiftedTypeKind kind || tv `elemVarSet` no_kinds-  = noLoc (UserTyVar noExtField flag (noLoc name))-  | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind))+  = noLocA (UserTyVar noAnn flag (noLocA name))+  | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind))   where     kind = tyVarKind tv     name = getName tv@@ -484,7 +504,7 @@   | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty   = let ki    = typeKind ty         hs_ki = synifyType WithinType [] ki-    in noLoc (HsKindSig noExtField hs_ty hs_ki)+    in noLocA (HsKindSig noAnn hs_ty hs_ki) annotHsType _    _ hs_ty = hs_ty  -- | For every argument type that a type constructor accepts,@@ -526,17 +546,17 @@   synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn--- The empty binders is a bit suspicious;--- what if the type has free variables?-synifySigType s vs ty = mkEmptyImplicitBndrs (synifyType s vs ty)+-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)+-- is a bit suspicious; what if the type has free variables?+synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)  synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType)-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty))+synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (synifyType s vs ty))  synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType)-synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps)+synifyPatSynSigType ps = mkEmptySigType (synifyPatSynType ps)  -- | Depending on the first argument, try to default all type variables of kind -- 'RuntimeRep' to 'LiftedType'.@@ -550,7 +570,7 @@   -> [TyVar]          -- ^ free variables in the type to convert   -> Type             -- ^ the type to convert   -> LHsType GhcRn-synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv)+synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv) synifyType _ vs (TyConApp tc tys)   = maybe_sig res_ty   where@@ -558,65 +578,66 @@     res_ty       -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473)       | tc `hasKey` tYPETyConKey-      , [TyConApp lev []] <- tys-      , lev `hasKey` liftedRepDataConKey-      = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName))+      , [TyConApp rep [TyConApp lev []]] <- tys+      , rep `hasKey` boxedRepDataConKey+      , lev `hasKey` liftedDataConKey+      = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName))       -- Use non-prefix tuple syntax where possible, because it looks nicer.       | Just sort <- tyConTuple_maybe tc       , tyConArity tc == tys_len-      = noLoc $ HsTupleTy noExtField+      = noLocA $ HsTupleTy noAnn                           (case sort of-                              BoxedTuple      -> HsBoxedTuple-                              ConstraintTuple -> HsConstraintTuple+                              BoxedTuple      -> HsBoxedOrConstraintTuple+                              ConstraintTuple -> HsBoxedOrConstraintTuple                               UnboxedTuple    -> HsUnboxedTuple)                            (map (synifyType WithinType vs) vis_tys)-      | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys)+      | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)       | Just dc <- isPromotedDataCon_maybe tc       , isTupleDataCon dc       , dataConSourceArity dc == length vis_tys-      = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)+      = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)       -- ditto for lists       | getName tc == listTyConName, [ty] <- vis_tys =-         noLoc $ HsListTy noExtField (synifyType WithinType vs ty)+         noLocA $ HsListTy noAnn (synifyType WithinType vs ty)       | tc == promotedNilDataCon, [] <- vis_tys-      = noLoc $ HsExplicitListTy noExtField IsPromoted []+      = noLocA $ HsExplicitListTy noExtField IsPromoted []       | tc == promotedConsDataCon       , [ty1, ty2] <- vis_tys       = let hTy = synifyType WithinType vs ty1         in case synifyType WithinType vs ty2 of              tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy-                 -> noLoc $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')+                 -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')                  | otherwise-                 -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy+                 -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy       -- ditto for implicit parameter tycons       | tc `hasKey` ipClassKey       , [name, ty] <- tys       , Just x <- isStrLitTy name-      = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty)+      = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty)       -- and equalities       | tc `hasKey` eqTyConKey       , [ty1, ty2] <- tys-      = noLoc $ HsOpTy noExtField+      = noLocA $ HsOpTy noExtField                        (synifyType WithinType vs ty1)-                       (noLoc eqTyConName)+                       (noLocA eqTyConName)                        (synifyType WithinType vs ty2)       -- and infix type operators       | isSymOcc (nameOccName (getName tc))       , ty1:ty2:tys_rest <- vis_tys       = mk_app_tys (HsOpTy noExtField                            (synifyType WithinType vs ty1)-                           (noLoc $ getName tc)+                           (noLocA $ getName tc)                            (synifyType WithinType vs ty2))                    tys_rest       -- Most TyCons:       | otherwise-      = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc))+      = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc))                    vis_tys       where         prom = if isPromotedDataCon tc then IsPromoted else NotPromoted         mk_app_tys ty_app ty_args =-          foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2)-                (noLoc ty_app)+          foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)+                (noLocA ty_app)                 (map (synifyType WithinType vs) $                  filterOut isCoercionTy ty_args) @@ -628,7 +649,7 @@       | tyConAppNeedsKindSig False tc tys_len       = let full_kind  = typeKind (mkTyConApp tc tys)             full_kind' = synifyType WithinType vs full_kind-        in noLoc $ HsKindSig noExtField ty' full_kind'+        in noLocA $ HsKindSig noAnn ty' full_kind'       | otherwise = ty'  synifyType _ vs ty@(AppTy {}) = let@@ -638,19 +659,19 @@              filterOut isCoercionTy $              filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)                           ty_args-  in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args'+  in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty synifyType _ vs       (FunTy VisArg w t1 t2) = let   s1 = synifyType WithinType vs t1   s2 = synifyType WithinType vs t2   w' = synifyMult vs w-  in noLoc $ HsFunTy noExtField w' s1 s2+  in noLocA $ HsFunTy noAnn w' s1 s2 synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =   case argf of     Required    -> synifyVisForAllType vs forallty     Invisible _ -> synifySigmaType s vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t+synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t synifyType s vs (CastTy t _) = synifyType s vs t synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -668,9 +689,9 @@       -- absence of an explicit forall       tvs' = orderedFVs (mkVarSet vs) [rho] -  in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs-                        , hst_xforall = noExtField-                        , hst_body  = synifyType WithinType (tvs' ++ vs) rho }+  in noLocA $ HsForAllTy { hst_tele    = mkHsForAllVisTele noAnn sTvs+                         , hst_xforall = noExtField+                         , hst_body    = synifyType WithinType (tvs' ++ vs) rho }  -- | Process a 'Type' which starts with an invisible @forall@ or a constraint -- into an 'HsType'@@ -685,9 +706,9 @@                       , hst_xqual = noExtField                       , hst_body = synifyType WithinType (tvs' ++ vs) tau } -      sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs+      sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs                        , hst_xforall = noExtField-                       , hst_body  = noLoc sPhi }+                       , hst_body  = noLocA sPhi }        sTvs = map synifyTyVarBndr tvs @@ -700,8 +721,8 @@      -- Put a forall in if there are any type variables     WithinType-      | not (null tvs) -> noLoc sTy-      | otherwise -> noLoc sPhi+      | not (null tvs) -> noLocA sTy+      | otherwise -> noLocA sPhi      ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau @@ -717,9 +738,9 @@   -> Type             -- ^ inner type   -> LHsType GhcRn implicitForAll tycons vs tvs ctx synInner tau-  | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy-  | tvs' /= (binderVars tvs)           = noLoc sTy-  | otherwise                          = noLoc sPhi+  | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy+  | tvs' /= (binderVars tvs)           = noLocA sTy+  | otherwise                          = noLocA sPhi   where   sRho = synInner (tvs' ++ vs) tau   sPhi | null ctx = unLoc sRho@@ -727,9 +748,9 @@        = HsQualTy { hst_ctxt = synifyCtx ctx                   , hst_xqual = noExtField                   , hst_body = synInner (tvs' ++ vs) tau }-  sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs+  sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs                    , hst_xforall = noExtField-                   , hst_body = noLoc sPhi }+                   , hst_body = noLocA sPhi }    no_kinds_needed = noKindTyVars tycons tau   sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs@@ -778,9 +799,9 @@  synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of-                    One  -> HsLinearArrow NormalSyntax+                    One  -> HsLinearArrow NormalSyntax Nothing                     Many -> HsUnrestrictedArrow NormalSyntax-                    ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty)+                    ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty)   @@ -804,6 +825,7 @@ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s+synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c  synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType [] k

@@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -21,17 +24,19 @@  import Control.Arrow import Data.Char ( isSpace )-import Data.Maybe ( mapMaybe )+import Data.Maybe ( mapMaybe, fromMaybe ) -import Haddock.Types( DocName, DocNameI )+import Haddock.Types( DocName, DocNameI, XRecCond )  import GHC.Utils.FV as FV-import GHC.Utils.Outputable ( Outputable, panic, showPpr )-import GHC.Types.Basic (PromotionFlag(..))+import GHC.Utils.Outputable ( Outputable )+import GHC.Utils.Panic ( panic )+import GHC.Driver.Ppr (showPpr ) import GHC.Types.Name import GHC.Unit.Module import GHC import GHC.Driver.Session+import GHC.Types.Basic import GHC.Types.SrcLoc  ( advanceSrcLoc ) import GHC.Types.Var     ( Specificity, VarBndr(..), TyVarBinder                          , tyVarKind, updateTyVarKind, isInvisibleArgFlag )@@ -39,8 +44,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type     ( isRuntimeRepVar )-import GHC.Builtin.Types( liftedRepDataConTyCon )-import GHC.Parser.Annotation (IsUnicodeSyntax(..))+import GHC.Builtin.Types( liftedRepTy )  import           GHC.Data.StringBuffer ( StringBuffer ) import qualified GHC.Data.StringBuffer             as S@@ -49,6 +53,8 @@ import qualified Data.ByteString          as BS import qualified Data.ByteString.Internal as BS +import GHC.HsToCore.Docs+ moduleString :: Module -> String moduleString = moduleNameString . moduleName @@ -68,45 +74,32 @@ filterSigNames p (FixSig _ (FixitySig _ ns ty)) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (FixSig noExtField (FixitySig noExtField filtered ty))+    filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty)) filterSigNames _ orig@(MinimalSig _ _ _)      = Just orig filterSigNames p (TypeSig _ ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (TypeSig noExtField filtered ty)+    filtered -> Just (TypeSig noAnn filtered ty) filterSigNames p (ClassOpSig _ is_default ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (ClassOpSig noExtField is_default filtered ty)+    filtered -> Just (ClassOpSig noAnn is_default filtered ty) filterSigNames p (PatSynSig _ ns ty) =   case filter (p . unLoc) ns of     []       -> Nothing-    filtered -> Just (PatSynSig noExtField filtered ty)+    filtered -> Just (PatSynSig noAnn filtered ty) filterSigNames _ _                             = Nothing  ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True  = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [IdP name]+sigName :: LSig GhcRn -> [IdP GhcRn] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [IdP name]-sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns-sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns-sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns-sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]-sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns-sigNameNoLoc _                             = []- -- | Was this signature given by the user?-isUserLSig :: LSig name -> Bool-isUserLSig (L _ (TypeSig {}))    = True-isUserLSig (L _ (ClassOpSig {})) = True-isUserLSig (L _ (PatSynSig {}))  = True-isUserLSig _                     = False-+isUserLSig :: forall p. UnXRec p => LSig p -> Bool+isUserLSig = isUserSig . unXRec @p  isClassD :: HsDecl a -> Bool isClassD (TyClD _ d) = isClassDecl d@@ -121,10 +114,10 @@ -- instantiated at DocNameI instead of (GhcPass _).  -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)-hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr flag n -> IdP n-hsTyVarBndrName (UserTyVar _ _ name) = unLoc name-hsTyVarBndrName (KindedTyVar _ _ (L _ name) _) = name-hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)+                => HsTyVarBndr flag n -> IdP n+hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name+hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name  hsTyVarNameI :: HsTyVarBndr flag DocNameI -> DocName hsTyVarNameI (UserTyVar _ _ (L _ n))     = n@@ -133,50 +126,62 @@ hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName hsLTyVarNameI = hsTyVarNameI . unLoc -getConNamesI :: ConDecl DocNameI -> [Located DocName]+getConNamesI :: ConDecl DocNameI -> [LocatedN DocName] getConNamesI ConDeclH98  {con_name  = name}  = [name] getConNamesI ConDeclGADT {con_names = names} = names -hsImplicitBodyI :: HsImplicitBndrs DocNameI thing -> thing-hsImplicitBodyI (HsIB { hsib_body = body }) = body- hsSigTypeI :: LHsSigType DocNameI -> LHsType DocNameI-hsSigTypeI = hsImplicitBodyI+hsSigTypeI = sig_body . unLoc +mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn+-- Dubious, because the implicit binders are empty even+-- though the type might have free varaiables+mkEmptySigType lty@(L loc ty) = L loc $ case ty of+  HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }+             , hst_body = body }+    -> HsSig { sig_ext = noExtField+             , sig_bndrs = HsOuterExplicit { hso_xexplicit = noExtField+                                           , hso_bndrs     = bndrs }+             , sig_body = body }+  _ -> HsSig { sig_ext   = noExtField+             , sig_bndrs = HsOuterImplicit{hso_ximplicit = []}+             , sig_body = lty }+ mkHsForAllInvisTeleI ::   [LHsTyVarBndr Specificity DocNameI] -> HsForAllTelescope DocNameI mkHsForAllInvisTeleI invis_bndrs =   HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } -getConArgsI :: ConDecl DocNameI -> HsConDeclDetails DocNameI-getConArgsI d = con_args d+mkHsImplicitSigTypeI :: LHsType DocNameI -> HsSigType DocNameI+mkHsImplicitSigTypeI body =+  HsSig { sig_ext   = noExtField+        , sig_bndrs = HsOuterImplicit{hso_ximplicit = noExtField}+        , sig_body  = body } -getGADTConType :: ConDecl DocNameI -> LHsType DocNameI+getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code.  So -- we are cavalier about locations and extensions, hence the -- 'undefined's-getGADTConType (ConDeclGADT { con_forall = L _ has_forall-                            , con_qvars = qtvs-                            , con_mb_cxt = mcxt, con_args = args+getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs+                            , con_mb_cxt = mcxt, con_g_args = args                             , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField-                                  , hst_tele = mkHsForAllInvisTeleI qtvs-                                  , hst_body  = theta_ty })- | otherwise  = theta_ty+ = noLocA (HsSig { sig_ext   = noExtField+                 , sig_bndrs = outer_bndrs+                 , sig_body  = theta_ty })  where    theta_ty | Just theta <- mcxt-            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })+            = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })             | otherwise             = tau_ty  --  tau_ty :: LHsType DocNameI    tau_ty = case args of-              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty-              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)-              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)+              RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty+              PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) -   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)+   mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI+   mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)  getGADTConType (ConDeclH98 {}) = panic "getGADTConType"   -- Should only be called on ConDeclGADT@@ -184,7 +189,7 @@ getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] getMainDeclBinderI (TyClD _ d) = [tcdNameI d] getMainDeclBinderI (ValD _ d) =-  case collectHsBindBinders d of+  case collectHsBindBinders CollNoDictBinders d of     []       -> []     (name:_) -> [name] getMainDeclBinderI (SigD _ d) = sigNameNoLoc d@@ -192,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = [] -familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName+familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName familyDeclLNameI (FamilyDecl { fdLName = n }) = n -tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName+tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName tyClDeclLNameI (FamDecl { tcdFam = fd })     = familyDeclLNameI fd tyClDeclLNameI (SynDecl { tcdLName = ln })   = ln tyClDeclLNameI (DataDecl { tcdLName = ln })  = ln@@ -204,73 +209,35 @@ tcdNameI :: TyClDecl DocNameI -> DocName tcdNameI = unLoc . tyClDeclLNameI --- ---------------------------------------getGADTConTypeG :: ConDecl GhcRn -> LHsType GhcRn--- The full type of a GADT data constructor We really only get this in--- order to pretty-print it, and currently only in Haddock's code.  So--- we are cavalier about locations and extensions, hence the--- 'undefined's-getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall-                            , con_qvars = qtvs-                            , con_mb_cxt = mcxt, con_args = args-                            , con_res_ty = res_ty })- | has_forall = noLoc (HsForAllTy { hst_xforall = noExtField-                                  , hst_tele = mkHsForAllInvisTele qtvs-                                  , hst_body  = theta_ty })- | otherwise  = theta_ty- where-   theta_ty | Just theta <- mcxt-            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })-            | otherwise-            = tau_ty----   tau_ty :: LHsType DocNameI-   tau_ty = case args of-              RecCon flds ->  mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty-              PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args)-              InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty)--   -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI-   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b)--getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"-  -- Should only be called on ConDeclGADT---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 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 noExtField lname (mkEmptySigWcType (go (hsSigType ltype))))-          -- The mkEmptySigWcType is suspicious+  = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))   where-    go (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))-       = L loc (HsForAllTy { hst_tele = tele, hst_xforall = noExtField-                           , hst_body = go ty })-    go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))+    go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))+       = L loc (HsSig { sig_ext = noExtField+                      , sig_bndrs = bndrs, sig_body = go_ty ty })++    go_ty (L loc (HsForAllTy { hst_tele = tele, hst_body = ty }))+       = L loc (HsForAllTy { hst_xforall = noExtField+                           , hst_tele = tele, hst_body = go_ty ty })+    go_ty (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty }))        = L loc (HsQualTy { hst_xqual = noExtField                          , hst_ctxt = add_ctxt ctxt, hst_body = ty })-    go (L loc ty)+    go_ty (L loc ty)        = L loc (HsQualTy { hst_xqual = noExtField-                         , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty })+                         , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty }) -    extra_pred :: LHsType GhcRn-    extra_pred = nlHsTyConApp Prefix cls (map HsValArg (lHsQTyVarsToTypes tvs0))+    extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) -    add_ctxt :: LHsContext GhcRn -> LHsContext GhcRn-    add_ctxt (L loc preds) = L loc (extra_pred : preds)+    add_ctxt Nothing              = Just $ noLocA [extra_pred]+    add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)  addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn]+lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn] lHsQTyVarsToTypes tvs-  = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv)))+  = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv)))     | tv <- hsQTvExplicit tvs ]  @@ -278,7 +245,6 @@ -- * Making abstract declarations -------------------------------------------------------------------------------- - restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of   TyClD x d | isDataDecl d  ->@@ -301,17 +267,27 @@ 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) =-      case con_args d of-        PrefixCon _ -> Just d-        RecCon fields-          | all field_avail (unLoc fields) -> Just d-          | otherwise -> Just (d { con_args = PrefixCon (field_types $ unLoc fields) })-          -- if we have *all* the field names available, then-          -- keep the record declaration.  Otherwise degrade to-          -- a constructor declaration.  This isn't quite right, but-          -- it's the best we can do.-        InfixCon _ _ -> Just d+    keep :: ConDecl GhcRn -> Maybe (ConDecl GhcRn)+    keep d+      | any (\n -> n `elem` names) (map unLoc $ getConNames d) =+        case d of+          ConDeclH98 { con_args = con_args' } -> case con_args' of+            PrefixCon {} -> Just d+            RecCon fields+              | all field_avail (unLoc fields) -> Just d+              | otherwise -> Just (d { con_args = PrefixCon [] (field_types $ unLoc fields) })+              -- if we have *all* the field names available, then+              -- keep the record declaration.  Otherwise degrade to+              -- a constructor declaration.  This isn't quite right, but+              -- it's the best we can do.+            InfixCon _ _ -> Just d++          ConDeclGADT { con_g_args = con_args' } -> case con_args' of+            PrefixConGADT {} -> Just d+            RecConGADT fields+              | all field_avail (unLoc fields) -> Just d+              | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) })+              -- see above       where         field_avail :: LConDeclField GhcRn -> Bool         field_avail (L _ (ConDeclField _ fs _ _))@@ -356,17 +332,18 @@ -- -- We cannot add parens that may be required by fixities because we do not have -- any fixity information to work with in the first place :(.-reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a+reparenTypePrec :: forall a. (XRecCond a)+                => Precedence -> HsType a -> HsType a reparenTypePrec = go   where    -- Shorter name for 'reparenType'-  go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a+  go :: XParTy a ~ EpAnn AnnParen => Precedence -> HsType a -> HsType a   go _ (HsBangTy x b ty)     = HsBangTy x b (reparenLType ty)   go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)   go _ (HsSumTy x tys)       = HsSumTy x (map reparenLType tys)   go _ (HsListTy x ty)       = HsListTy x (reparenLType ty)-  go _ (HsRecTy x flds)      = HsRecTy x (map (fmap reparenConDeclField) flds)+  go _ (HsRecTy x flds)      = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)   go p (HsDocTy x ty d)      = HsDocTy x (goL p ty) d   go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)   go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)@@ -379,7 +356,11 @@   go p (HsQualTy x ctxt ty)     = let p' [_] = PREC_CTX           p' _   = PREC_TOP -- parens will get added anyways later...-      in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty)+          ctxt' = case ctxt of+            Nothing -> Nothing+            Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c+      in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty)+    -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)   go p (HsFunTy x w ty1 ty2)     = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)   go p (HsAppTy x fun_ty arg_ty)@@ -388,7 +369,7 @@     = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)   go p (HsOpTy x ty1 op ty2)     = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)-  go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed+  go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed   go _ t@HsTyVar{} = t   go _ t@HsStarTy{} = t   go _ t@HsSpliceTy{} = t@@ -397,43 +378,58 @@   go _ t@XHsType{} = t    -- Located variant of 'go'-  goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a-  goL ctxt_prec = fmap (go ctxt_prec)+  goL :: XParTy a ~ EpAnn AnnParen => Precedence -> LHsType a -> LHsType a+  goL ctxt_prec = mapXRec @a (go ctxt_prec)    -- Optionally wrap a type in parens-  paren :: (XParTy a ~ NoExtField)+  paren :: XParTy a ~ EpAnn AnnParen         => Precedence            -- Precedence of context         -> Precedence            -- Precedence of top-level operator         -> HsType a -> HsType a  -- Wrap in parens if (ctxt >= op)-  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc+  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a                           | otherwise            = id   -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')-reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a+reparenType :: XRecCond a => HsType a -> HsType a reparenType = reparenTypePrec PREC_TOP  -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')-reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a-reparenLType = fmap reparenType+reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a+reparenLType = mapXRec @a reparenType +-- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec')+reparenSigType :: forall a. ( XRecCond a )+               => HsSigType a -> HsSigType a+reparenSigType (HsSig x bndrs body) =+  HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)+reparenSigType v@XHsSigType{} = v++-- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec')+reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )+                       => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a+reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp+reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =+  HsOuterExplicit x (map (mapXRec @(NoGhcTc a) reparenTyVar) exp_bndrs)+reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v+ -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')-reparenHsForAllTelescope :: (XParTy a ~ NoExtField)+reparenHsForAllTelescope :: forall a. (XRecCond a )                          => HsForAllTelescope a -> HsForAllTelescope a reparenHsForAllTelescope (HsForAllVis x bndrs) =-  HsForAllVis x (map (fmap reparenTyVar) bndrs)+  HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope (HsForAllInvis x bndrs) =-  HsForAllInvis x (map (fmap reparenTyVar) bndrs)+  HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs) reparenHsForAllTelescope v@XHsForAllTelescope{} = v  -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')-reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a+reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar v@XTyVarBndr{} = v  -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')-reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a+reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c @@ -443,13 +439,15 @@ -------------------------------------------------------------------------------  -unL :: Located a -> a+unL :: GenLocated l a -> a unL (L _ x) = x --reL :: a -> Located a+reL :: a -> GenLocated l a reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b)+mapMA f (L al a) = L (locA al) <$> f a+ ------------------------------------------------------------------------------- -- * NamedThing instances -------------------------------------------------------------------------------@@ -469,10 +467,9 @@  instance Parent (ConDecl GhcRn) where   children con =-    case con_args con of-      RecCon fields -> map (extFieldOcc . unLoc) $-                         concatMap (cd_fld_names . unLoc) (unLoc fields)-      _             -> []+    case getRecConArgs_maybe con of+      Nothing -> []+      Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)  instance Parent (TyClDecl GhcRn) where   children d@@ -738,7 +735,7 @@      go subs (TyVarTy tv)       | tv `elemVarEnv` subs-      = TyConApp liftedRepDataConTyCon []+      = liftedRepTy       | otherwise       = TyVarTy (updateTyVarKind (go subs) tv) @@ -756,3 +753,6 @@      go _ ty@(LitTy {}) = ty     go _ ty@(CoercionTy {}) = ty++fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt

@@ -43,39 +43,40 @@ import Haddock.Types (DocOption (..), Documentation (..), ExportItem (..), IfaceMap, InstIfaceMap, Interface, LinkEnv,                       expItemDecl, expItemMbDoc, ifaceDoc, ifaceExportItems, ifaceExports, ifaceHaddockCoverage,                       ifaceInstances, ifaceMod, ifaceOptions, ifaceVisibleExports, instMod, runWriter, throwE)-import Haddock.Utils (Verbosity, normal, out, verbose)+import Haddock.Utils (Verbosity (..), normal, out, verbose)  import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub)+import Text.Printf (printf) import qualified Data.Map as Map import qualified Data.Set as Set-import Text.Printf (printf)  import GHC hiding (verbosity) import GHC.Data.FastString (unpackFS)-import GHC.Data.Graph.Directed-import GHC.Driver.Monad (modifySession)+import GHC.Data.Graph.Directed (flattenSCCs)+import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)+import GHC.Driver.Monad (modifySession, withTimingM) import GHC.Driver.Session hiding (verbosity)-import GHC.Driver.Types (isBootSummary) import GHC.HsToCore.Docs (getMainDeclBinder)-import GHC.Plugins (HscEnv (..), Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin,-                    keepRenamedSource)+import GHC.Plugins (Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, keepRenamedSource) import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal)-import GHC.Tc.Utils.Monad (setGblEnv)+import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv) import GHC.Types.Name (nameIsFromExternalPackage, nameOccName) import GHC.Types.Name.Occurrence (isTcOcc)-import GHC.Types.Name.Reader (globalRdrEnvElts, gre_name, unQualOK)+import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK) import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)+import GHC.Unit.Module.Graph (ModuleGraphNode (..))+import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary) import GHC.Unit.Types (IsBootInterface (..))-import GHC.Utils.Error (withTimingD)+import GHC.Utils.Error (withTiming)  #if defined(mingw32_HOST_OS)-import GHC.IO.Encoding.CodePage (mkLocaleEncoding)-import GHC.IO.Encoding.Failure (CodingFailureMode (TransliterateCodingFailure)) import System.IO+import GHC.IO.Encoding.CodePage (mkLocaleEncoding)+import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure)) #endif  -- | Create 'Interface's and a link environment by typechecking the list of@@ -112,7 +113,7 @@       mods = Set.fromList $ map ifaceMod interfaces   out verbosity verbose "Attaching instances..."   interfaces' <- {-# SCC attachInstances #-}-                 withTimingD "attachInstances" (const ()) $ do+                 withTimingM "attachInstances" (const ()) $ do                    attachInstances (exportedNames, mods) interfaces instIfaceMap ms    out verbosity verbose "Building cross-linking environment..."@@ -146,10 +147,10 @@     installHaddockPlugin :: HscEnv -> HscEnv     installHaddockPlugin hsc_env = hsc_env       {-        hsc_dflags = (gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy)-          {-            staticPlugins = haddockPlugin : staticPlugins (hsc_dflags hsc_env)-          }+        hsc_dflags =+          gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy+      , hsc_static_plugins =+          haddockPlugin : hsc_static_plugins hsc_env       }    -- Note that we would rather use withTempSession but as long as we@@ -160,7 +161,7 @@   targets <- mapM (\filePath -> guessTarget filePath Nothing) modules   setTargets targets -  loadOk <- withTimingD "load" (const ()) $+  loadOk <- withTimingM "load" (const ()) $     {-# SCC load #-} GHC.load LoadAllTargets    case loadOk of@@ -176,9 +177,9 @@         ifaces =           [ Map.findWithDefault               (error "haddock:iface")-              (ms_mod ms)+              (ms_mod (emsModSummary ems))               ifaceMap-          | ms <- flattenSCCs $ topSortModuleGraph True modGraph Nothing+          | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing           ]        return (ifaces, moduleSet)@@ -209,9 +210,11 @@       | IsBoot <- isBootSummary mod_summary =           pure ()       | otherwise = do+          hsc_env <- getTopEnv           ifaces <- liftIO $ readIORef ifaceMapRef-          (iface, modules) <- withTimingD "processModule" (const ()) $-            processModule1 verbosity flags ifaces instIfaceMap mod_summary tc_gbl_env+          (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)+                                "processModule" (const ()) $+            processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env            liftIO $ do             atomicModifyIORef' ifaceMapRef $ \xs ->@@ -249,44 +252,50 @@   -> [Flag]   -> IfaceMap   -> InstIfaceMap+  -> HscEnv   -> ModSummary   -> TcGblEnv   -> TcM (Interface, ModuleSet)-processModule1 verbosity flags ifaces inst_ifaces mod_summary tc_gbl_env = do+processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env = do   out verbosity verbose "Creating interface..."    let     TcGblEnv { tcg_rdr_env } = tc_gbl_env -  (!interface, messages) <- {-# SCC createInterface #-}-    withTimingD "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $-      createInterface1 flags mod_summary tc_gbl_env ifaces inst_ifaces+    unit_state = hsc_units hsc_env +  (!interface, messages) <- do+    logger <- getLogger+    dflags <- getDynFlags+    {-# SCC createInterface #-}+     withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $+      createInterface1 flags unit_state mod_summary tc_gbl_env+        ifaces inst_ifaces+   -- We need to keep track of which modules were somehow in scope so that when   -- Haddock later looks for instances, it also looks in these modules too.   --   -- See https://github.com/haskell/haddock/issues/469.-  dflags <- getDynFlags   let     mods :: ModuleSet     !mods = mkModuleSet       [ nameModule name       | gre <- globalRdrEnvElts tcg_rdr_env-      , let name = gre_name gre-      , nameIsFromExternalPackage (homeUnit dflags) name+      , let name = greMangledName gre+      , nameIsFromExternalPackage (hsc_home_unit hsc_env) name       , isTcOcc (nameOccName name)   -- Types and classes only       , unQualOK gre -- In scope unqualified       ]    liftIO $ mapM_ putStrLn (nub messages)+  dflags <- getDynFlags    let     (haddockable, haddocked) =       ifaceHaddockCoverage interface      percentage :: Int-    percentage =-      round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double)+    percentage = div (haddocked * 100) haddockable      modString :: String     modString = moduleString (ifaceMod interface)@@ -302,7 +311,7 @@      undocumentedExports :: [String]     undocumentedExports =-      [ formatName s n+      [ formatName (locA s) n       | ExportDecl { expItemDecl = L s n                    , expItemMbDoc = (Documentation Nothing _, _)                    } <- ifaceExportItems interface

@@ -30,14 +30,11 @@  import GHC.Data.FastString (unpackFS) import GHC.Core.Class-import GHC.Driver.Session import GHC.Core (isOrphan)-import GHC.Utils.Error import GHC.Core.FamInstEnv import GHC import GHC.Core.InstEnv import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts )-import GHC.Utils.Monad (liftIO) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable (text, sep, (<+>))@@ -104,7 +101,7 @@             fam_instances = maybeToList mb_instances >>= snd             fam_insts = [ ( synFamInst                           , getInstDoc n-                          , spanNameE n synFamInst (L eSpan (tcdName d))+                          , spanNameE n synFamInst (L (locA eSpan) (tcdName d))                           , nameModule_maybe n                           )                         | i <- sortBy (comparing instFam) fam_instances@@ -116,7 +113,7 @@                         ]             cls_insts = [ ( synClsInst                           , getInstDoc n-                          , spanName n synClsInst (L eSpan (tcdName d))+                          , spanName n synClsInst (L (locA eSpan) (tcdName d))                           , nameModule_maybe n                           )                         | let is = [ (instanceSig i, getName i) | i <- cls_instances ]@@ -128,9 +125,8 @@             cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ]             famInstErrs = [ errm | (Left errm, _, _, _) <- fam_insts ]         in do-          dfs <- getDynFlags           let mkBug = (text "haddock-bug:" <+>) . text-          liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)+          putMsgM (sep $ map mkBug famInstErrs)           return $ cls_insts ++ cleanFamInsts       return $ e { expItemInstances = insts }     e -> return e@@ -197,6 +193,7 @@ data SimpleType = SimpleType SName [SimpleType]                 | SimpleIntTyLit Integer                 | SimpleStringTyLit String+                | SimpleCharTyLit Char                   deriving (Eq,Ord)  @@ -222,6 +219,7 @@                                        (mapMaybe simplify_maybe ts) simplify (LitTy (NumTyLit n)) = SimpleIntTyLit n simplify (LitTy (StrTyLit s)) = SimpleStringTyLit (unpackFS s)+simplify (LitTy (CharTyLit c)) = SimpleCharTyLit c simplify (CastTy ty _) = simplify ty simplify (CoercionTy _) = error "simplify:Coercion" 

@@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-}@@ -32,50 +33,54 @@  import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl)-import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigWcType, moduleString, parents,-                         pretty, restrictTo, sigName)-import Haddock.Interface.LexParseRn+import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents,+                         pretty, restrictTo, sigName, unL)+import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader) import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace) -import Control.Monad.Catch (MonadCatch, MonadThrow)-import Control.Monad.Reader (MonadReader (..), ReaderT (..), asks)+import Control.Applicative ((<|>))+import Control.Monad.Reader (MonadReader (..), ReaderT, asks, runReaderT) import Control.Monad.Writer.Strict hiding (tell) import Data.Bitraversable (bitraverse) import Data.List (find, foldl')+import qualified Data.IntMap as IM+import Data.IntMap (IntMap) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, maybeToList) import Data.Traversable (for)-import GHC.Stack (HasCallStack)  import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..)) import GHC.Data.FastString (bytesFS, unpackFS)-import GHC.Driver.Types (HscSource (..), WarningTxt (..), Warnings (..), msHsFilePath)+import GHC.Driver.Ppr (showSDoc) import GHC.HsToCore.Docs hiding (mkMaps)+import GHC.IORef (readIORef) import GHC.Parser.Annotation (IsUnicodeSyntax (..))+import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail-import GHC.Types.Basic (PromotionFlag (..), SourceText (..), StringLiteral (..))+import GHC.Types.Basic (PromotionFlag (..)) import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName) import GHC.Types.Name.Env (lookupNameEnv)-import GHC.Types.Name.Reader (GlobalRdrEnv, globalRdrEnvElts, gre_name, gresToAvailInfo, isLocalGRE, lookupGlobalRdrEnv)+import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet)+import GHC.Types.SourceFile (HscSource (..))+import GHC.Types.SourceText (SourceText (..), sl_fs) import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Unit.Module as Module-import GHC.Unit.State+import GHC.Unit.Module.ModSummary (msHsFilePath)+import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..))+import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O---mkExceptionContext :: ModSummary -> String-mkExceptionContext =-  ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name-+import GHC.Utils.Panic (pprPanic)+import GHC.HsToCore.Docs hiding (mkMaps)+import GHC.Unit.Module.Warnings  newtype IfEnv m = IfEnv   {@@ -92,14 +97,13 @@ -- over the Ghc specific clarifies where side effects happen. newtype IfM m a = IfM { unIfM :: ReaderT (IfEnv m) (WriterT [ErrMsg] m) a } + deriving newtype instance Functor m => Functor (IfM m) deriving newtype instance Applicative m => Applicative (IfM m) deriving newtype instance Monad m => Monad (IfM m) deriving newtype instance MonadIO m => MonadIO (IfM m) deriving newtype instance Monad m => MonadReader (IfEnv m) (IfM m) deriving newtype instance Monad m => MonadWriter [ErrMsg] (IfM m)-deriving newtype instance (MonadThrow m) => MonadThrow (IfM m)-deriving newtype instance (MonadCatch m) => MonadCatch (IfM m)   -- | Run an `IfM` action.@@ -132,15 +136,15 @@   createInterface1-  :: (MonadIO m, MonadCatch m)+  :: MonadIO m   => [Flag]+  -> UnitState   -> ModSummary   -> TcGblEnv   -> IfaceMap   -> InstIfaceMap   -> IfM m Interface-createInterface1 flags mod_sum tc_gbl_env ifaces inst_ifaces =-  withExceptionContext (mkExceptionContext mod_sum) $ do+createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do    let     ModSummary@@ -171,6 +175,7 @@       , tcg_rn_exports       , tcg_rn_decls +      , tcg_th_docs       , tcg_doc_hdr       } = tc_gbl_env @@ -179,7 +184,7 @@     is_sig = tcg_src == HsigFile      (pkg_name_fs, _) =-      modulePackageInfo dflags flags (Just tcg_mod)+      modulePackageInfo unit_state flags (Just tcg_mod)      pkg_name :: Maybe Package     pkg_name =@@ -197,7 +202,7 @@     loc_splices :: [SrcSpan]     loc_splices = case tcg_rn_decls of       Nothing -> []-      Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ]+      Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ]    decls <- case tcg_rn_decls of     Nothing -> do@@ -221,16 +226,9 @@           Nothing      -- All the exported Names of this module.-    actual_exports :: [AvailInfo]-    actual_exports-      | OptIgnoreExports `elem` doc_opts  =-          gresToAvailInfo $ filter isLocalGRE $ globalRdrEnvElts tcg_rdr_env-      | otherwise =-          tcg_exports-     exported_names :: [Name]     exported_names =-      concatMap availNamesWithSelectors actual_exports+      concatMap availNamesWithSelectors tcg_exports      -- Module imports of the form `import X`. Note that there is     -- a) no qualification and@@ -253,9 +251,13 @@   -- Infer module safety   safety   <- liftIO (finalSafeMode ms_hspp_opts tc_gbl_env) +  -- The docs added via Template Haskell's putDoc+  thDocs@ExtractedTHDocs { ethd_mod_header = thMbDocStr } <-+    liftIO $ extractTHDocs <$> readIORef tcg_th_docs+   -- Process the top-level module header documentation.   (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name-    tcg_rdr_env safety tcg_doc_hdr+    tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr))    -- Warnings on declarations in this module   decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)@@ -269,11 +271,11 @@     warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces))    maps@(!docs, !arg_docs, !decl_map, _) <--    liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls)+    liftErrMsg (mkMaps dflags pkg_name tcg_rdr_env local_instances decls thDocs)    export_items <- mkExportItems is_sig ifaces pkg_name tcg_mod tcg_semantic_mod     warnings tcg_rdr_env exported_names (map fst decls) maps fixities-    imported_modules loc_splices export_list actual_exports inst_ifaces dflags+    imported_modules loc_splices export_list tcg_exports inst_ifaces dflags    let     visible_names :: [Name]@@ -290,7 +292,7 @@     !coverage = (haddockable, haddocked)      aliases :: Map Module ModuleName-    aliases = mkAliasMap (unitState dflags) tcg_rn_imports+    aliases = mkAliasMap unit_state tcg_rn_imports    return $! Interface     {@@ -365,7 +367,7 @@ -- -- With our mapping we know that we can display exported modules M1 and M2. ---unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName]+unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports idecls =   M.map (map (unLoc . ideclName))   $ M.filter (all isInteresting) impModMap@@ -414,7 +416,7 @@     let ws' = [ (n, w)               | (occ, w) <- ws               , elt <- lookupGlobalRdrEnv gre occ-              , let n = gre_name elt, n `elem` exps ]+              , let n = greMangledName elt, n `elem` exps ]     in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws'  moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))@@ -481,11 +483,14 @@        -> GlobalRdrEnv        -> [Name]        -> [(LHsDecl GhcRn, [HsDocString])]+       -> ExtractedTHDocs -- ^ Template Haskell putDoc docs        -> ErrMsgM Maps-mkMaps dflags pkgName gre instances decls = do+mkMaps dflags pkgName gre instances decls thDocs = do   (a, b, c) <- unzip3 <$> traverse mappings decls-  pure ( f' (map (nubByName fst) a)-       , f  (filterMapping (not . M.null) b)+  (th_a, th_b) <- thMappings+  pure ( th_a `M.union` f' (map (nubByName fst) a)+       , fmap intmap2mapint $+           th_b `unionArgMaps` (f (filterMapping (not . IM.null) b))        , f  (filterMapping (not . null) c)        , instanceMap        )@@ -499,14 +504,37 @@     filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]     filterMapping p = map (filter (p . snd)) +    -- Convert IntMap -> IntMap+    -- TODO: should ArgMap eventually be switched over to IntMap?+    intmap2mapint = M.fromList . IM.toList++    -- | Extract the mappings from template haskell.+    -- No DeclMap/InstMap is needed since we already have access to the+    -- doc strings+    thMappings :: ErrMsgM (Map Name (MDoc Name), Map Name (IntMap (MDoc Name)))+    thMappings = do+      let ExtractedTHDocs+            _+            (DeclDocMap declDocs)+            (ArgDocMap argDocs)+            (DeclDocMap instDocs) = thDocs+          ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name)+          ds2mdoc = processDocStringParas dflags pkgName gre++      declDocs' <- mapM ds2mdoc declDocs+      argDocs'  <- mapM (mapM ds2mdoc) argDocs+      instDocs' <- mapM ds2mdoc instDocs+      return (declDocs' <> instDocs', argDocs')++     mappings :: (LHsDecl GhcRn, [HsDocString])              -> ErrMsgM ( [(Name, MDoc Name)]-                        , [(Name, Map Int (MDoc Name))]+                        , [(Name, IntMap (MDoc Name))]                         , [(Name,  [LHsDecl GhcRn])]                         )-    mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do-      let declDoc :: [HsDocString] -> Map Int HsDocString-                  -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name))+    mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do+      let declDoc :: [HsDocString] -> IntMap HsDocString+                  -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))           declDoc strs m = do             doc' <- processDocStrings dflags pkgName gre strs             m'   <- traverse (processDocStringParas dflags pkgName gre) m@@ -515,7 +543,7 @@       (doc, args) <- declDoc docStrs (declTypeDocs decl)        let-          subs :: [(Name, [HsDocString], Map Int HsDocString)]+          subs :: [(Name, [HsDocString], IntMap HsDocString)]           subs = subordinates instanceMap decl        (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs@@ -533,7 +561,7 @@         seqList subDocs `seq`         seqList subArgs `seq`         pure (dm, am, cm)-    mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], [])+    mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], [])      instanceMap :: Map RealSrcSpan Name     instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]@@ -544,7 +572,7 @@               -- The CoAx's loc is the whole line, but only for TFs. The               -- workaround is to dig into the family instance declaration and               -- get the identifier with the right location.-              TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d'))+              TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')               _ -> getInstLoc d     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].     names _ decl = getMainDeclBinder decl@@ -578,7 +606,7 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems-  :: (Monad m)+  :: Monad m   => Bool               -- is it a signature   -> IfaceMap   -> Maybe Package      -- this package@@ -617,7 +645,7 @@       return [ExportDoc doc]      lookupExport (IEDocNamed _ str, _)      = liftErrMsg $-      findNamedDoc str [ unLoc d | d <- decls ] >>= \case+      findNamedDoc str [ unL d | d <- decls ] >>= \case         Nothing -> return  []         Just docStr -> do           doc <- processDocStringParas dflags pkgName gre docStr@@ -675,18 +703,19 @@       let t = availName avail       r    <- findDecl avail       case r of-        ([L l (ValD _ _)], (doc, _)) -> do+        ([L l' (ValD _ _)], (doc, _)) -> do+          let l = locA l'           -- Top-level binding without type signature           export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap           return [export]         (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->-          let declNames = getMainDeclBinder (unLoc decl)+          let declNames = getMainDeclBinder (unL decl)           in case () of             _               -- We should not show a subordinate by itself if any of its               -- parents is also exported. See note [1].               | t `notElem` declNames,-                Just p <- find isExported (parents t $ unLoc decl) ->+                Just p <- find isExported (parents t $ unL decl) ->                 do liftErrMsg $ tell [                      "Warning: " ++ moduleString thisMod ++ ": " ++                      pretty dflags (nameOccName t) ++ " is exported separately but " ++@@ -706,11 +735,11 @@                     let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig                     in availExportDecl avail newDecl docs_ -                  L loc (TyClD _ cl@ClassDecl{}) -> do+                  L loc (TyClD _ ClassDecl {..}) -> do                     mdef <- minimalDef t-                    let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef+                    let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef                     availExportDecl avail-                      (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_+                      (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_                    _ -> availExportDecl avail decl docs_ @@ -744,7 +773,7 @@           synifiedDeclOpt <- hiDecl dflags declName           case synifiedDeclOpt of             Just synifiedDecl -> pure synifiedDecl-            Nothing -> O.pprPanic "availExportItem" (O.text err)+            Nothing -> pprPanic "availExportItem" (O.text err)      availExportDecl :: AvailInfo -> LHsDecl GhcRn                     -> (DocForDecl Name, [(Name, DocForDecl Name)])@@ -842,16 +871,8 @@         constructor_names =           filter isDataConName (availSubordinates avail) --- 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)+availSubordinates = map greNameMangledName . availSubordinateGreNames  availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] availNoDocs avail =@@ -864,7 +885,6 @@     | Module.isHoleModule m = mkModule this_uid (moduleName m)     | otherwise             = m --- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: Monad m => DynFlags -> Name -> IfM m (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do   mayTyThing <- lookupName t@@ -875,12 +895,12 @@     Just x -> case tyThingToLHsDecl ShowRuntimeRep x of       Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing       Right (m, t') -> liftErrMsg (tell $ map bugWarn m)-                      >> return (Just $ noLoc t')+                      >> return (Just $ noLocA t')     where       warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>                    O.comma O.<+> O.quotes (O.ppr t) O.<+>                    O.text "-- Please report this on Haddock issue tracker!"-      bugWarn = O.showSDoc dflags . warnLine+      bugWarn = showSDoc dflags . warnLine  -- | This function is called for top-level bindings without type signatures. -- It gets the type signature from GHC and that means it's not going to@@ -895,7 +915,7 @@     Nothing -> return (ExportNoDecl name [])     Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)   where-    fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t+    fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t     fixities = case fixity of       Just f  -> [(name, f)]       Nothing -> []@@ -996,7 +1016,7 @@         doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)         return [[ExportDoc doc]]       (L _ (ValD _ valDecl))-        | name:_ <- collectHsBindBinders valDecl+        | name:_ <- collectHsBindBinders CollNoDictBinders valDecl         , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap         -> return []       _ ->@@ -1011,7 +1031,6 @@     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@@ -1062,7 +1081,7 @@        TyClD _ d@DataDecl { tcdLName = L _ dataNm                          , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do-        let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d))+        let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d)         lsig <- if isDataConName name                   then extractPatternSyn name dataNm ty_args dataCons                   else extractRecSel name dataNm ty_args dataCons@@ -1072,43 +1091,42 @@         | isValName name         , Just (famInst:_) <- M.lookup name declMap         -> extractDecl declMap name famInst-      InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body =-          FamEqn { feqn_tycon = L _ famName-                 , feqn_pats  = ty_args-                 , feqn_rhs   = HsDataDefn { dd_cons = dataCons } }}))) -> do-        lsig <- if isDataConName name-                  then extractPatternSyn name famName ty_args dataCons-                  else extractRecSel name famName ty_args dataCons-        pure (SigD noExtField <$> lsig)+      InstD _ (DataFamInstD _ (DataFamInstDecl+                            (FamEqn { feqn_tycon = L _ n+                                    , feqn_pats  = tys+                                    , feqn_rhs   = defn }))) ->+        if isDataConName name+        then fmap (SigD noExtField) <$> extractPatternSyn name n tys (dd_cons defn)+        else fmap (SigD noExtField) <$> extractRecSel name n tys (dd_cons defn)       InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts })         | isDataConName name ->-            let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body =-                                          FamEqn { feqn_rhs   = HsDataDefn { dd_cons = dataCons }-                                                 }-                                         })) <- insts-                               , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons)+            let matches = [ d' | L _ d'@(DataFamInstDecl (FamEqn { feqn_rhs = dd })) <- insts+                               , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))                                ]             in case matches of-                [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0)))+                [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))                 _    -> Left "internal: extractDecl (ClsInstD)"         | otherwise ->-            let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d }))+            let matches = [ d' | L _ d'@(DataFamInstDecl d )                                    <- insts                                  -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d)-                               , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d))+                               , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d))                                , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)                                , L _ n <- ns                                , extFieldOcc n == name                           ]             in case matches of-              [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0)+              [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)               _ -> Left "internal: extractDecl (ClsInstD)"       _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn)+extractPatternSyn :: HasCallStack+                  => Name -> Name+                  -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]+                  -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons =   case filter matches cons of-    [] -> Left . O.showSDocUnsafe $+    [] -> Left . O.showSDocOneLine O.defaultSDocContext $           O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t     con:_ -> pure (extract <$> con)  where@@ -1117,37 +1135,41 @@   extract :: ConDecl GhcRn -> Sig GhcRn   extract con =     let args =-          case getConArgs con of-            PrefixCon args' -> (map hsScaledThing args')-            RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields-            InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]+          case con of+            ConDeclH98 { con_args = con_args' } -> case con_args' of+              PrefixCon _ args' -> map hsScaledThing args'+              RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields+              InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2]+            ConDeclGADT { con_g_args = con_args' } -> case con_args' of+              PrefixConGADT args' -> map hsScaledThing args'+              RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields         typ = longArrow args (data_ty con)         typ' =           case con of-            ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField cxt typ)+            ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)             _ -> typ-        typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')-    in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')+        typ'' = noLocA (HsQualTy noExtField Nothing typ')+    in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')    longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn-  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs+  longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs    data_ty con     | ConDeclGADT{} <- con = con_res_ty con-    | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs+    | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs                     where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn                           mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty                           mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki-                          mkAppTyArg f (HsArgPar _) = HsParTy noExtField f+                          mkAppTyArg f (HsArgPar _) = HsParTy noAnn f  extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]               -> Either ErrMsg (LSig GhcRn) extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"  extractRecSel nm t tvs (L _ con : rest) =-  case getConArgs con of-    RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->-      pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))+  case getRecConArgs_maybe con of+    Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->+      pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))     _ -> extractRecSel nm t tvs rest  where   matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]@@ -1156,11 +1178,11 @@   data_ty     -- ResTyGADT _ ty <- con_res con = ty     | ConDeclGADT{} <- con = con_res_ty con-    | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs+    | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs                    where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn                          mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty                          mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki-                         mkAppTyArg f (HsArgPar _) = HsParTy noExtField f+                         mkAppTyArg f (HsArgPar _) = HsParTy noAnn f  -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]

@@ -5,7 +5,7 @@   , renderJson   ) where -import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Utils.Json import GHC.Unit.Module import GHC.Types.Name

@@ -22,8 +22,8 @@  import Control.Arrow import Control.Monad-import Data.Functor (($>))-import Data.List (maximumBy, (\\))+import Data.Functor+import Data.List ((\\), maximumBy) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import GHC.Driver.Session (languageExtensions)@@ -33,8 +33,9 @@ import Haddock.Parser import Haddock.Types import GHC.Types.Name+import GHC.Types.Avail ( availName ) import GHC.Parser.PostProcess-import GHC.Utils.Outputable ( showPpr, showSDoc )+import GHC.Driver.Ppr ( showPpr, showSDoc ) import GHC.Types.Name.Reader import GHC.Data.EnumSet as EnumSet @@ -57,13 +58,13 @@ processDocString dflags gre hds =   rename dflags gre $ parseString dflags (unpackHDS hds) -processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString+processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString                     -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags pkgName gre safety mayStr = do   (hmi, doc) <-     case mayStr of       Nothing -> return failure-      Just (L _ hds) -> do+      Just hds -> do         let str = unpackHDS hds             (hmi, doc) = parseModuleHeader dflags pkgName str         !descr <- case hmi_description hmi of@@ -135,7 +136,7 @@            -- There is only one name in the environment that matches so           -- use it.-          [a] -> pure (DocIdentifier (i $> gre_name a))+          [a] -> pure $ DocIdentifier (i $> greMangledName a)            -- There are multiple names available.           gres -> ambiguous dflags i gres@@ -200,9 +201,10 @@           -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above.           -> ErrMsgM (Doc Name) ambiguous dflags x gres = do-  let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres+  let noChildren = map availName (gresToAvailInfo gres)+      dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren       msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++-            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") gres +++            concatMap (\n -> "    * " ++ defnLoc n ++ "\n") (map greMangledName gres) ++             "    You may be able to disambiguate the identifier by qualifying it or\n" ++             "    by specifying the type/value namespace explicitly.\n" ++             "    Defaulting to the one defined " ++ defnLoc dflt@@ -211,10 +213,12 @@   -- of the same name, but not the only constructor.   -- For example, for @data D = C | D@, someone may want to reference the @D@   -- constructor.-  when (length (gresToAvailInfo gres) > 1) $ tell [msg]-  pure (DocIdentifier (x $> gre_name dflt))+  when (length noChildren > 1) $ tell [msg]+  pure (DocIdentifier (x $> dflt))   where-    defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name+    isLocalName (nameSrcLoc -> RealSrcLoc {}) = True+    isLocalName _ = False+    defnLoc = showSDoc dflags . pprNameDefnLoc  -- | Handle value-namespaced names that cannot be for values. --

@@ -34,6 +34,7 @@ import qualified Data.Set as Set import Prelude hiding (mapM) import GHC.HsToCore.Docs+import GHC.Types.Basic ( TopLevelFlag(..) )  -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to -- 'DocName'.@@ -173,10 +174,9 @@ rename = lookupRn  -renameL :: Located Name -> RnM (Located DocName)+renameL :: GenLocated l Name -> RnM (GenLocated l DocName) renameL = mapM rename - renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -213,10 +213,10 @@ renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp  renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)-renameLSigType = renameImplicit renameLType+renameLSigType = mapM renameSigType  renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)-renameLSigWcType = renameWc (renameImplicit renameLType)+renameLSigWcType = renameWc renameLSigType  renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType@@ -235,10 +235,10 @@          ; return (L loc (TyVarSig noExtField bndr')) }  renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)-renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))+renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs))     = do { lhs' <- renameL lhs          ; rhs' <- mapM renameL rhs-         ; return (L loc (InjectivityAnn lhs' rhs')) }+         ; return (L loc (InjectivityAnn noExtField lhs' rhs')) }  renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)                           -> RnM (Maybe (LInjectivityAnn DocNameI))@@ -246,76 +246,82 @@  renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)-renameArrow (HsLinearArrow u) = return (HsLinearArrow u)-renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p+renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)+renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p  renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of   HsForAllTy { hst_tele = tele, hst_body = ltype } -> do     tele'  <- renameHsForAllTelescope tele     ltype' <- renameLType ltype-    return (HsForAllTy { hst_xforall = noExtField+    return (HsForAllTy { hst_xforall = noAnn                        , hst_tele = tele', hst_body = ltype' })    HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do-    lcontext' <- renameLContext lcontext+    lcontext' <- traverse renameLContext lcontext     ltype'    <- renameLType ltype-    return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' })+    return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) -  HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n-  HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype+  HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n+  HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype -  HsStarTy _ isUni -> return (HsStarTy noExtField isUni)+  HsStarTy _ isUni -> return (HsStarTy noAnn isUni)    HsAppTy _ a b -> do     a' <- renameLType a     b' <- renameLType b-    return (HsAppTy noExtField a' b')+    return (HsAppTy noAnn a' b')    HsAppKindTy _ a b -> do     a' <- renameLType a     b' <- renameLKind b-    return (HsAppKindTy noExtField a' b')+    return (HsAppKindTy noAnn a' b')    HsFunTy _ w a b -> do     a' <- renameLType a     b' <- renameLType b     w' <- renameArrow w-    return (HsFunTy noExtField w' a' b')+    return (HsFunTy noAnn w' a' b') -  HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty-  HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty)+  HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty+  HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) -  HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts-  HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts+  HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts+  HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts    HsOpTy _ a (L loc op) b -> do     op' <- rename op     a'  <- renameLType a     b'  <- renameLType b-    return (HsOpTy noExtField a' (L loc op') b')+    return (HsOpTy noAnn a' (L loc op') b') -  HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty+  HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty    HsKindSig _ ty k -> do     ty' <- renameLType ty     k' <- renameLKind k-    return (HsKindSig noExtField ty' k')+    return (HsKindSig noAnn ty' k')    HsDocTy _ ty doc -> do     ty' <- renameLType ty     doc' <- renameLDocHsSyn doc-    return (HsDocTy noExtField ty' doc')+    return (HsDocTy noAnn ty' doc') -  HsTyLit _ x -> return (HsTyLit noExtField x)+  HsTyLit _ x -> return (HsTyLit noAnn x) -  HsRecTy _ a               -> HsRecTy noExtField <$> mapM renameConDeclFieldField a-  (XHsType (NHsCoreTy a))   -> pure (XHsType (NHsCoreTy a))-  HsExplicitListTy i a b  -> HsExplicitListTy i a <$> mapM renameLType b-  HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b+  HsRecTy _ a               -> HsRecTy noAnn <$> mapM renameConDeclFieldField a+  XHsType a                 -> pure (XHsType a)+  HsExplicitListTy _ a b  -> HsExplicitListTy noAnn a <$> mapM renameLType b+  HsExplicitTupleTy _ b   -> HsExplicitTupleTy noAnn <$> mapM renameLType b   HsSpliceTy _ s          -> renameHsSpliceTy s-  HsWildCardTy a          -> pure (HsWildCardTy a)+  HsWildCardTy _          -> pure (HsWildCardTy noAnn) +renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)+renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do+  bndrs' <- renameOuterTyVarBndrs bndrs+  body'  <- renameLType body+  pure $ HsSig { sig_ext = noExtField, sig_bndrs = bndrs', sig_body = body' }+ -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: --@@ -335,21 +341,21 @@  renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of-  HsForAllVis   x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs-                              pure $ HsForAllVis x bndrs'-  HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs-                              pure $ HsForAllInvis x bndrs'+  HsForAllVis   _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+                              pure $ HsForAllVis noExtField bndrs'+  HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs+                              pure $ HsForAllInvis noExtField bndrs'  renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI)-renameLTyVarBndr (L loc (UserTyVar x fl (L l n)))+renameLTyVarBndr (L loc (UserTyVar _ fl (L l n)))   = do { n' <- rename n-       ; return (L loc (UserTyVar x fl (L l n'))) }-renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind))+       ; return (L loc (UserTyVar noExtField fl (L l n'))) }+renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind))   = do { n' <- rename n        ; kind' <- renameLKind kind-       ; return (L loc (KindedTyVar x fl (L lv n') kind')) }+       ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])+renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI]) renameLContext (L loc context) = do   context' <- mapM renameLType context   return (L loc context')@@ -400,8 +406,8 @@     return (DerivD noExtField d')   _ -> error "renameDecl" -renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))-renameLThing fn (L loc x) = return . L loc =<< fn x+renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI))+renameLThing fn (L loc x) = return . L (locA loc) =<< fn x  renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of@@ -426,7 +432,7 @@    ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity             , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do-    lcontext' <- renameLContext lcontext+    lcontext' <- traverse renameLContext lcontext     lname'    <- renameL lname     ltyvars'  <- renameLHsQTyVars ltyvars     lfundeps' <- mapM renameLFunDep lfundeps@@ -440,12 +446,13 @@                       , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField })    where-    renameLFunDep (L loc (xs, ys)) = do+    renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI)+    renameLFunDep (L loc (FunDep _ xs ys)) = do       xs' <- mapM rename (map unLoc xs)       ys' <- mapM rename (map unLoc ys)-      return (L loc (map noLoc xs', map noLoc ys'))+      return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) -    renameLSig (L loc sig) = return . L loc =<< renameSig sig+    renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig  renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname@@ -458,7 +465,8 @@     ltyvars'     <- renameLHsQTyVars ltyvars     result'      <- renameFamilyResultSig result     injectivity' <- renameMaybeInjectivityAnn injectivity-    return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname'+    return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel+                       , fdLName = lname'                        , fdTyVars = ltyvars'                        , fdFixity = fixity                        , fdResultSig = result'@@ -484,64 +492,73 @@ 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+    lcontext' <- traverse renameLContext lcontext     k'        <- renameMaybeLKind k-    cons'     <- mapM (mapM renameCon) cons+    cons'     <- mapM (mapMA renameCon) cons     -- I don't think we need the derivings, so we return Nothing     return (HsDataDefn { dd_ext = noExtField                        , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType                        , dd_kindSig = k', dd_cons = cons'-                       , dd_derivs = noLoc [] })+                       , dd_derivs = [] })  renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars                            , con_mb_cxt = lcontext, con_args = details-                           , con_doc = mbldoc }) = do+                           , con_doc = mbldoc+                           , con_forall = forall }) = do       lname'    <- renameL lname       ltyvars'  <- mapM renameLTyVarBndr ltyvars       lcontext' <- traverse renameLContext lcontext-      details'  <- renameDetails details+      details'  <- renameH98Details details       mbldoc'   <- mapM renameLDocHsSyn mbldoc       return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'                    , con_mb_cxt = lcontext'+                   , con_forall = forall -- Remove when #18311 is fixed                    , con_args = details', con_doc = mbldoc' }) -renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars-                            , con_mb_cxt = lcontext, con_args = details+renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs+                            , con_mb_cxt = lcontext, con_g_args = details                             , con_res_ty = res_ty-                            , con_doc = mbldoc }) = do+                            , con_doc = mbldoc } = do       lnames'   <- mapM renameL lnames-      ltyvars'  <- mapM renameLTyVarBndr ltyvars+      bndrs'    <- mapM renameOuterTyVarBndrs bndrs       lcontext' <- traverse renameLContext lcontext-      details'  <- renameDetails details+      details'  <- renameGADTDetails details       res_ty'   <- renameLType res_ty       mbldoc'   <- mapM renameLDocHsSyn mbldoc-      return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'-                   , con_mb_cxt = lcontext', con_args = details'+      return (ConDeclGADT+                   { con_g_ext = noExtField, con_names = lnames', con_bndrs = bndrs'+                   , con_mb_cxt = lcontext', con_g_args = details'                    , con_res_ty = res_ty', con_doc = mbldoc' })  renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)                -> RnM (HsScaled DocNameI (LHsType DocNameI)) renameHsScaled (HsScaled w ty) = HsScaled <$> renameArrow w <*> renameLType ty -renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI)-renameDetails (RecCon (L l fields)) = do+renameH98Details :: HsConDeclH98Details GhcRn+                 -> RnM (HsConDeclH98Details DocNameI)+renameH98Details (RecCon (L l fields)) = do   fields' <- mapM renameConDeclFieldField fields-  return (RecCon (L l fields'))-                               -- This causes an assertion failure---renameDetails (PrefixCon ps) = -- return . PrefixCon =<< mapM (_renameLType) ps-renameDetails (PrefixCon ps) = PrefixCon <$> mapM renameHsScaled ps-renameDetails (InfixCon a b) = do+  return (RecCon (L (locA l) fields'))+renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps+renameH98Details (InfixCon a b) = do   a' <- renameHsScaled a   b' <- renameHsScaled b   return (InfixCon a' b') +renameGADTDetails :: HsConDeclGADTDetails GhcRn+                  -> RnM (HsConDeclGADTDetails DocNameI)+renameGADTDetails (RecConGADT (L l fields)) = do+  fields' <- mapM renameConDeclFieldField fields+  return (RecConGADT (L (locA l) fields'))+renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps+ renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do   names' <- mapM renameLFieldOcc names   t'   <- renameLType t   doc' <- mapM renameLDocHsSyn doc-  return $ L l (ConDeclField noExtField names' t' doc')+  return $ L (locA l) (ConDeclField noExtField names' t' doc')  renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do@@ -606,10 +623,10 @@                     , deriv_overlap_mode = omode })  renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI)-renameDerivStrategy StockStrategy    = pure StockStrategy-renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy-renameDerivStrategy NewtypeStrategy  = pure NewtypeStrategy-renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty+renameDerivStrategy (StockStrategy a)    = pure (StockStrategy a)+renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a)+renameDerivStrategy (NewtypeStrategy a)  = pure (NewtypeStrategy a)+renameDerivStrategy (ViaStrategy ty)     = ViaStrategy <$> renameLSigType ty  renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode@@ -627,35 +644,29 @@ renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })   = do { eqn' <- renameTyFamInstEqn eqn-       ; return (TyFamInstDecl { tfid_eqn = eqn' }) }+       ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) }  renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)-renameTyFamInstEqn eqn-  = renameImplicit rename_ty_fam_eqn eqn-  where-    rename_ty_fam_eqn-      :: FamEqn GhcRn (LHsType GhcRn)-      -> RnM (FamEqn DocNameI (LHsType DocNameI))-    rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs-                              , feqn_pats = pats, feqn_fixity = fixity-                              , feqn_rhs = rhs })-      = do { tc' <- renameL tc-           ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs-           ; pats' <- mapM renameLTypeArg pats-           ; rhs' <- renameLType rhs-           ; return (FamEqn { feqn_ext    = noExtField-                            , feqn_tycon  = tc'-                            , feqn_bndrs  = bndrs'-                            , feqn_pats   = pats'-                            , feqn_fixity = fixity-                            , feqn_rhs    = rhs' }) }+renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs+                           , feqn_pats = pats, feqn_fixity = fixity+                           , feqn_rhs = rhs })+  = do { tc' <- renameL tc+       ; bndrs' <- renameOuterTyVarBndrs bndrs+       ; pats' <- mapM renameLTypeArg pats+       ; rhs' <- renameLType rhs+       ; return (FamEqn { feqn_ext    = noExtField+                        , feqn_tycon  = tc'+                        , feqn_bndrs  = bndrs'+                        , feqn_pats   = pats'+                        , feqn_fixity = fixity+                        , feqn_rhs    = rhs' }) }  renameTyFamDefltD :: TyFamDefltDecl GhcRn -> RnM (TyFamDefltDecl DocNameI) renameTyFamDefltD = renameTyFamInstD  renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })-  = do { eqn' <- renameImplicit rename_data_fam_eqn eqn+  = do { eqn' <- rename_data_fam_eqn eqn        ; return (DataFamInstDecl { dfid_eqn = eqn' }) }   where     rename_data_fam_eqn@@ -665,7 +676,7 @@                                 , feqn_pats = pats, feqn_fixity = fixity                                 , feqn_rhs = defn })       = do { tc' <- renameL tc-           ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs+           ; bndrs' <- renameOuterTyVarBndrs bndrs            ; pats' <- mapM renameLTypeArg pats            ; defn' <- renameDataDefn defn            ; return (FamEqn { feqn_ext    = noExtField@@ -675,13 +686,12 @@                             , feqn_fixity = fixity                             , feqn_rhs    = defn' }) } -renameImplicit :: (in_thing -> RnM 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'-                      , hsib_ext = noExtField }) }+renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn+                      -> RnM (HsOuterTyVarBndrs flag DocNameI)+renameOuterTyVarBndrs (HsOuterImplicit{}) =+  pure $ HsOuterImplicit{hso_ximplicit = noExtField}+renameOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = exp_bndrs}) =+  HsOuterExplicit noExtField <$> mapM renameLTyVarBndr exp_bndrs  renameWc :: (in_thing -> RnM out_thing)          -> HsWildCardBndrs GhcRn in_thing

@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module Haddock.Interface.Specialize@@ -18,7 +19,6 @@ import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )-import GHC.Parser.Annotation (IsUnicodeSyntax(..))  import Control.Monad import Control.Monad.Trans.State@@ -38,7 +38,7 @@     go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x     go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map -    strip_kind_sig :: HsType name -> HsType name+    strip_kind_sig :: HsType GhcRn -> HsType GhcRn     strip_kind_sig (HsKindSig _ (L _ t) _) = t     strip_kind_sig typ = typ @@ -57,7 +57,7 @@ -- -- 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 :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn+specializeTyVarBndrs :: Data a => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs   where     bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs@@ -74,13 +74,13 @@               -> Sig GhcRn               -> Sig GhcRn specializeSig bndrs typs (TypeSig _ lnames typ) =-  TypeSig noExtField lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})+  TypeSig noAnn lnames (typ {hswc_body = noLocA typ'})   where-    true_type :: HsType GhcRn-    true_type = unLoc (hsSigWcType typ)-    typ' :: HsType GhcRn+    true_type :: HsSigType GhcRn+    true_type = unLoc (dropWildCards typ)+    typ' :: HsSigType GhcRn     typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type-    fv = foldr Set.union Set.empty . map freeVariables $ typs+    fv = foldr Set.union Set.empty . map freeVariablesType $ typs specializeSig _ _ sig = sig  @@ -110,7 +110,7 @@  sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)-    | getName name == listTyConName = HsListTy noExtField ltyp+    | getName name == listTyConName = HsListTy noAnn ltyp sugarLists typ = typ  @@ -121,7 +121,7 @@     aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp     aux apps (HsParTy _ (L _ typ')) = aux apps typ'     aux apps (HsTyVar _ _ (L _ name))-        | isBuiltInSyntax name' && suitable = HsTupleTy noExtField HsBoxedTuple apps+        | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps       where         name' = getName name         strName = getOccString name@@ -131,10 +131,10 @@     aux _ _ = typ  -sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)+sugarOperators :: HsType GhcRn -> HsType GhcRn sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)     | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb-    | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb+    | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb   where     name' = getName name sugarOperators typ = typ@@ -176,19 +176,25 @@ -- not converted to 'String' or alike to avoid new allocations. Additionally, -- since it is stored mostly in 'Set', fast comparison of 'FastString' is also -- quite nice.-type NameRep = FastString+newtype NameRep+   = NameRep FastString+   deriving (Eq) +instance Ord NameRep where+   compare (NameRep fs1) (NameRep fs2) = uniqCompareFS fs1 fs2++ getNameRep :: NamedThing name => name -> NameRep-getNameRep = getOccFS+getNameRep = NameRep . getOccFS  nameRepString :: NameRep -> String-nameRepString = unpackFS+nameRepString (NameRep fs) = unpackFS fs  stringNameRep :: String -> NameRep-stringNameRep = mkFastString+stringNameRep = NameRep . mkFastString  setInternalNameRep :: SetName name => NameRep -> name -> name-setInternalNameRep = setInternalOccName . mkVarOccFS+setInternalNameRep (NameRep fs) = setInternalOccName (mkVarOccFS fs)  setInternalOccName :: SetName name => OccName -> name -> name setInternalOccName occ name =@@ -198,25 +204,39 @@     nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)  --- | Compute set of free variables of given type.-freeVariables :: HsType GhcRn -> Set Name-freeVariables =-    everythingWithState Set.empty Set.union query-  where-    query term ctx = case cast term :: Maybe (HsType GhcRn) of-        Just (HsForAllTy _ tele _) ->-            (Set.empty, Set.union ctx (teleNames tele))-        Just (HsTyVar _ _ (L _ name))-            | getName name `Set.member` ctx -> (Set.empty, ctx)-            | otherwise -> (Set.singleton $ getName name, ctx)-        _ -> (Set.empty, ctx)+-- | Compute set of free variables of a given 'HsType'.+freeVariablesType :: HsType GhcRn -> Set Name+freeVariablesType =+    everythingWithState Set.empty Set.union+      (mkQ (\ctx -> (Set.empty, ctx)) queryType) +-- | Compute set of free variables of a given 'HsType'.+freeVariablesSigType :: HsSigType GhcRn -> Set Name+freeVariablesSigType =+    everythingWithState Set.empty Set.union+      (mkQ (\ctx -> (Set.empty, ctx)) queryType `extQ` querySigType)++queryType :: HsType GhcRn -> Set Name -> (Set Name, Set Name)+queryType term ctx = case term of+    HsForAllTy _ tele _ ->+        (Set.empty, Set.union ctx (teleNames tele))+    HsTyVar _ _ (L _ name)+        | getName name `Set.member` ctx -> (Set.empty, ctx)+        | otherwise -> (Set.singleton $ getName name, ctx)+    _ -> (Set.empty, ctx)+  where+    teleNames :: HsForAllTelescope GhcRn -> Set Name     teleNames (HsForAllVis   _ bndrs) = bndrsNames bndrs     teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs -    bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc)+querySigType :: HsSigType GhcRn -> Set Name -> (Set Name, Set Name)+querySigType (HsSig { sig_bndrs = outer_bndrs }) ctx =+  (Set.empty, Set.union ctx (bndrsNames (hsOuterExplicitBndrs outer_bndrs))) +bndrsNames :: [LHsTyVarBndr flag GhcRn] -> Set Name+bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + -- | Make given type visually unambiguous. -- -- After applying 'specialize' method, some free type variables may become@@ -225,12 +245,12 @@ -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@).-rename :: Set Name -> HsType GhcRn -> HsType GhcRn-rename fv typ = evalState (renameType typ) env+rename :: Set Name -> HsSigType GhcRn -> HsSigType GhcRn+rename fv typ = evalState (renameSigType typ) env   where     env = RenameEnv       { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv-      , rneSigFVs = Set.map getNameRep $ freeVariables typ+      , rneSigFVs = Set.map getNameRep $ freeVariablesSigType typ       , rneCtx = Map.empty       }     mkPair name = (getNameRep name, name)@@ -245,6 +265,17 @@   }  +renameSigType :: HsSigType GhcRn -> Rename (IdP GhcRn) (HsSigType GhcRn)+renameSigType (HsSig x bndrs body) =+  HsSig x <$> renameOuterTyVarBndrs bndrs <*> renameLType body++renameOuterTyVarBndrs :: HsOuterTyVarBndrs flag GhcRn+                      -> Rename (IdP GhcRn) (HsOuterTyVarBndrs flag GhcRn)+renameOuterTyVarBndrs (HsOuterImplicit imp_tvs) =+  HsOuterImplicit <$> mapM renameName imp_tvs+renameOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =+  HsOuterExplicit x <$> mapM renameLBinder exp_bndrs+ renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) renameType (HsForAllTy x tele lt) =     HsForAllTy x@@ -252,9 +283,9 @@         <*> renameLType lt renameType (HsQualTy x lctxt lt) =     HsQualTy x-        <$> located renameContext lctxt+        <$> renameMContext lctxt         <*> renameLType lt-renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name+renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk@@ -263,7 +294,7 @@ renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt renameType (HsOpTy x la lop lb) =-    HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb+    HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk@@ -271,7 +302,7 @@ renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt renameType t@(HsRecTy _ _) = pure t-renameType t@(XHsType (NHsCoreTy _)) = pure t+renameType t@(XHsType _) = pure t renameType (HsExplicitListTy x ip ltys) =     HsExplicitListTy x ip <$> renameLTypes ltys renameType (HsExplicitTupleTy x ltys) =@@ -280,7 +311,7 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)  renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)-renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p+renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p renameHsArrow mult = pure mult  @@ -293,6 +324,11 @@ renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType +renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))+renameMContext Nothing = return Nothing+renameMContext (Just (L l ctxt)) = do+  ctxt' <- renameContext ctxt+  return (Just (L l ctxt'))  renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes@@ -305,9 +341,9 @@   HsForAllInvis x <$> mapM renameLBinder bndrs  renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn)-renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname+renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname renameBinder (KindedTyVar x fl lname lkind) =-  KindedTyVar x fl <$> located renameName lname <*> located renameType lkind+  KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind  renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn) renameLBinder = located renameBinder@@ -360,5 +396,13 @@     str = nameRepString name  -located :: Functor f => (a -> f b) -> Located a -> f (Located b)+located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b) located f (L loc e) = L loc <$> f e++locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b)+locatedN f (L loc e) = L loc <$> f e+++tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn+tyVarName (UserTyVar _ _ name) = unLoc name+tyVarName (KindedTyVar _ _ (L _ name) _) = name

@@ -38,7 +38,7 @@ import GHC.Data.FastString import GHC hiding (NoLink) import GHC.Driver.Monad (withSession)-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Types.Name.Cache import GHC.Iface.Env import GHC.Types.Name@@ -94,7 +94,7 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0)+#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0) binaryInterfaceVersion = 38  binaryInterfaceVersionCompatibility :: [Word16]@@ -123,14 +123,12 @@   put_ bh0 symtab_p_p    -- Make some intial state-  symtab_next <- newFastMutInt-  writeFastMutInt symtab_next 0+  symtab_next <- newFastMutInt 0   symtab_map <- newIORef emptyUFM   let bin_symtab = BinSymbolTable {                       bin_symtab_next = symtab_next,                       bin_symtab_map  = symtab_map }-  dict_next_ref <- newFastMutInt-  writeFastMutInt dict_next_ref 0+  dict_next_ref <- newFastMutInt 0   dict_map_ref <- newIORef emptyUFM   let bin_dict = BinDictionary {                       bin_dict_next = dict_next_ref,

@@ -24,7 +24,6 @@   optSourceCssFile,   sourceUrls,   wikiUrls,-  baseUrl,   optParCount,   optDumpInterfaceFile,   optShowInterfaceFile,@@ -47,9 +46,8 @@ import           Data.Version import           Control.Applicative import           GHC.Data.FastString-import           GHC ( DynFlags, Module, moduleUnit, unitState )-import           GHC.Unit.Info ( PackageName(..), unitPackageName, unitPackageVersion )-import           GHC.Unit.State ( lookupUnit  )+import           GHC ( Module, moduleUnit )+import           GHC.Unit.State import           Haddock.Types import           Haddock.Utils import           System.Console.GetOpt@@ -74,7 +72,6 @@   | Flag_SourceEntityURL  String   | Flag_SourceLEntityURL String   | Flag_WikiBaseURL   String-  | Flag_BaseURL       String   | Flag_WikiModuleURL String   | Flag_WikiEntityURL String   | Flag_LaTeX@@ -160,8 +157,6 @@       "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",     Option []  ["comments-base"]   (ReqArg Flag_WikiBaseURL "URL")       "URL for a comments link on the contents\nand index pages",-    Option [] ["base-url"] (ReqArg Flag_BaseURL "URL")-      "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.",     Option []  ["comments-module"]  (ReqArg Flag_WikiModuleURL "URL")       "URL for a comments link for each module\n(using the %{MODULE} var)",     Option []  ["comments-entity"]  (ReqArg Flag_WikiEntityURL "URL")@@ -306,9 +301,6 @@   ,optLast [str | Flag_WikiEntityURL str <- flags])  -baseUrl :: [Flag] -> Maybe String-baseUrl flags = optLast [str | Flag_BaseURL str <- flags]- optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] @@ -388,16 +380,16 @@ -- -- The @--package-name@ and @--package-version@ Haddock flags allow the user to -- specify this information manually and it is returned here if present.-modulePackageInfo :: DynFlags+modulePackageInfo :: UnitState                   -> [Flag] -- ^ Haddock flags are checked as they may contain                             -- the package name or version provided by the user                             -- which we prioritise                   -> Maybe Module                   -> (Maybe PackageName, Maybe Data.Version.Version)-modulePackageInfo _dflags _flags Nothing = (Nothing, Nothing)-modulePackageInfo dflags flags (Just modu) =+modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)+modulePackageInfo unit_state flags (Just modu) =   ( optPackageName flags    <|> fmap unitPackageName pkgDb   , optPackageVersion flags <|> fmap unitPackageVersion pkgDb   )   where-    pkgDb = lookupUnit (unitState dflags) (moduleUnit modu)+    pkgDb = lookupUnit unit_state (moduleUnit modu)

@@ -19,8 +19,9 @@ import Haddock.Types  import GHC.Driver.Session ( DynFlags )+import GHC.Driver.Config import GHC.Data.FastString   ( fsLit )-import GHC.Parser.Lexer ( mkPState, unP, ParseResult(POk, PFailed) )+import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser       ( parseIdentifier ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Name.Reader ( RdrName(..) )@@ -48,7 +49,7 @@     PFailed{} -> Nothing   where     realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0-    pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc+    pstate str = initParserState (initParserOpts dflags) (stringToStringBuffer str) realSrcLc     (wrap,str1) = case str0 of                     '(' : s@(c : _) | c /= ',', c /= ')'  -- rule out tuple names                                     -> (Parenthesized, init s)

@@ -6,7 +6,7 @@ module Haddock.Syb     ( everything, everythingButType, everythingWithState     , everywhere, everywhereButType-    , mkT+    , mkT, mkQ, extQ     , combine     ) where @@ -90,6 +90,21 @@ mkT f = case cast f of     Just f' -> f'     Nothing -> id++-- | Create generic query.+--+-- Another function stolen from SYB package.+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = case cast a of+                        Just b  -> br b+                        Nothing -> r+++-- | Extend a generic query by a type-specific case.+--+-- Another function stolen from SYB package.+extQ :: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q+extQ f g a = maybe (f a) g (cast a)  -- | Combine two queries into one using alternative combinator. combine :: Alternative f => (forall a. Data a => a -> f r)

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]@@ -44,7 +45,9 @@ import Data.Data (Data) import Data.Void (Void) import Documentation.Haddock.Types-import GHC.Types.Basic (Fixity(..), PromotionFlag(..))+import GHC.Types.Basic (PromotionFlag(..))+import GHC.Types.Fixity (Fixity(..))+import GHC.Types.Var (Specificity)  import GHC import GHC.Driver.Session (Language)@@ -311,10 +314,12 @@  data DocNameI +type instance NoGhcTc DocNameI = DocNameI+ type instance IdP DocNameI = DocName  instance CollectPass DocNameI where-  collectXXPat _ ext = noExtCon ext+  collectXXPat _ _ ext = noExtCon ext  instance NamedThing DocName where   getName (Documented name _) = name@@ -403,13 +408,13 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl     { pfdInfo :: FamilyInfo name-    , pfdLName :: Located (IdP name)+    , pfdLName :: LocatedN (IdP name)     , pfdTyVars :: [LHsType name]     , pfdKindSig :: LFamilyResultSig name     }  -mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p)+mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl     { pfdInfo = fdInfo     , pfdLName = fdLName@@ -417,12 +422,12 @@     , pfdKindSig = fdResultSig     }   where-    mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p)+    mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn     mkType (KindedTyVar _ _ (L loc name) lkind) =-        HsKindSig noExtField tvar lkind+        HsKindSig noAnn tvar lkind       where-        tvar = L loc (HsTyVar noExtField NotPromoted (L loc name))-    mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name+        tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name))+    mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name   -- | An instance head that may have documentation and a source location.@@ -687,41 +692,71 @@ liftErrMsg :: ErrMsgM a -> ErrMsgGhc a liftErrMsg = writer . runWriter -instance MonadThrow ErrMsgGhc where-  throwM e = ErrMsgGhc (throwM e)--instance MonadCatch ErrMsgGhc where-  catch (ErrMsgGhc m) f = ErrMsgGhc (catch m (unErrMsgGhc . f))- ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance XRec DocNameI f = Located (f DocNameI)+type instance XRec DocNameI a = GenLocated (Anno a) a+instance UnXRec DocNameI where+  unXRec = unLoc+instance MapXRec DocNameI where+  mapXRec = fmap+instance WrapXRec DocNameI (HsType DocNameI) where+  wrapXRec = noLocA -type instance XForAllTy        DocNameI = NoExtField-type instance XQualTy          DocNameI = NoExtField-type instance XTyVar           DocNameI = NoExtField-type instance XStarTy          DocNameI = NoExtField-type instance XAppTy           DocNameI = NoExtField-type instance XAppKindTy       DocNameI = NoExtField-type instance XFunTy           DocNameI = NoExtField-type instance XListTy          DocNameI = NoExtField-type instance XTupleTy         DocNameI = NoExtField-type instance XSumTy           DocNameI = NoExtField-type instance XOpTy            DocNameI = NoExtField-type instance XParTy           DocNameI = NoExtField-type instance XIParamTy        DocNameI = NoExtField-type instance XKindSig         DocNameI = NoExtField+type instance Anno DocName                           = SrcSpanAnnN+type instance Anno (HsTyVarBndr flag DocNameI)       = SrcSpanAnnA+type instance Anno [LocatedA (HsType DocNameI)]      = SrcSpanAnnC+type instance Anno (HsType DocNameI)                 = SrcSpanAnnA+type instance Anno (DataFamInstDecl DocNameI)        = SrcSpanAnnA+type instance Anno (DerivStrategy DocNameI)          = SrcSpan+type instance Anno (FieldOcc DocNameI)               = SrcSpan+type instance Anno (ConDeclField DocNameI)           = SrcSpan+type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan+type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan+type instance Anno (ConDecl DocNameI)                = SrcSpan+type instance Anno (FunDep DocNameI)                 = SrcSpan+type instance Anno (TyFamInstDecl DocNameI)          = SrcSpanAnnA+type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL+type instance Anno (FamilyDecl DocNameI)               = SrcSpan+type instance Anno (Sig DocNameI)                      = SrcSpan+type instance Anno (InjectivityAnn DocNameI)           = SrcSpan+type instance Anno (HsDecl DocNameI)                   = SrcSpanAnnA+type instance Anno (FamilyResultSig DocNameI)          = SrcSpan+type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA+type instance Anno (HsSigType DocNameI)                     = SrcSpanAnnA++type XRecCond a+  = ( XParTy a           ~ EpAnn AnnParen+    , NoGhcTc a ~ a+    , MapXRec a+    , UnXRec a+    , WrapXRec a (HsType a)+    )++type instance XForAllTy        DocNameI = EpAnn [AddEpAnn]+type instance XQualTy          DocNameI = EpAnn [AddEpAnn]+type instance XTyVar           DocNameI = EpAnn [AddEpAnn]+type instance XStarTy          DocNameI = EpAnn [AddEpAnn]+type instance XAppTy           DocNameI = EpAnn [AddEpAnn]+type instance XAppKindTy       DocNameI = EpAnn [AddEpAnn]+type instance XFunTy           DocNameI = EpAnn [AddEpAnn]+type instance XListTy          DocNameI = EpAnn AnnParen+type instance XTupleTy         DocNameI = EpAnn AnnParen+type instance XSumTy           DocNameI = EpAnn AnnParen+type instance XOpTy            DocNameI = EpAnn [AddEpAnn]+type instance XParTy           DocNameI = EpAnn AnnParen+type instance XIParamTy        DocNameI = EpAnn [AddEpAnn]+type instance XKindSig         DocNameI = EpAnn [AddEpAnn] type instance XSpliceTy        DocNameI = Void       -- see `renameHsSpliceTy`-type instance XDocTy           DocNameI = NoExtField-type instance XBangTy          DocNameI = NoExtField-type instance XRecTy           DocNameI = NoExtField-type instance XExplicitListTy  DocNameI = NoExtField-type instance XExplicitTupleTy DocNameI = NoExtField-type instance XTyLit           DocNameI = NoExtField-type instance XWildCardTy      DocNameI = NoExtField-type instance XXType           DocNameI = NewHsTypeX+type instance XDocTy           DocNameI = EpAnn [AddEpAnn]+type instance XBangTy          DocNameI = EpAnn [AddEpAnn]+type instance XRecTy           DocNameI = EpAnn [AddEpAnn]+type instance XExplicitListTy  DocNameI = EpAnn [AddEpAnn]+type instance XExplicitTupleTy DocNameI = EpAnn [AddEpAnn]+type instance XTyLit           DocNameI = EpAnn [AddEpAnn]+type instance XWildCardTy      DocNameI = EpAnn [AddEpAnn]+type instance XXType           DocNameI = HsCoreTy  type instance XHsForAllVis        DocNameI = NoExtField type instance XHsForAllInvis      DocNameI = NoExtField@@ -763,6 +798,9 @@  type instance XCClsInstDecl DocNameI = NoExtField type instance XCDerivDecl   DocNameI = NoExtField+type instance XStockStrategy    DocNameI = NoExtField+type instance XAnyClassStrategy DocNameI = NoExtField+type instance XNewtypeStrategy  DocNameI = NoExtField type instance XViaStrategy  DocNameI = LHsSigType DocNameI type instance XDataFamInstD DocNameI = NoExtField type instance XTyFamInstD   DocNameI = NoExtField@@ -776,12 +814,23 @@ type instance XXFamilyDecl  DocNameI = NoExtCon type instance XXTyClDecl    DocNameI = NoExtCon -type instance XHsIB             DocNameI _ = NoExtField-type instance XHsWC             DocNameI _ = NoExtField-type instance XXHsImplicitBndrs DocNameI _ = NoExtCon+type instance XHsWC DocNameI _ = NoExtField +type instance XHsOuterExplicit    DocNameI _ = NoExtField+type instance XHsOuterImplicit    DocNameI   = NoExtField+type instance XXHsOuterTyVarBndrs DocNameI   = NoExtCon++type instance XHsSig      DocNameI = NoExtField+type instance XXHsSigType DocNameI = NoExtCon+ type instance XHsQTvs        DocNameI = NoExtField type instance XConDeclField  DocNameI = NoExtField type instance XXConDeclField DocNameI = NoExtCon  type instance XXPat DocNameI = NoExtCon++type instance XCInjectivityAnn DocNameI = NoExtField++type instance XCFunDep DocNameI = NoExtField++type instance XCTyFamInstDecl DocNameI = NoExtField

@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module      :  Haddock.Utils

@@ -1,6 +1,4 @@-{-# LANGUAGE ExplicitForAll    #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}  -- | Minimal JSON / RFC 7159 support --@@ -14,53 +12,35 @@     , encodeToString     , encodeToBuilder     , ToJSON(toJSON)--    , Parser(..)-    , Result(..)-    , FromJSON(parseJSON)-    , withObject-    , withArray-    , withString-    , withDouble-    , withBool-    , fromJSON-    , parse-    , parseEither-    , (.:)-    , (.:?)-    , decode-    , decodeWith-    , eitherDecode-    , eitherDecodeWith-    , decodeFile-    , eitherDecodeFile     )     where -import Control.Applicative (Alternative (..))-import Control.Monad (MonadPlus (..), zipWithM, (>=>))-import qualified Control.Monad as Monad-import qualified Control.Monad.Fail as Fail--import qualified Data.ByteString.Lazy as BSL-import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BB import Data.Char import Data.Int+import Data.String import Data.Word import Data.List (intersperse) import Data.Monoid -import GHC.Natural+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB  -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' -import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy-import qualified Text.ParserCombinators.Parsec as Parsec+-- | 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) -import Haddock.Utils.Json.Types-import Haddock.Utils.Json.Parser+-- | A key\/value pair for an 'Object'+type Pair = (String, Value) +-- | A JSON \"object\" (key/value map).+type Object = [Pair]  infixr 8 .= @@ -68,7 +48,14 @@ (.=) :: 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.@@ -236,324 +223,3 @@      -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF     needsEscape c = ord c < 0x20 || c `elem` ['\\','"']----------------------------------------------------------------------------------- FromJSON---- | Elements of a JSON path used to describe the location of an--- error.-data JSONPathElement-  = Key String-  -- ^ JSON path element of a key into an object,-  -- \"object.key\".-  | Index !Int-  -- ^ JSON path element of an index into an-  -- array, \"array[index]\".-  deriving (Eq, Show, Ord)--type JSONPath = [JSONPathElement]---- | Failure continuation.-type Failure f r   = JSONPath -> String -> f r---- | Success continuation.-type Success a f r = a -> f r--newtype Parser a = Parser {-      runParser :: forall f r.-                   JSONPath-                -> Failure f r-                -> Success a f r-                -> f r-    }--modifyFailure :: (String -> String) -> Parser a -> Parser a-modifyFailure f (Parser p) = Parser $ \path kf ks ->-    p path (\p' m -> kf p' (f m)) ks--prependFailure :: String -> Parser a -> Parser a-prependFailure = modifyFailure . (++)--prependContext :: String -> Parser a -> Parser a-prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")--typeMismatch :: String -> Value -> Parser a-typeMismatch expected actual =-    fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual--instance Monad.Monad Parser where-    m >>= g = Parser $ \path kf ks ->-      runParser m path kf-                       (\a -> runParser (g a) path kf ks)-    return = pure--instance Fail.MonadFail Parser where-    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg--instance Functor Parser where-    fmap f m = Parser $ \path kf ks ->-      let ks' a = ks (f a)-      in runParser m path kf ks'--instance Applicative Parser where-    pure a = Parser $ \_path _kf ks -> ks a-    (<*>) = apP--instance Alternative Parser where-    empty = fail "empty"-    (<|>) = mplus--instance MonadPlus Parser where-    mzero = fail "mzero"-    mplus a b = Parser $ \path kf ks ->-      runParser a path (\_ _ -> runParser b path kf ks) ks--instance Semigroup (Parser a) where-    (<>) = mplus--instance Monoid (Parser a) where-    mempty  = fail "mempty"-    mappend = (<>)--apP :: Parser (a -> b) -> Parser a -> Parser b-apP d e = do-  b <- d-  b <$> e--(<?>) :: Parser a -> JSONPathElement -> Parser a-p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks--parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a-parseIndexedJSON p idx value = p value <?> Index idx--unexpected :: Value -> Parser a-unexpected actual = fail $ "unexpected " ++ typeOf actual--withObject :: String -> (Object -> Parser a) -> Value -> Parser a-withObject _    f (Object obj) = f obj-withObject name _ v            = prependContext name (typeMismatch "Object" v)--withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a-withArray _    f (Array arr) = f arr-withArray name _ v           = prependContext name (typeMismatch "Array" v)--withString :: String -> (String -> Parser a) -> Value -> Parser a-withString _    f (String txt) = f txt-withString name _ v            = prependContext name (typeMismatch "String" v)--withDouble :: String -> (Double -> Parser a) -> Value -> Parser a-withDouble _    f (Number duble) = f duble-withDouble name _ v              = prependContext name (typeMismatch "Number" v)--withBool :: String -> (Bool -> Parser a) -> Value -> Parser a-withBool _    f (Bool arr) = f arr-withBool name _ v          = prependContext name (typeMismatch "Boolean" v)--class FromJSON a where-    parseJSON     :: Value -> Parser a--    parseJSONList :: Value -> Parser [a]-    parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..])--instance FromJSON Bool where-    parseJSON (Bool b)  = pure b-    parseJSON v = typeMismatch "Bool" v--instance FromJSON () where-    parseJSON =-      withArray "()" $ \v ->-        if null v-          then pure ()-          else prependContext "()" $ fail "expected an empty array"--instance FromJSON Char where-    parseJSON = withString "Char" parseChar--    parseJSONList (String s) = pure s-    parseJSONList v = typeMismatch "String" v--parseChar :: String -> Parser Char-parseChar t =-    if length t == 1-      then pure $ head t-      else prependContext "Char" $ fail "expected a string of length 1"--parseRealFloat :: RealFloat a => String -> Value -> Parser a-parseRealFloat _    (Number s) = pure $ realToFrac s-parseRealFloat _    Null       = pure (0/0)-parseRealFloat name v          = prependContext name (unexpected v)--instance FromJSON Double where-    parseJSON = parseRealFloat "Double"--instance FromJSON Float where-    parseJSON = parseRealFloat "Float"--parseNatural :: Integer -> Parser Natural-parseNatural integer =-    if integer < 0 then-        fail $ "parsing Natural failed, unexpected negative number " <> show integer-    else-        pure $ fromIntegral integer--parseIntegralFromDouble :: Integral a => Double -> Parser a-parseIntegralFromDouble d =-    let r = toRational d-        x = truncate r-    in if toRational x == r-         then pure $ x-         else fail $ "unexpected floating number " <> show d--parseIntegral :: Integral a => String -> Value -> Parser a-parseIntegral name = withDouble name parseIntegralFromDouble--instance FromJSON Integer where-    parseJSON = parseIntegral "Integer"--instance FromJSON Natural where-    parseJSON = withDouble "Natural"-                  (parseIntegralFromDouble >=> parseNatural)--instance FromJSON Int where-    parseJSON = parseIntegral "Int"--instance FromJSON Int8 where-    parseJSON = parseIntegral "Int8"--instance FromJSON Int16 where-    parseJSON = parseIntegral "Int16"--instance FromJSON Int32 where-    parseJSON = parseIntegral "Int32"--instance FromJSON Int64 where-    parseJSON = parseIntegral "Int64"--instance FromJSON Word where-    parseJSON = parseIntegral "Word"--instance FromJSON Word8 where-    parseJSON = parseIntegral "Word8"--instance FromJSON Word16 where-    parseJSON = parseIntegral "Word16"--instance FromJSON Word32 where-    parseJSON = parseIntegral "Word32"--instance FromJSON Word64 where-    parseJSON = parseIntegral "Word64"--instance FromJSON a => FromJSON [a] where-    parseJSON = parseJSONList--data Result a = Error String-              | Success a-                deriving (Eq, Show)--fromJSON :: FromJSON a => Value -> Result a-fromJSON = parse parseJSON--parse :: (a -> Parser b) -> a -> Result b-parse m v = runParser (m v) [] (const Error) Success--parseEither :: (a -> Parser b) -> a -> Either String b-parseEither m v = runParser (m v) [] onError Right-  where onError path msg = Left (formatError path msg)--formatError :: JSONPath -> String -> String-formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg--formatPath :: JSONPath -> String-formatPath path = "$" ++ formatRelativePath path--formatRelativePath :: JSONPath -> String-formatRelativePath path = format "" path-  where-    format :: String -> JSONPath -> String-    format pfx []                = pfx-    format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts-    format pfx (Key key:parts)   = format (pfx ++ formatKey key) parts--    formatKey :: String -> String-    formatKey key-       | isIdentifierKey key = "." ++ key-       | otherwise           = "['" ++ escapeKey key ++ "']"--    isIdentifierKey :: String -> Bool-    isIdentifierKey []     = False-    isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs--    escapeKey :: String -> String-    escapeKey = concatMap escapeChar--    escapeChar :: Char -> String-    escapeChar '\'' = "\\'"-    escapeChar '\\' = "\\\\"-    escapeChar c    = [c]--explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a-explicitParseField p obj key =-    case key `lookup` obj of-      Nothing -> fail $ "key " ++ key ++ " not found"-      Just v  -> p v <?> Key key--(.:) :: FromJSON a => Object -> String -> Parser a-(.:) = explicitParseField parseJSON--explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a)-explicitParseFieldMaybe p obj key =-    case key `lookup` obj of-      Nothing -> pure Nothing-      Just v  -> Just <$> p v <?> Key key--(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a)-(.:?) = explicitParseFieldMaybe parseJSON---decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a-decodeWith decoder bsl =-   case Parsec.parse parseJSONValue "<input>" bsl of-     Left  _    -> Nothing-     Right json ->-       case decoder json of-         Success a -> Just a-         Error _   -> Nothing--decode :: FromJSON a => BSL.ByteString -> Maybe a-decode = decodeWith fromJSON--eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a-eitherDecodeWith decoder bsl =-    case Parsec.parse parseJSONValue "<input>" bsl of-      Left parsecError -> Left (show parsecError)-      Right json ->-        case decoder json of-          Success a -> Right a-          Error err -> Left  err--eitherDecode :: FromJSON a => BSL.ByteString -> Either String a-eitherDecode = eitherDecodeWith fromJSON---decodeFile :: FromJSON a => FilePath -> IO (Maybe a)-decodeFile filePath = do-    parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath-    case parsecResult of-      Right r ->-        case fromJSON r of-          Success a -> return (Just a)-          Error   _ -> return Nothing-      Left _ -> return Nothing---eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a)-eitherDecodeFile filePath = do-    parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath-    case parsecResult of-      Right r ->-        case fromJSON r of-          Success a -> return (Right a)-          Error err -> return (Left err)-      Left err -> return $ Left (show err)-

@@ -1,102 +0,0 @@--- | Json "Parsec" parser, based on--- [json](https://hackage.haskell.org/package/json) package.----module Haddock.Utils.Json.Parser-  ( parseJSONValue-  ) where--import Prelude hiding (null)--import Control.Applicative (Alternative (..))-import Control.Monad (MonadPlus (..))-import Data.Char (isHexDigit)-import Data.Functor (($>))-import qualified Data.ByteString.Lazy.Char8 as BSCL-import Numeric-import Text.Parsec.ByteString.Lazy (Parser)-import Text.ParserCombinators.Parsec ((<?>))-import qualified Text.ParserCombinators.Parsec as Parsec--import Haddock.Utils.Json.Types hiding (object)--parseJSONValue :: Parser Value-parseJSONValue = Parsec.spaces *> parseValue--tok :: Parser a -> Parser a-tok p = p <* Parsec.spaces--parseValue :: Parser Value-parseValue =-         parseNull-     <|> Bool   <$> parseBoolean-     <|> Array  <$> parseArray-     <|> String <$> parseString-     <|> Object <$> parseObject-     <|> Number <$> parseNumber-     <?> "JSON value"--parseNull :: Parser Value-parseNull = tok-     $  Parsec.string "null"-     $> Null--parseBoolean :: Parser Bool-parseBoolean = tok-     $  Parsec.string "true"  $> True-    <|> Parsec.string "false" $> False--parseArray :: Parser [Value]-parseArray =-    Parsec.between-      (tok (Parsec.char '['))-      (tok (Parsec.char ']'))-      (parseValue `Parsec.sepBy` tok (Parsec.char ','))--parseString :: Parser String-parseString =-    Parsec.between-      (tok (Parsec.char '"'))-      (tok (Parsec.char '"'))-      (many char)-  where-    char = (Parsec.char '\\' >> escapedChar)-       <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\')--    escapedChar =-          Parsec.char '"'  $> '"'-      <|> Parsec.char '\\' $> '\\'-      <|> Parsec.char '/'  $> '/'-      <|> Parsec.char 'b'  $> '\b'-      <|> Parsec.char 'f'  $> '\f'-      <|> Parsec.char 'n'  $> '\n'-      <|> Parsec.char 'r'  $> '\r'-      <|> Parsec.char 't'  $> '\t'-      <|> Parsec.char 'u'  *> uni-      <?> "escape character"--    uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)-      where-        check x | code <= max_char = return (toEnum code)-                | otherwise        = mzero-          where code      = fst $ head $ readHex x-                max_char  = fromEnum (maxBound :: Char)--parseObject :: Parser Object-parseObject =-      Parsec.between-        (tok (Parsec.char '{'))-        (tok (Parsec.char '}'))-        (field `Parsec.sepBy` tok (Parsec.char ','))-  where-    field :: Parser (String, Value)-    field = (,)-        <$> parseString-        <*  tok (Parsec.char ':')-        <*> parseValue--parseNumber :: Parser Double-parseNumber = tok $ do-  s <- BSCL.unpack <$> Parsec.getInput-  case readSigned readFloat s of-    [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n-    _        -> mzero

@@ -1,42 +0,0 @@-module Haddock.Utils.Json.Types-  ( Value(..)-  , typeOf-  , Pair-  , Object-  , object-  ) where--import Data.String---- TODO: We may want to replace 'String' with 'Text' or 'ByteString'---- | A JSON value represented as a Haskell value.-data Value = Object !Object-           | Array  [Value]-           | String  String-           | Number !Double-           | Bool   !Bool-           | Null-           deriving (Eq, Read, Show)--typeOf :: Value -> String-typeOf v = case v of-    Object _ -> "Object"-    Array _  -> "Array"-    String _ -> "String"-    Number _ -> "Number"-    Bool _   -> "Boolean"-    Null     -> "Null"---- | A key\/value pair for an 'Object'-type Pair = (String, Value)---- | A JSON \"object\" (key/value map).-type Object = [Pair]---- | Create a 'Value' from a list of name\/value 'Pair's.-object :: [Pair] -> Value-object = Object--instance IsString Value where-  fromString = String