diff --git a/haddock-api.cabal b/haddock-api.cabal --- a/haddock-api.cabal +++ b/haddock-api.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: haddock-api -version: 2.18.1 +version: 2.19.0.1 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -12,7 +13,6 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -cabal-version: >= 2.0 extra-source-files: CHANGES.md @@ -20,8 +20,10 @@ data-dir: resources data-files: + html/quick-jump.min.js + html/haddock-bundle.min.js + html/quick-jump.css html/solarized.css - html/haddock-util.js html/highlight.js html/Classic.theme/haskell_icon.gif html/Classic.theme/minus.gif @@ -38,11 +40,11 @@ default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base ^>= 4.10.0 - , Cabal ^>= 2.0.0 - , ghc ^>= 8.2 + build-depends: base ^>= 4.11.0 + , Cabal ^>= 2.2.0 + , ghc ^>= 8.4 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.4.4 + , haddock-library ^>= 1.5.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -73,15 +75,18 @@ Haddock.Interface.Rename Haddock.Interface.Create Haddock.Interface.AttachInstances + Haddock.Interface.Json Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Interface.Specialize Haddock.Parser Haddock.Utils + Haddock.Utils.Json Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta Haddock.Backends.Xhtml.Names Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types @@ -119,24 +124,68 @@ test , src - -- NB: We only use a small subset of lib:haddock-api here, which - -- explains why this component has a smaller build-depends set other-modules: + Haddock + Haddock.Backends.Hoogle + Haddock.Backends.Hyperlinker + Haddock.Backends.Hyperlinker.Ast + Haddock.Backends.Hyperlinker.Renderer + Haddock.Backends.Hyperlinker.Utils + Haddock.Backends.LaTeX + Haddock.Backends.Xhtml + Haddock.Backends.Xhtml.Decl + Haddock.Backends.Xhtml.DocMarkup + Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta + Haddock.Backends.Xhtml.Names + Haddock.Backends.Xhtml.Themes + Haddock.Backends.Xhtml.Types + Haddock.Backends.Xhtml.Utils + Haddock.Convert + Haddock.Doc + Haddock.GhcUtils + Haddock.Interface + Haddock.Interface.AttachInstances + Haddock.Interface.Create + Haddock.Interface.Json + Haddock.Interface.LexParseRn + Haddock.Interface.ParseModuleHeader + Haddock.Interface.Rename + Haddock.Interface.Specialize + Haddock.InterfaceFile + Haddock.ModuleTree + Haddock.Options + Haddock.Parser + Haddock.Syb + Haddock.Types + Haddock.Utils + Haddock.Utils.Json + Haddock.Version + Paths_haddock_api Haddock.Backends.Hyperlinker.ParserSpec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: - ghc ^>= 8.2 - , hspec ^>= 2.4.4 - , QuickCheck ^>= 2.10 + build-depends: Cabal ^>= 2.0.0 + , ghc ^>= 8.4 + , ghc-paths ^>= 0.1.0.9 + , haddock-library ^>= 1.5.0 + , xhtml ^>= 3000.2.2 + , hspec ^>= 2.4.4 + , QuickCheck ^>= 2.11 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version -- bounds - build-depends: - base - , containers + build-depends: base + , array + , bytestring + , containers + , deepseq + , directory + , filepath + , ghc-boot + , transformers build-tool-depends: hspec-discover:hspec-discover ^>= 2.4.4 diff --git a/resources/html/Classic.theme/xhaddock.css b/resources/html/Classic.theme/xhaddock.css --- a/resources/html/Classic.theme/xhaddock.css +++ b/resources/html/Classic.theme/xhaddock.css @@ -392,6 +392,20 @@ } +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} #footer { background-color: #000099; diff --git a/resources/html/Ocean.std-theme/ocean.css b/resources/html/Ocean.std-theme/ocean.css --- a/resources/html/Ocean.std-theme/ocean.css +++ b/resources/html/Ocean.std-theme/ocean.css @@ -46,6 +46,14 @@ /* @end */ +/* @group Show and hide with JS */ + +body.js-enabled .hide-when-js-enabled { + display: none; +} + +/* @end */ + /* @group Fonts & Sizes */ /* Basic technique & IE workarounds from YUI 3 @@ -106,7 +114,7 @@ /* @group Common */ -.caption, h1, h2, h3, h4, h5, h6 { +.caption, h1, h2, h3, h4, h5, h6, summary { font-weight: bold; color: rgb(78,98,114); margin: 0.8em 0 0.4em; @@ -168,7 +176,17 @@ min-height: 9px; } +summary { + cursor: pointer; + outline: none; + list-style-image: url(plus.gif); + list-style-position: outside; +} +details[open] > summary { + list-style-image: url(minus.gif); +} + pre { padding: 0.25em; margin: 0.8em 0; @@ -338,7 +356,8 @@ z-index: 1; } -#synopsis .caption { +#synopsis summary { + display: block; float: left; width: 29px; color: rgba(255,255,255,0); @@ -346,16 +365,13 @@ margin: 0; font-size: 1px; padding: 0; + background: url(synopsis.png) no-repeat 0px -8px; } -#synopsis p.caption.collapser { +#synopsis details[open] > summary { background: url(synopsis.png) no-repeat -64px -8px; } -#synopsis p.caption.expander { - background: url(synopsis.png) no-repeat 0px -8px; -} - #synopsis ul { height: 100%; overflow: auto; @@ -419,14 +435,27 @@ vertical-align: top; padding-left: 0.5em; } -#interface td.src { - white-space: nowrap; -} + #interface td.doc p { margin: 0; } #interface td.doc p + p { margin-top: 0.8em; +} + +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; } .clearfix:after { diff --git a/resources/html/haddock-bundle.min.js b/resources/html/haddock-bundle.min.js new file mode 100644 --- /dev/null +++ b/resources/html/haddock-bundle.min.js @@ -0,0 +1,2 @@ +!function e(t,n,o){function r(s,a){if(!n[s]){if(!t[s]){var l="function"==typeof require&&require;if(!a&&l)return l(s,!0);if(i)return i(s,!0);var c=new Error("Cannot find module '"+s+"'");throw c.code="MODULE_NOT_FOUND",c}var u=n[s]={exports:{}};t[s][0].call(u.exports,function(e){var n=t[s][1][e];return r(n||e)},u,u.exports,e,t,n,o)}return n[s].exports}for(var i="function"==typeof require&&require,s=0;s element with id '"+e+"'");return t}function r(e){for(var t=e.target,n=t.id,r=o(n),i=r.element.open,s=0,l=r.toggles;s0&&(d[n.id]={element:n,openByDefault:!!n.open,toggles:[]},n.addEventListener("toggle",r))}}function s(e){var t=o(e).element;t.open=!t.open}function a(){var e=Object.keys(p);document.cookie="toggled="+encodeURIComponent(e.join("+"))}function l(){var e=h.getCookie("toggled");if(e)for(var t=0,n=e.split("+");t=0&&e.followActiveLink()),"s"===t.key&&"input"!==t.target.tagName.toLowerCase()&&(t.preventDefault(),e.show())})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},t.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},t.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t={};this.state.fuse.search(e).forEach(function(e){var n=e.item.module;(t[n]||(t[n]=[])).push(e)});var n=[];for(var o in t)!function(e){var o=t[e],r=0;o.forEach(function(e){r+=1/e.score}),n.push({module:e,totalScore:1/r,items:o})}(o);n.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:n})},t.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.top=0}function s(e,t){var n=o(e.className||"");n.indexOf(" "+t+" ")<0&&(e.className=r(n+" "+t))}function a(e,t){var n=o(e.className||"");n=n.replace(" "+t+" "," "),e.className=r(n)}function l(e,t,n,o){return null==o&&(o=!i(e,t)),o?(a(e,n),s(e,t)):(a(e,t),s(e,n)),o}function c(e){var t=document.getElementById("page-menu");if(t&&t.firstChild){var n=t.firstChild.cloneNode(!1);n.innerHTML=e,t.appendChild(n)}}function u(){return Array.prototype.slice.call(document.getElementsByTagName("link")).filter(function(e){return-1!=e.rel.indexOf("style")&&e.title})}function h(){var e=u(),t="";e.forEach(function(e){t+="
  • "+e.title+"
    • "}),e.length>1&&c("")}function d(e){for(var t=u(),n=null,o=0;on)return i(e,this.pattern,o);var r=this.options,a=r.location,l=r.distance,c=r.threshold,u=r.findAllMatches,h=r.minMatchCharLength;return s(e,this.pattern,this.patternAlphabet,{location:a,distance:l,threshold:c,findAllMatches:u,minMatchCharLength:h})}}]),e}();e.exports=l},function(e,t,n){"use strict";var o=n(0),r=function e(t,n,r){if(n){var i=n.indexOf("."),s=n,a=null;-1!==i&&(s=n.slice(0,i),a=n.slice(i+1));var l=t[s];if(null!==l&&void 0!==l)if(a||"string"!=typeof l&&"number"!=typeof l)if(o(l))for(var c=0,u=l.length;c0&&void 0!==arguments[0]?arguments[0]:[],t=arguments.length>1&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i=t&&n.push([o,r]),o=-1)}return e[i-1]&&i-o>=t&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o2&&void 0!==arguments[2]?arguments[2]:/ +/g,r=new RegExp(t.replace(o,"\\$&").replace(n,"|")),i=e.match(r),s=!!i,a=[];if(s)for(var l=0,c=i.length;l=E;P-=1){var R=P-1,U=n[e.charAt(R)];if(U&&(b[R]=1),j[P]=(j[P+1]<<1|1)&U,0!==I&&(j[P]|=(L[P+1]|L[P])<<1|1|L[P+1]),j[P]&N&&(C=o(t,{errors:I,currentLocation:R,expectedLocation:g,distance:c}))<=y){if(y=C,(_=R)<=g)break;E=Math.max(1,2*g-_)}}if(o(t,{errors:I+1,currentLocation:g,expectedLocation:g,distance:c})>y)break;L=j}return{isMatch:_>=0,score:0===C?.001:C,matchedIndices:r(b,v)}}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;n0&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o0&&void 0!==arguments[0]?arguments[0]:[],t=arguments[1],n=this.list,o={},r=[];if("string"==typeof n[0]){for(var i=0,s=n.length;i1)throw new Error("Key weight has to be > 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,l=e.index,c=t.tokenSearchers,u=void 0===c?[]:c,h=t.fullSearcher,d=void 0===h?[]:h,p=t.resultMap,f=void 0===p?{}:p,v=t.results,g=void 0===v?[]:v;if(void 0!==i&&null!==i){var m=!1,y=-1,_=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var k=d.search(i);if(this._log('Full text: "'+i+'", score: '+k.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),x=[],w=0;w-1&&(E=(E+y)/2),this._log("Score average:",E);var T=!this.options.tokenize||!this.options.matchAllTokens||_>=u.length;if(this._log("\nCheck Matches: "+T),(m||k.isMatch)&&T){var j=f[l];j?j.output.push({key:n,arrayIndex:r,value:i,score:E,matchedIndices:k.matchedIndices}):(f[l]={item:s,output:[{key:n,arrayIndex:r,value:i,score:E,matchedIndices:k.matchedIndices}]},g.push(f[l]))}}else if(a(i))for(var P=0,R=i.length;P-1&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;o2;)A.push(arguments[s]);for(n&&null!=n.children&&(A.length||A.push(n.children),delete n.children);A.length;)if((r=A.pop())&&void 0!==r.pop)for(s=r.length;s--;)A.push(r[s]);else"boolean"==typeof r&&(r=null),(i="function"!=typeof t)&&(null==r?r="":"number"==typeof r?r=String(r):"string"!=typeof r&&(i=!1)),i&&o?a[a.length-1]+=r:a===O?a=[r]:a.push(r),o=i;var l=new e;return l.nodeName=t,l.children=a,l.attributes=null==n?void 0:n,l.key=null==n?void 0:n.key,void 0!==I.vnode&&I.vnode(l),l}function o(e,t){for(var n in t)e[n]=t[n];return e}function r(e){!e.__d&&(e.__d=!0)&&1==j.push(e)&&(I.debounceRendering||E)(i)}function i(){var e,t=j;for(j=[];e=t.pop();)e.__d&&L(e)}function s(e,t,n){return"string"==typeof t||"number"==typeof t?void 0!==e.splitText:"string"==typeof t.nodeName?!e._componentConstructor&&a(e,t.nodeName):n||e._componentConstructor===t.nodeName}function a(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function l(e){var t=o({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var r in n)void 0===t[r]&&(t[r]=n[r]);return t}function c(e,t){var n=t?document.createElementNS("http://www.w3.org/2000/svg",e):document.createElement(e);return n.__n=e,n}function u(e){var t=e.parentNode;t&&t.removeChild(e)}function h(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===T.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,p,s):e.removeEventListener(t,p,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e)d(e,t,null==o?"":o),null!=o&&!1!==o||e.removeAttribute(t);else{var a=r&&t!==(t=t.replace(/^xlink\:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function d(e,t,n){try{e[t]=n}catch(e){}}function p(e){return this.__l[e.type](I.event&&I.event(e)||e)}function f(){for(var e;e=P.pop();)I.afterMount&&I.afterMount(e),e.componentDidMount&&e.componentDidMount()}function v(e,t,n,o,r,i){R++||(U=null!=r&&void 0!==r.ownerSVGElement,D=null!=e&&!("__preactattr_"in e));var s=g(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(D=!1,i||f()),s}function g(e,t,n,o,r){var i=e,s=U;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),y(e,!0))),i.__preactattr_=!0,i;var l=t.nodeName;if("function"==typeof l)return C(e,t,n,o);if(U="svg"===l||"foreignObject"!==l&&U,l=String(l),(!e||!a(e,l))&&(i=c(l,U),e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),y(e,!0)}var u=i.firstChild,h=i.__preactattr_,d=t.children;if(null==h){h=i.__preactattr_={};for(var p=i.attributes,f=p.length;f--;)h[p[f].name]=p[f].value}return!D&&d&&1===d.length&&"string"==typeof d[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=d[0]&&(u.nodeValue=d[0]):(d&&d.length||null!=u)&&m(i,d,n,o,D||null!=h.dangerouslySetInnerHTML),k(i,t.attributes,h),U=s,i}function m(e,t,n,o,r){var i,a,l,c,h,d=e.childNodes,p=[],f={},v=0,m=0,_=d.length,k=0,b=t?t.length:0;if(0!==_)for(L=0;L<_;L++){var x=d[L],w=x.__preactattr_;null!=(S=b&&w?x._component?x._component.__k:w.key:null)?(v++,f[S]=x):(w||(void 0!==x.splitText?!r||x.nodeValue.trim():r))&&(p[k++]=x)}if(0!==b)for(L=0;L2?[].slice.call(arguments,2):e.children)},Component:N,render:function(e,t,n){return v(n,e,{},!1,t,!1)},rerender:i,options:I};void 0!==t?t.exports=F:self.preact=F}()},{}]},{},[3]); +//# sourceMappingURL=haddock-bundle.min.js.map diff --git a/resources/html/haddock-util.js b/resources/html/haddock-util.js deleted file mode 100644 --- a/resources/html/haddock-util.js +++ /dev/null @@ -1,186 +0,0 @@ -// Haddock JavaScript utilities - -var rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; - -function spaced(s) { return (" " + s + " ").replace(rspace, " "); } -function trim(s) { return s.replace(rtrim, ""); } - -function hasClass(elem, value) { - var className = spaced(elem.className || ""); - return className.indexOf( " " + value + " " ) >= 0; -} - -function addClass(elem, value) { - var className = spaced(elem.className || ""); - if ( className.indexOf( " " + value + " " ) < 0 ) { - elem.className = trim(className + " " + value); - } -} - -function removeClass(elem, value) { - var className = spaced(elem.className || ""); - className = className.replace(" " + value + " ", " "); - elem.className = trim(className); -} - -function toggleClass(elem, valueOn, valueOff, bool) { - if (bool == null) { bool = ! hasClass(elem, valueOn); } - if (bool) { - removeClass(elem, valueOff); - addClass(elem, valueOn); - } - else { - removeClass(elem, valueOn); - addClass(elem, valueOff); - } - return bool; -} - - -function makeClassToggle(valueOn, valueOff) -{ - return function(elem, bool) { - return toggleClass(elem, valueOn, valueOff, bool); - } -} - -toggleShow = makeClassToggle("show", "hide"); -toggleCollapser = makeClassToggle("collapser", "expander"); - -function toggleSection(id) -{ - var b = toggleShow(document.getElementById("section." + id)); - toggleCollapser(document.getElementById("control." + id), b); - rememberCollapsed(id); - return b; -} - -var collapsed = {}; -function rememberCollapsed(id) -{ - if(collapsed[id]) - delete collapsed[id] - else - collapsed[id] = true; - - var sections = []; - for(var i in collapsed) - { - if(collapsed.hasOwnProperty(i)) - sections.push(i); - } - // cookie specific to this page; don't use setCookie which sets path=/ - document.cookie = "collapsed=" + escape(sections.join('+')); -} - -function restoreCollapsed() -{ - var cookie = getCookie("collapsed"); - if(!cookie) - return; - - var ids = cookie.split('+'); - for(var i in ids) - { - if(document.getElementById("section." + ids[i])) - toggleSection(ids[i]); - } -} - -function setCookie(name, value) { - document.cookie = name + "=" + escape(value) + ";path=/;"; -} - -function clearCookie(name) { - document.cookie = name + "=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"; -} - -function getCookie(name) { - var nameEQ = name + "="; - var ca = document.cookie.split(';'); - for(var i=0;i < ca.length;i++) { - var c = ca[i]; - while (c.charAt(0)==' ') c = c.substring(1,c.length); - if (c.indexOf(nameEQ) == 0) { - return unescape(c.substring(nameEQ.length,c.length)); - } - } - return null; -} - -function addMenuItem(html) { - var menu = document.getElementById("page-menu"); - if (menu) { - var btn = menu.firstChild.cloneNode(false); - btn.innerHTML = html; - menu.appendChild(btn); - } -} - -function styles() { - var i, a, es = document.getElementsByTagName("link"), rs = []; - for (i = 0; a = es[i]; i++) { - if(a.rel.indexOf("style") != -1 && a.title) { - rs.push(a); - } - } - return rs; -} - -function addStyleMenu() { - var as = styles(); - var i, a, btns = ""; - for(i=0; a = as[i]; i++) { - btns += "
  • " - + a.title + "
    • " - } - if (as.length > 1) { - var h = "
    " - + "Style ▾" - + "
      " + btns + "
    " - + "
    "; - addMenuItem(h); - } -} - -function setActiveStyleSheet(title) { - var as = styles(); - var i, a, found; - for(i=0; a = as[i]; i++) { - a.disabled = true; - // need to do this always, some browsers are edge triggered - if(a.title == title) { - found = a; - } - } - if (found) { - found.disabled = false; - setCookie("haddock-style", title); - } - else { - as[0].disabled = false; - clearCookie("haddock-style"); - } - styleMenu(false); -} - -function resetStyle() { - var s = getCookie("haddock-style"); - if (s) setActiveStyleSheet(s); -} - - -function styleMenu(show) { - var m = document.getElementById('style-menu'); - if (m) toggleShow(m, show); -} - - -function pageLoad() { - addStyleMenu(); - resetStyle(); - restoreCollapsed(); -} - diff --git a/resources/html/quick-jump.css b/resources/html/quick-jump.css new file mode 100644 --- /dev/null +++ b/resources/html/quick-jump.css @@ -0,0 +1,164 @@ +/* @group Search box layout */ + +#search { + position: fixed; + top: 3.2em; + bottom: 0; + left: calc(50% - 22em); + width: 44em; + z-index: 1000; + pointer-events: none; + overflow-y: auto; +} + +#search.hidden { + display: none; +} + +#search-form, #search-results { + box-shadow: 2px 2px 6px rgb(199, 204, 208); + pointer-events: all; +} + +#search-form input { + font-size: 1.25em; line-height: 2.3em; height: 2.4em; + display: block; + box-sizing: border-box; + width: 100%; + margin: 0; + padding: 0 0.75em; + border: 0.05em solid rgb(151, 179, 202); +} + +#search input:focus { + outline: none; +} + +#search p.error { + color: rgb(107, 24, 24); + font-weight: bold; +} + +#search-results { + box-sizing: border-box; + border: 0.05em solid #b2d5fb; + background: #e8f3ff; +} + +#search-form input + #search-results { + border-top: none; + top: 3em; + max-height: calc(100% - 3em); +} + +/* @end */ + +/* @group search results */ + +#search-results > ul { + margin: 0; + list-style: none; +} + +#search-results > ul > li, +#search-results > p, +#search-results > table { + padding: 0.5em 1em; + margin: 0; +} + +#search-results > ul > li { + border-bottom: 1px solid #b2d5fb; +} + +#search-results > ul > li > ul { + list-style: none; +} + +.search-module h4 { + margin: 0; +} + +.search-module > ul { + margin: 0.5em 0 0.5em 2em; +} + +.search-module > ul > li > a[href] { + display: block; + color: inherit; + padding: 0.25em 0.5em; +} + +.search-module > ul > li > a[href].active-link { + background: #faf9dc; +} + +.search-module a[href]:hover { + text-decoration: none; +} + +.search-result a a { + pointer-events: none; +} + +.search-result ul.subs { + display: inline-block; + margin: 0; padding: 0; +} + +.search-result ul.subs li { + display: none; +} + +.search-result ul.subs::after { + display: inline-block; + content: "..."; + color: rgb(78,98,114); + margin: 0 0.25em; +} + +.more-results { + color: rgb(99, 141, 173); + position: relative; +} + +.more-results::before { + content: "+"; + display: inline-block; + color: #b2d5fb; + font-weight: bold; + font-size: 1.25em; line-height: inherit; + position: absolute; + left: -1em; +} + +/* @end */ + +/* @group Keyboard shortcuts table */ + +.keyboard-shortcuts { + line-height: 1.6em; +} + +.keyboard-shortcuts th { + color: rgb(78,98,114); +} + +.keyboard-shortcuts td:first-child, +.keyboard-shortcuts th:first-child { + text-align: right; + padding-right: 0.6em; +} + +.key { + display: inline-block; + font-size: 0.9em; + min-width: 0.8em; line-height: 1.2em; + text-align: center; + background: #b2d5fb; + border: 1px solid #74a3d6; + padding: 0 0.2em; + margin: 0 0.1em; +} + +/* @end */ diff --git a/resources/html/quick-jump.min.js b/resources/html/quick-jump.min.js new file mode 100644 --- /dev/null +++ b/resources/html/quick-jump.min.js @@ -0,0 +1,2 @@ +!function e(t,n,o){function r(s,a){if(!n[s]){if(!t[s]){var l="function"==typeof require&&require;if(!a&&l)return l(s,!0);if(i)return i(s,!0);var c=new Error("Cannot find module '"+s+"'");throw c.code="MODULE_NOT_FOUND",c}var u=n[s]={exports:{}};t[s][0].call(u.exports,function(e){var n=t[s][1][e];return r(n||e)},u,u.exports,e,t,n,o)}return n[s].exports}for(var i="function"==typeof require&&require,s=0;s=0&&e.followActiveLink()),"s"===t.key&&"input"!==t.target.tagName.toLowerCase()&&(t.preventDefault(),e.show())})},t.prototype.hide=function(){this.setState({isVisible:!1})},t.prototype.show=function(){this.state.isVisible||(this.focusPlease=!0,this.setState({isVisible:!0,activeLinkIndex:-1}))},t.prototype.toggleVisibility=function(){this.state.isVisible?this.hide():this.show()},t.prototype.navigateLinks=function(e){var t=Math.max(-1,Math.min(this.linkIndex-1,this.state.activeLinkIndex+e));this.navigatedByKeyboard=!0,this.setState({activeLinkIndex:t})},t.prototype.followActiveLink=function(){this.activeLinkAction&&this.activeLinkAction()},t.prototype.updateResults=function(){var e=this.input&&this.input.value||"",t={};this.state.fuse.search(e).forEach(function(e){var n=e.item.module;(t[n]||(t[n]=[])).push(e)});var n=[];for(var o in t)!function(e){var o=t[e],r=0;o.forEach(function(e){r+=1/e.score}),n.push({module:e,totalScore:1/r,items:o})}(o);n.sort(function(e,t){return e.totalScore-t.totalScore}),this.setState({searchString:e,isVisible:!0,moduleResults:n})},t.prototype.componentDidUpdate=function(){if(this.searchResults&&this.activeLink&&this.navigatedByKeyboard){var e=this.activeLink.getClientRects()[0],t=this.searchResults.getClientRects()[0].top;e.bottom>window.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return i(e,this.pattern,o);var r=this.options,a=r.location,l=r.distance,c=r.threshold,u=r.findAllMatches,h=r.minMatchCharLength;return s(e,this.pattern,this.patternAlphabet,{location:a,distance:l,threshold:c,findAllMatches:u,minMatchCharLength:h})}}]),e}();e.exports=l},function(e,t,n){"use strict";var o=n(0),r=function e(t,n,r){if(n){var i=n.indexOf("."),s=n,a=null;-1!==i&&(s=n.slice(0,i),a=n.slice(i+1));var l=t[s];if(null!==l&&void 0!==l)if(a||"string"!=typeof l&&"number"!=typeof l)if(o(l))for(var c=0,u=l.length;c0&&void 0!==arguments[0]?arguments[0]:[],t=arguments.length>1&&void 0!==arguments[1]?arguments[1]:1,n=[],o=-1,r=-1,i=0,s=e.length;i=t&&n.push([o,r]),o=-1)}return e[i-1]&&i-o>=t&&n.push([o,i-1]),n}},function(e,t,n){"use strict";e.exports=function(e){for(var t={},n=e.length,o=0;o2&&void 0!==arguments[2]?arguments[2]:/ +/g,r=new RegExp(t.replace(o,"\\$&").replace(n,"|")),i=e.match(r),s=!!i,a=[];if(s)for(var l=0,c=i.length;l=O;E-=1){var R=E-1,U=n[e.charAt(R)];if(U&&(b[R]=1),P[E]=(P[E+1]<<1|1)&U,0!==I&&(P[E]|=(L[E+1]|L[E])<<1|1|L[E+1]),P[E]&N&&(C=o(t,{errors:I,currentLocation:R,expectedLocation:_,distance:c}))<=m){if(m=C,(y=R)<=_)break;O=Math.max(1,2*_-y)}}if(o(t,{errors:I+1,currentLocation:_,expectedLocation:_,distance:c})>m)break;L=P}return{isMatch:y>=0,score:0===C?.001:C,matchedIndices:r(b,v)}}},function(e,t,n){"use strict";function o(e,t){if(!(e instanceof t))throw new TypeError("Cannot call a class as a function")}var r=function(){function e(e,t){for(var n=0;n0&&void 0!==arguments[0]?arguments[0]:"",t=[];if(this.options.tokenize)for(var n=e.split(this.options.tokenSeparator),o=0,r=n.length;o0&&void 0!==arguments[0]?arguments[0]:[],t=arguments[1],n=this.list,o={},r=[];if("string"==typeof n[0]){for(var i=0,s=n.length;i1)throw new Error("Key weight has to be > 0 and <= 1");d=d.name}else a[d]={weight:1};this._analyze({key:d,value:this.options.getFn(u,d),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,l=e.index,c=t.tokenSearchers,u=void 0===c?[]:c,h=t.fullSearcher,p=void 0===h?[]:h,d=t.resultMap,f=void 0===d?{}:d,v=t.results,_=void 0===v?[]:v;if(void 0!==i&&null!==i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var k=p.search(i);if(this._log('Full text: "'+i+'", score: '+k.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),x=[],w=0;w-1&&(O=(O+m)/2),this._log("Score average:",O);var j=!this.options.tokenize||!this.options.matchAllTokens||y>=u.length;if(this._log("\nCheck Matches: "+j),(g||k.isMatch)&&j){var P=f[l];P?P.output.push({key:n,arrayIndex:r,value:i,score:O,matchedIndices:k.matchedIndices}):(f[l]={item:s,output:[{key:n,arrayIndex:r,value:i,score:O,matchedIndices:k.matchedIndices}]},_.push(f[l]))}}else if(a(i))for(var E=0,R=i.length;E-1&&(s.arrayIndex=i.arrayIndex),t.matches.push(s)}}}),this.options.includeScore&&n.push(function(e,t){t.score=e.score});for(var o=0,r=e.length;o2;)A.push(arguments[s]);for(n&&null!=n.children&&(A.length||A.push(n.children),delete n.children);A.length;)if((r=A.pop())&&void 0!==r.pop)for(s=r.length;s--;)A.push(r[s]);else"boolean"==typeof r&&(r=null),(i="function"!=typeof t)&&(null==r?r="":"number"==typeof r?r=String(r):"string"!=typeof r&&(i=!1)),i&&o?a[a.length-1]+=r:a===T?a=[r]:a.push(r),o=i;var l=new e;return l.nodeName=t,l.children=a,l.attributes=null==n?void 0:n,l.key=null==n?void 0:n.key,void 0!==I.vnode&&I.vnode(l),l}function o(e,t){for(var n in t)e[n]=t[n];return e}function r(e){!e.__d&&(e.__d=!0)&&1==P.push(e)&&(I.debounceRendering||O)(i)}function i(){var e,t=P;for(P=[];e=t.pop();)e.__d&&L(e)}function s(e,t,n){return"string"==typeof t||"number"==typeof t?void 0!==e.splitText:"string"==typeof t.nodeName?!e._componentConstructor&&a(e,t.nodeName):n||e._componentConstructor===t.nodeName}function a(e,t){return e.__n===t||e.nodeName.toLowerCase()===t.toLowerCase()}function l(e){var t=o({},e.attributes);t.children=e.children;var n=e.nodeName.defaultProps;if(void 0!==n)for(var r in n)void 0===t[r]&&(t[r]=n[r]);return t}function c(e,t){var n=t?document.createElementNS("http://www.w3.org/2000/svg",e):document.createElement(e);return n.__n=e,n}function u(e){var t=e.parentNode;t&&t.removeChild(e)}function h(e,t,n,o,r){if("className"===t&&(t="class"),"key"===t);else if("ref"===t)n&&n(null),o&&o(e);else if("class"!==t||r)if("style"===t){if(o&&"string"!=typeof o&&"string"!=typeof n||(e.style.cssText=o||""),o&&"object"==typeof o){if("string"!=typeof n)for(var i in n)i in o||(e.style[i]="");for(var i in o)e.style[i]="number"==typeof o[i]&&!1===j.test(i)?o[i]+"px":o[i]}}else if("dangerouslySetInnerHTML"===t)o&&(e.innerHTML=o.__html||"");else if("o"==t[0]&&"n"==t[1]){var s=t!==(t=t.replace(/Capture$/,""));t=t.toLowerCase().substring(2),o?n||e.addEventListener(t,d,s):e.removeEventListener(t,d,s),(e.__l||(e.__l={}))[t]=o}else if("list"!==t&&"type"!==t&&!r&&t in e)p(e,t,null==o?"":o),null!=o&&!1!==o||e.removeAttribute(t);else{var a=r&&t!==(t=t.replace(/^xlink\:?/,""));null==o||!1===o?a?e.removeAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase()):e.removeAttribute(t):"function"!=typeof o&&(a?e.setAttributeNS("http://www.w3.org/1999/xlink",t.toLowerCase(),o):e.setAttribute(t,o))}else e.className=o||""}function p(e,t,n){try{e[t]=n}catch(e){}}function d(e){return this.__l[e.type](I.event&&I.event(e)||e)}function f(){for(var e;e=E.pop();)I.afterMount&&I.afterMount(e),e.componentDidMount&&e.componentDidMount()}function v(e,t,n,o,r,i){R++||(U=null!=r&&void 0!==r.ownerSVGElement,D=null!=e&&!("__preactattr_"in e));var s=_(e,t,n,o,i);return r&&s.parentNode!==r&&r.appendChild(s),--R||(D=!1,i||f()),s}function _(e,t,n,o,r){var i=e,s=U;if(null!=t&&"boolean"!=typeof t||(t=""),"string"==typeof t||"number"==typeof t)return e&&void 0!==e.splitText&&e.parentNode&&(!e._component||r)?e.nodeValue!=t&&(e.nodeValue=t):(i=document.createTextNode(t),e&&(e.parentNode&&e.parentNode.replaceChild(i,e),m(e,!0))),i.__preactattr_=!0,i;var l=t.nodeName;if("function"==typeof l)return C(e,t,n,o);if(U="svg"===l||"foreignObject"!==l&&U,l=String(l),(!e||!a(e,l))&&(i=c(l,U),e)){for(;e.firstChild;)i.appendChild(e.firstChild);e.parentNode&&e.parentNode.replaceChild(i,e),m(e,!0)}var u=i.firstChild,h=i.__preactattr_,p=t.children;if(null==h){h=i.__preactattr_={};for(var d=i.attributes,f=d.length;f--;)h[d[f].name]=d[f].value}return!D&&p&&1===p.length&&"string"==typeof p[0]&&null!=u&&void 0!==u.splitText&&null==u.nextSibling?u.nodeValue!=p[0]&&(u.nodeValue=p[0]):(p&&p.length||null!=u)&&g(i,p,n,o,D||null!=h.dangerouslySetInnerHTML),k(i,t.attributes,h),U=s,i}function g(e,t,n,o,r){var i,a,l,c,h,p=e.childNodes,d=[],f={},v=0,g=0,y=p.length,k=0,b=t?t.length:0;if(0!==y)for(L=0;L2?[].slice.call(arguments,2):e.children)},Component:N,render:function(e,t,n){return v(n,e,{},!1,t,!1)},rerender:i,options:I};void 0!==t?t.exports=F:self.preact=F}()},{}]},{},[1]); +//# sourceMappingURL=quick-jump.min.js.map diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -39,7 +39,8 @@ DocH(..), Example(..), Hyperlink(..), - DocMarkup(..), + DocMarkup, + DocMarkupH(..), Documentation(..), ArgMap, AliasMap, @@ -69,12 +70,11 @@ withGhc ) where - +import Documentation.Haddock.Markup (markup) import Haddock.InterfaceFile import Haddock.Interface import Haddock.Types import Haddock.Options -import Haddock.Utils import Haddock diff --git a/src/Haddock.hs b/src/Haddock.hs --- a/src/Haddock.hs +++ b/src/Haddock.hs @@ -27,11 +27,13 @@ import Data.Version import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker import Haddock.Interface +import Haddock.Interface.Json import Haddock.Parser import Haddock.Types import Haddock.Version @@ -41,7 +43,8 @@ import Control.Monad hiding (forM_) import Control.Applicative -import Data.Foldable (forM_) +import Data.Foldable (forM_, foldl') +import Data.Traversable (for) import Data.List (isPrefixOf) import Control.Exception import Data.Maybe @@ -65,9 +68,11 @@ import System.Directory (doesDirectoryExist) #endif +import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) +import ErrUtils import Packages import Panic (handleGhcException) import Module @@ -161,9 +166,13 @@ hPutStrLn stderr warning ghc flags' $ do - dflags <- getDynFlags + forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + forM_ mIfaceFile $ \(_, ifaceFile) -> do + putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files @@ -268,7 +277,7 @@ | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat | otherwise = srcModule - srcMap = mkSrcMap $ Map.union + srcMap = Map.union (Map.map SrcExternal extSrcMap) (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ]) @@ -288,30 +297,52 @@ sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') + installedMap :: Map Module InstalledInterface + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ] + + -- The user gives use base-4.9.0.0, but the InstalledInterface + -- records the *wired in* identity base. So untranslate it + -- so that we can service the request. + unwire :: Module -> Module + unwire m = m { moduleUnitId = unwireUnitId dflags (moduleUnitId m) } + + reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do + let warn = hPutStrLn stderr . ("Warning: " ++) + case readP_to_S parseModuleId mod_str of + [(m, "")] + | Just iface <- Map.lookup m installedMap + -> return [iface] + | otherwise + -> warn ("Cannot find reexported module '" ++ mod_str ++ "'") >> return [] + _ -> warn ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return []) + libDir <- getHaddockLibDir flags prologue <- getPrologue dflags' flags themes <- getThemes libDir flags >>= either bye return + let withQuickjump = Flag_QuickJumpIndex `elem` flags + when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces pretty - copyHtmlBits odir libDir themes + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do ppHtmlContents dflags' odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty (makeContentsQual qual) - copyHtmlBits odir libDir themes + copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - ppHtml dflags' title pkgStr visibleIfaces odir + ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes + pretty withQuickjump + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them @@ -397,23 +428,50 @@ ghcMode = CompManager, ghcLink = NoLink } - let dynflags'' = updOptLevel 0 $ gopt_unset dynflags' Opt_SplitObjs - + -- We disable pattern match warnings because than can be very + -- expensive to check + let dynflags'' = unsetPatternMatchWarnings $ + updOptLevel 0 $ + gopt_unset dynflags' Opt_SplitObjs -- ignore the following return-value, which is a list of packages -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' ghcActs dynflags'' where + + -- ignore sublists of flags that start with "+RTS" and end in "-RTS" + -- + -- See https://github.com/haskell/haddock/issues/666 + filterRtsFlags :: [String] -> [String] + filterRtsFlags flgs = foldr go (const []) flgs True + where go "-RTS" func _ = func True + go "+RTS" func _ = func False + go _ func False = func False + go arg func True = arg : func True + + parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags parseGhcFlags dynflags = do -- TODO: handle warnings? - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags) + let flags' = filterRtsFlags flags + (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ unwords flags) + then throwE ("Couldn't parse GHC options: " ++ unwords flags') else return dynflags' +unsetPatternMatchWarnings :: DynFlags -> DynFlags +unsetPatternMatchWarnings dflags = + foldl' wopt_unset dflags pattern_match_warnings + where + pattern_match_warnings = + [ Opt_WarnIncompletePatterns + , Opt_WarnIncompleteUniPatterns + , Opt_WarnIncompletePatternsRecUpd + , Opt_WarnOverlappingPatterns + ] + ------------------------------------------------------------------------------- -- * Misc ------------------------------------------------------------------------------- @@ -438,9 +496,9 @@ exists <- doesDirectoryExist p pure $ if exists then Just p else Nothing - dirs <- mapM check res_dirs + dirs <- mapM check res_dirs case [p | Just p <- dirs] of - (p : _) -> return p + (p : _) -> return p _ -> die "Haddock's resource directory does not exist!\n" #endif fs -> return (last fs) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -18,6 +18,7 @@ import BasicTypes (OverlapFlag(..), OverlapMode(..), SourceText(..)) import InstEnv (ClsInst(..)) +import Documentation.Haddock.Markup import Haddock.GhcUtils import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) @@ -86,7 +87,7 @@ f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (OutputableBndrId a) +outHsType :: (SourceTextX a, OutputableBndrId a) => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy @@ -117,7 +118,7 @@ --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport :: DynFlags -> ExportItem GhcRn -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs @@ -135,29 +136,29 @@ ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] -ppSigWithDoc :: DynFlags -> Sig Name -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) - ++ [pp_sig dflags names (hsSigWcType sig)] + ++ [pp_sig dflags [n] (hsSigWcType sig)] getDoc :: Located Name -> [Documentation Name] getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs) ppSigWithDoc _ _ _ = [] -ppSig :: DynFlags -> Sig Name -> [String] +ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType Name -> String +pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String pp_sig dflags names (L _ typ) = operator prettyNames ++ " :: " ++ outHsType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[], tcdATs=[], tcdATDefs=[], tcdMeths=emptyLHsBinds} ++ ppTyFams) : ppMethods @@ -177,17 +178,17 @@ whereWrapper elems = vcat' [ text "where" <+> lbrace - , nest 4 . vcat . map (<> semi) $ elems + , nest 4 . vcat . map (Outputable.<> semi) $ elems , rbrace ] - tyFamEqnToSyn :: TyFamDefltEqn Name -> TyClDecl Name + tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn tyFamEqnToSyn tfe = SynDecl - { tcdLName = tfe_tycon tfe - , tcdTyVars = tfe_pats tfe - , tcdFixity = tfe_fixity tfe - , tcdRhs = tfe_rhs tfe - , tcdFVs = emptyNameSet + { tcdLName = feqn_tycon tfe + , tcdTyVars = feqn_pats tfe + , tcdFixity = feqn_fixity tfe + , tcdRhs = feqn_rhs tfe + , tcdFVs = emptyNameSet } @@ -203,10 +204,10 @@ cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } -ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) @@ -227,7 +228,7 @@ Just (d, _) -> ppDocumentation dflags d _ -> [] -ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) @@ -261,7 +262,7 @@ ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags (FixitySig [noLoc name] fixity)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- @@ -327,7 +328,8 @@ markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, - markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h, + markupTable = \(Table _ _) -> str "TODO: table" } diff --git a/src/Haddock/Backends/Hyperlinker/Ast.hs b/src/Haddock/Backends/Hyperlinker/Ast.hs --- a/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -11,11 +12,16 @@ import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified SrcLoc import Control.Applicative +import Control.Monad (guard) import Data.Data +import qualified Data.Map.Strict as Map import Data.Maybe +import Prelude hiding (span) + everythingInRenamedSource :: (Alternative f, Data x) => (forall a. Data a => a -> f r) -> x -> f r everythingInRenamedSource f = Syb.everythingButType @GHC.Name (<|>) f @@ -28,25 +34,39 @@ , rtkDetails = enrichToken token detailsMap } where - detailsMap = concatMap ($ src) - [ variables - , types - , decls - , binds - , imports - ] + detailsMap = + mkDetailsMap (concatMap ($ src) + [ variables + , types + , decls + , binds + , imports + ]) +type LTokenDetails = [(GHC.SrcSpan, TokenDetails)] + -- | A map containing association between source locations and "details" of -- this location. -- --- For the time being, it is just a list of pairs. However, looking up things --- in such structure has linear complexity. We cannot use any hashmap-like --- stuff because source locations are not ordered. In the future, this should --- be replaced with interval tree data structure. -type DetailsMap = [(GHC.SrcSpan, TokenDetails)] +type DetailsMap = Map.Map Position (Span, TokenDetails) +mkDetailsMap :: [(GHC.SrcSpan, TokenDetails)] -> DetailsMap +mkDetailsMap xs = + Map.fromListWith select_details [ (start, (span, token_details)) + | (ghc_span, token_details) <- xs + , GHC.RealSrcSpan span <- [ghc_span] + , let start = SrcLoc.realSrcSpanStart span + ] + where + -- favour token details which appear earlier in the list + select_details _new old = old + lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails -lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst) +lookupBySpan span details = do + let pos = SrcLoc.realSrcSpanStart span + (_, (tok_span, tok_details)) <- Map.lookupLE pos details + guard (tok_span `SrcLoc.containsSpan` span) + return tok_details enrichToken :: Token -> DetailsMap -> Maybe TokenDetails enrichToken (Token typ _ spn) dm @@ -54,28 +74,31 @@ enrichToken _ _ = Nothing -- | Obtain details map for variables ("normally" used identifiers). -variables :: GHC.RenamedSource -> DetailsMap +variables :: GHC.RenamedSource -> LTokenDetails variables = everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of - (Just (GHC.L sspan (GHC.HsVar name))) -> + (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of - Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) -> + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) -> pure (sspan, RtkVar name) _ -> empty -- | Obtain details map for types. -types :: GHC.RenamedSource -> DetailsMap +types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty where + ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] ty term = case cast term of - (Just (GHC.L sspan (GHC.HsTyVar _ name))) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) + (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) -> + (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) _ -> empty -- | Obtain details map for identifier bindings. @@ -84,16 +107,21 @@ -- ordinary assignment (in top-level declarations, let-expressions and where -- clauses). -binds :: GHC.RenamedSource -> DetailsMap +binds :: GHC.RenamedSource -> LTokenDetails binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) -> + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) -> + pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args _ -> empty + patsyn_binds term = case cast term of + (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) + _ -> empty pat term = case cast term of - (Just (GHC.L sspan (GHC.VarPat name))) -> + (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs @@ -101,21 +129,22 @@ pure (sspan, RtkBind name) _ -> empty rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) -> + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) -> pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just (GHC.L sspan (GHC.UserTyVar name))) -> + (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty -- | Obtain details map for top-level declarations. -decls :: GHC.RenamedSource -> DetailsMap +decls :: GHC.RenamedSource -> LTokenDetails decls (group, _, _, _) = concatMap ($ group) [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds , everythingInRenamedSource fun . GHC.hs_valds + , everythingInRenamedSource fix . GHC.hs_fixds , everythingInRenamedSource (con `Syb.combine` ins) ] where @@ -123,26 +152,40 @@ GHC.DataDecl { tcdLName = name } -> pure . decl $ name GHC.SynDecl name _ _ _ _ -> pure . decl $ name GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam - GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs + GHC.ClassDecl{..} -> + [decl tcdLName] + ++ concatMap sig tcdSigs + ++ concatMap tyfam tcdATs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) + (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) + | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of - (Just cdcl) -> + (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> map decl (GHC.getConNames cdcl) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> - pure . tyref $ GHC.tfe_tycon eqn + (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + :: GHC.InstDecl GHC.GhcRn)) + -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn + (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.Name) + Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty + fix term = case cast term of + Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn) + -> map decl names + Nothing -> empty + tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names + sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -151,39 +194,21 @@ -- -- This map also includes type and variable details for items in export and -- import lists. -imports :: GHC.RenamedSource -> DetailsMap +imports :: GHC.RenamedSource -> LTokenDetails imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just (GHC.IEVar v)) -> pure $ var $ GHC.ieLWrappedName v + (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs + (Just (GHC.IEModuleContents m)) -> pure $ modu m _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) - imp idecl | not . GHC.ideclImplicit $ idecl = - let (GHC.L sspan name) = GHC.ideclName idecl - in Just (sspan, RtkModule name) - imp _ = Nothing - --- | Check whether token stream span matches GHC source span. --- --- Currently, it is implemented as checking whether "our" span is contained --- in GHC span. The reason for that is because GHC span are generally wider --- and may spread across couple tokens. For example, @(>>=)@ consists of three --- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable --- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@ --- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span --- associated with @quux@ contains all five elements. -matches :: Span -> GHC.SrcSpan -> Bool -matches tspan (GHC.RealSrcSpan aspan) - | saspan <= stspan && etspan <= easpan = True - where - stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan) - etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan) - saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan) - easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan) -matches _ _ = False + modu (GHC.L sspan name) = (sspan, RtkModule name) + imp idecl + | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl)) + | otherwise = Nothing diff --git a/src/Haddock/Backends/Hyperlinker/Parser.hs b/src/Haddock/Backends/Hyperlinker/Parser.hs --- a/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,11 +1,17 @@ module Haddock.Backends.Hyperlinker.Parser (parse) where +import Data.Either ( isRight, isLeft ) +import Data.List ( foldl', isPrefixOf, isSuffixOf ) +import Data.Maybe ( maybeToList ) -import Data.Char -import Data.List -import Data.Maybe +import GHC ( DynFlags, addSourceToTokens ) +import SrcLoc +import FastString ( mkFastString ) +import StringBuffer ( stringToStringBuffer ) +import Lexer ( Token(..) ) +import qualified Lexer as L -import Haddock.Backends.Hyperlinker.Types +import Haddock.Backends.Hyperlinker.Types as T -- | Turn source code string into a stream of more descriptive tokens. @@ -13,202 +19,404 @@ -- Result should retain original file layout (including comments, whitespace, -- etc.), i.e. the following "law" should hold: -- --- @concat . map 'tkValue' . 'parse' = id@ -parse :: String -> [Token] -parse = tokenize . tag . chunk +-- prop> concat . map tkValue . parse = id +-- +-- (In reality, this only holds for input not containing '\r', '\t', '\f', '\v', +-- characters, since GHC transforms those into ' ' and '\n') +parse :: DynFlags -> FilePath -> String -> [T.Token] +parse dflags fp s = ghcToks (processCPP dflags fp s) --- | Split raw source string to more meaningful chunks. + +-- | Parse the source into tokens using the GHC lexer. -- --- This is the initial stage of tokenization process. Each chunk is either --- a comment (including comment delimiters), a whitespace string, preprocessor --- macro (and all its content until the end of a line) or valid Haskell lexeme. -chunk :: String -> [String] -chunk [] = [] -chunk str@(c:_) - | isSpace c = - let (space, mcpp, rest) = spanSpaceOrCpp str - in [space] ++ maybeToList mcpp ++ chunk rest -chunk str - | "--" `isPrefixOf` str = chunk' $ spanToNewline str - | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str - | otherwise = case lex' str of - (tok:_) -> chunk' tok - [] -> [str] +-- * CPP lines are removed and reinserted as line-comments +-- * top-level file pragmas are parsed as block comments (see the +-- 'ITblockComment' case of 'classify' for more details) +-- +processCPP :: DynFlags -- ^ GHC's flags + -> FilePath -- ^ source file name (for position information) + -> String -- ^ source file contents + -> [(Located L.Token, String)] +processCPP dflags fpath s = addSrc . go start . splitCPP $ s where - chunk' (c, rest) = c:(chunk rest) + start = mkRealSrcLoc (mkFastString fpath) 1 1 + addSrc = addSourceToTokens start (stringToStringBuffer s) --- | A bit better lexer then the default, i.e. handles DataKinds quotes -lex' :: ReadS String -lex' ('\'' : '\'' : rest) = [("''", rest)] -lex' str@('\'' : '\\' : _ : '\'' : _) = lex str -lex' str@('\'' : _ : '\'' : _) = lex str -lex' ('\'' : rest) = [("'", rest)] -lex' str = lex str + -- Transform a list of Haskell/CPP lines into a list of tokens + go :: RealSrcLoc -> [Either String String] -> [Located L.Token] + go _ [] = [] + go pos ls = + let (hLinesRight, ls') = span isRight ls + (cppLinesLeft, rest) = span isLeft ls' --- | Split input to "first line" string and the rest of it. + hSrc = concat [ hLine | Right hLine <- hLinesRight ] + cppSrc = concat [ cppLine | Left cppLine <- cppLinesLeft ] + + in case L.lexTokenStream (stringToStringBuffer hSrc) pos dflags of + + -- Stuff that fails to lex gets turned into comments + L.PFailed _ _ss _msg -> + let (src_pos, failed) = mkToken ITunknown pos hSrc + (new_pos, cpp) = mkToken ITlineComment src_pos cppSrc + in failed : cpp : go new_pos rest + + -- Successfully lexed + L.POk ss toks -> + let (new_pos, cpp) = mkToken ITlineComment (L.loc ss) cppSrc + in toks ++ [cpp] ++ go new_pos rest + + -- Manually make a token from a 'String', advancing the cursor position + mkToken tok start' str = + let end = foldl' advanceSrcLoc start' str + in (end, L (RealSrcSpan $ mkRealSrcSpan start' end) (tok str)) + + +-- | Split apart the initial file into Haskell source lines ('Left' entries) and +-- CPP lines ('Right' entries). -- --- Ideally, this should be done simply with @'break' (== '\n')@. However, --- Haskell also allows line-unbreaking (or whatever it is called) so things --- are not as simple and this function deals with that. -spanToNewline :: String -> (String, String) -spanToNewline [] = ([], []) -spanToNewline ('\\':'\n':str) = - let (str', rest) = spanToNewline str - in ('\\':'\n':str', rest) -spanToNewline str@('\n':_) = ("", str) -spanToNewline (c:str) = - let (str', rest) = spanToNewline str - in (c:str', rest) +-- All characters in the input are present in the output: +-- +-- prop> concat . map (either id id) . splitCPP = id +splitCPP :: String -> [Either String String] +splitCPP "" = [] +splitCPP s | isCPPline s = Left l : splitCPP rest + | otherwise = Right l : splitCPP rest + where + ~(l, rest) = spanToNewline 0 s --- | Split input to whitespace string, (optional) preprocessor directive and --- the rest of it. + +-- | Heuristic to decide if a line is going to be a CPP line. This should be a +-- cheap operation since it is going to be run on every line being processed. -- --- Again, using something like @'span' 'isSpace'@ would be nice to chunk input --- to whitespace. The problem is with /#/ symbol - if it is placed at the very --- beginning of a line, it should be recognized as preprocessor macro. In any --- other case, it is ordinary Haskell symbol and can be used to declare --- operators. Hence, while dealing with whitespace we also check whether there --- happens to be /#/ symbol just after a newline character - if that is the --- case, we begin treating the whole line as preprocessor macro. -spanSpaceOrCpp :: String -> (String, Maybe String, String) -spanSpaceOrCpp ('\n':'#':str) = - let (str', rest) = spanToNewline str - in ("\n", Just $ '#':str', rest) -spanSpaceOrCpp (c:str') - | isSpace c = - let (space, mcpp, rest) = spanSpaceOrCpp str' - in (c:space, mcpp, rest) -spanSpaceOrCpp str = ("", Nothing, str) +-- Right now it just checks if the first non-whitespace character in the first +-- five characters of the line is a '#': +-- +-- >>> isCPPline "#define FOO 1" +-- True +-- +-- >>> isCPPline "\t\t #ifdef GHC" +-- True +-- +-- >>> isCPPline " #endif" +-- False +-- +isCPPline :: String -> Bool +isCPPline = isPrefixOf "#" . dropWhile (`elem` " \t") . take 5 --- | Split input to comment content (including delimiters) and the rest. + +-- | Split a "line" off the front of a string, supporting newline escapes. -- --- Again, some more logic than simple 'span' is required because of Haskell --- comment nesting policy. -chunkComment :: Int -> String -> (String, String) -chunkComment _ [] = ("", "") -chunkComment depth ('{':'-':str) = - let (c, rest) = chunkComment (depth + 1) str - in ("{-" ++ c, rest) -chunkComment depth ('-':'}':str) - | depth == 1 = ("-}", str) - | otherwise = - let (c, rest) = chunkComment (depth - 1) str - in ("-}" ++ c, rest) -chunkComment depth (e:str) = - let (c, rest) = chunkComment depth str - in (e:c, rest) +-- By "line", we understand: the shortest substring ending in a '\n' that is not +-- +-- 1. immediately preceded by a '\\' +-- 2. not inside some (possibly nested) block comment +-- +-- All characters in the input are present in the output: +-- +-- prop> curry (++) . spanToNewLine 0 = id +spanToNewline :: Int -- ^ open '{-' + -> String -- ^ input + -> (String, String) +spanToNewline _ [] = ([], []) +spanToNewline n ('\n':str) | n <= 0 = ("\n", str) +spanToNewline n ('\\':'\n':str) = + let (str', rest) = spanToNewline n str + in ('\\':'\n':str', rest) +spanToNewline n ('{':'-':str) = + let (str', rest) = spanToNewline (n+1) str + in ('{':'-':str', rest) +spanToNewline n ('-':'}':str) = + let (str', rest) = spanToNewline (n-1) str + in ('-':'}':str', rest) +spanToNewline n (c:str) = + let (str', rest) = spanToNewline n str + in (c:str', rest) --- | Assign source location for each chunk in given stream. -tag :: [String] -> [(Span, String)] -tag = - reverse . snd . foldl aux (Position 1 1, []) - where - aux (pos, cs) str = - let pos' = foldl move pos str - in (pos', (Span pos pos', str):cs) - move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 } - move pos _ = pos { posCol = posCol pos + 1 } --- | Turn unrecognised chunk stream to more descriptive token stream. -tokenize :: [(Span, String)] -> [Token] -tokenize = - map aux +-- | Turn a list of GHC's 'L.Token' (and their source 'String') into a list of +-- Haddock's 'T.Token'. +ghcToks :: [(Located L.Token, String)] -> [T.Token] +ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) where - aux (sp, str) = Token - { tkType = classify str - , tkValue = str - , tkSpan = sp - } + start = mkRealSrcLoc (mkFastString "lexing") 1 1 --- | Classify given string as appropriate Haskell token. --- --- This method is based on Haskell 98 Report lexical structure description: --- https://www.haskell.org/onlinereport/lexemes.html --- --- However, this is probably far from being perfect and most probably does not --- handle correctly all corner cases. -classify :: String -> TokenType -classify str - | "--" `isPrefixOf` str = TkComment - | "{-#" `isPrefixOf` str = TkPragma - | "{-" `isPrefixOf` str = TkComment -classify "''" = TkSpecial -classify "'" = TkSpecial -classify str@(c:_) - | isSpace c = TkSpace - | isDigit c = TkNumber - | c `elem` special = TkSpecial - | str `elem` glyphs = TkGlyph - | all (`elem` symbols) str = TkOperator - | c == '#' = TkCpp - | c == '"' = TkString - | c == '\'' = TkChar -classify str - | str `elem` keywords = TkKeyword - | isIdentifier str = TkIdentifier - | otherwise = TkUnknown + go :: (RealSrcLoc, [T.Token], Bool) + -- ^ current position, tokens accumulated, currently in pragma (or not) + + -> (Located L.Token, String) + -- ^ next token, its content + + -> (RealSrcLoc, [T.Token], Bool) + -- ^ new position, new tokens accumulated, currently in pragma (or not) -keywords :: [String] -keywords = - [ "as" - , "case" - , "class" - , "data" - , "default" - , "deriving" - , "do" - , "else" - , "hiding" - , "if" - , "import" - , "in" - , "infix" - , "infixl" - , "infixr" - , "instance" - , "let" - , "module" - , "newtype" - , "of" - , "qualified" - , "then" - , "type" - , "where" - , "forall" - , "family" - , "mdo" - ] + go (pos, toks, in_prag) (L l tok, raw) = + ( next_pos + , classifiedTok ++ maybeToList white ++ toks + , inPragma in_prag tok + ) + where + (next_pos, white) = mkWhitespace pos l + + classifiedTok = [ Token (classify' tok) raw rss + | RealSrcSpan rss <- [l] + , not (null raw) + ] + + classify' | in_prag = const TkPragma + | otherwise = classify -glyphs :: [String] -glyphs = - [ ".." - , ":" - , "::" - , "=" - , "\\" - , "|" - , "<-" - , "->" - , "@" - , "~" - , "~#" - , "=>" - , "-" - , "!" - ] -special :: [Char] -special = "()[]{},;`" +-- | Find the correct amount of whitespace between tokens. +mkWhitespace :: RealSrcLoc -> SrcSpan -> (RealSrcLoc, Maybe T.Token) +mkWhitespace prev spn = + case spn of + UnhelpfulSpan _ -> (prev,Nothing) + RealSrcSpan s | null wsstring -> (end, Nothing) + | otherwise -> (end, Just (Token TkSpace wsstring wsspan)) + where + start = realSrcSpanStart s + end = realSrcSpanEnd s + wsspan = mkRealSrcSpan prev start + nls = srcLocLine start - srcLocLine prev + spaces = if nls == 0 then srcLocCol start - srcLocCol prev + else srcLocCol start - 1 + wsstring = replicate nls '\n' ++ replicate spaces ' ' --- TODO: Add support for any Unicode symbol or punctuation. --- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators -symbols :: [Char] -symbols = "!#$%&*+./<=>?@\\^|-~:" -isIdentifier :: String -> Bool -isIdentifier (s:str) - | (isLower' s || isUpper s) && all isAlphaNum' str = True - where - isLower' c = isLower c || c == '_' - isAlphaNum' c = isAlphaNum c || c == '_' || c == '\'' -isIdentifier _ = False +-- | Classify given tokens as appropriate Haskell token type. +classify :: L.Token -> TokenType +classify tok = + case tok of + ITas -> TkKeyword + ITcase -> TkKeyword + ITclass -> TkKeyword + ITdata -> TkKeyword + ITdefault -> TkKeyword + ITderiving -> TkKeyword + ITdo -> TkKeyword + ITelse -> TkKeyword + IThiding -> TkKeyword + ITforeign -> TkKeyword + ITif -> TkKeyword + ITimport -> TkKeyword + ITin -> TkKeyword + ITinfix -> TkKeyword + ITinfixl -> TkKeyword + ITinfixr -> TkKeyword + ITinstance -> TkKeyword + ITlet -> TkKeyword + ITmodule -> TkKeyword + ITnewtype -> TkKeyword + ITof -> TkKeyword + ITqualified -> TkKeyword + ITthen -> TkKeyword + ITtype -> TkKeyword + ITwhere -> TkKeyword + + ITforall {} -> TkKeyword + ITexport -> TkKeyword + ITlabel -> TkKeyword + ITdynamic -> TkKeyword + ITsafe -> TkKeyword + ITinterruptible -> TkKeyword + ITunsafe -> TkKeyword + ITstdcallconv -> TkKeyword + ITccallconv -> TkKeyword + ITcapiconv -> TkKeyword + ITprimcallconv -> TkKeyword + ITjavascriptcallconv -> TkKeyword + ITmdo -> TkKeyword + ITfamily -> TkKeyword + ITrole -> TkKeyword + ITgroup -> TkKeyword + ITby -> TkKeyword + ITusing -> TkKeyword + ITpattern -> TkKeyword + ITstatic -> TkKeyword + ITstock -> TkKeyword + ITanyclass -> TkKeyword + + ITunit -> TkKeyword + ITsignature -> TkKeyword + ITdependency -> TkKeyword + ITrequires -> TkKeyword + + ITinline_prag {} -> TkPragma + ITspec_prag {} -> TkPragma + ITspec_inline_prag {} -> TkPragma + ITsource_prag {} -> TkPragma + ITrules_prag {} -> TkPragma + ITwarning_prag {} -> TkPragma + ITdeprecated_prag {} -> TkPragma + ITline_prag {} -> TkPragma + ITcolumn_prag {} -> TkPragma + ITscc_prag {} -> TkPragma + ITgenerated_prag {} -> TkPragma + ITcore_prag {} -> TkPragma + ITunpack_prag {} -> TkPragma + ITnounpack_prag {} -> TkPragma + ITann_prag {} -> TkPragma + ITcomplete_prag {} -> TkPragma + ITclose_prag -> TkPragma + IToptions_prag {} -> TkPragma + ITinclude_prag {} -> TkPragma + ITlanguage_prag -> TkPragma + ITvect_prag {} -> TkPragma + ITvect_scalar_prag {} -> TkPragma + ITnovect_prag {} -> TkPragma + ITminimal_prag {} -> TkPragma + IToverlappable_prag {} -> TkPragma + IToverlapping_prag {} -> TkPragma + IToverlaps_prag {} -> TkPragma + ITincoherent_prag {} -> TkPragma + ITctype {} -> TkPragma + + ITdotdot -> TkGlyph + ITcolon -> TkGlyph + ITdcolon {} -> TkGlyph + ITequal -> TkGlyph + ITlam -> TkGlyph + ITlcase -> TkGlyph + ITvbar -> TkGlyph + ITlarrow {} -> TkGlyph + ITrarrow {} -> TkGlyph + ITat -> TkGlyph + ITtilde -> TkGlyph + ITtildehsh -> TkGlyph + ITdarrow {} -> TkGlyph + ITminus -> TkGlyph + ITbang -> TkGlyph + ITdot -> TkOperator + ITtypeApp -> TkGlyph + + ITbiglam -> TkGlyph + + ITocurly -> TkSpecial + ITccurly -> TkSpecial + ITvocurly -> TkSpecial + ITvccurly -> TkSpecial + ITobrack -> TkSpecial + ITopabrack -> TkSpecial + ITcpabrack -> TkSpecial + ITcbrack -> TkSpecial + IToparen -> TkSpecial + ITcparen -> TkSpecial + IToubxparen -> TkSpecial + ITcubxparen -> TkSpecial + ITsemi -> TkSpecial + ITcomma -> TkSpecial + ITunderscore -> TkIdentifier + ITbackquote -> TkSpecial + ITsimpleQuote -> TkSpecial + + ITvarid {} -> TkIdentifier + ITconid {} -> TkIdentifier + ITvarsym {} -> TkOperator + ITconsym {} -> TkOperator + ITqvarid {} -> TkIdentifier + ITqconid {} -> TkIdentifier + ITqvarsym {} -> TkOperator + ITqconsym {} -> TkOperator + + ITdupipvarid {} -> TkUnknown + ITlabelvarid {} -> TkUnknown + + ITchar {} -> TkChar + ITstring {} -> TkString + ITinteger {} -> TkNumber + ITrational {} -> TkNumber + + ITprimchar {} -> TkChar + ITprimstring {} -> TkString + ITprimint {} -> TkNumber + ITprimword {} -> TkNumber + ITprimfloat {} -> TkNumber + ITprimdouble {} -> TkNumber + + ITopenExpQuote {} -> TkSpecial + ITopenPatQuote -> TkSpecial + ITopenDecQuote -> TkSpecial + ITopenTypQuote -> TkSpecial + ITcloseQuote {} -> TkSpecial + ITopenTExpQuote {} -> TkSpecial + ITcloseTExpQuote -> TkSpecial + ITidEscape {} -> TkUnknown + ITparenEscape -> TkSpecial + ITidTyEscape {} -> TkUnknown + ITparenTyEscape -> TkSpecial + ITtyQuote -> TkSpecial + ITquasiQuote {} -> TkUnknown + ITqQuasiQuote {} -> TkUnknown + + ITproc -> TkKeyword + ITrec -> TkKeyword + IToparenbar {} -> TkGlyph + ITcparenbar {} -> TkGlyph + ITlarrowtail {} -> TkGlyph + ITrarrowtail {} -> TkGlyph + ITLarrowtail {} -> TkGlyph + ITRarrowtail {} -> TkGlyph + + ITunknown {} -> TkUnknown + ITeof -> TkUnknown + + -- Line comments are only supposed to start with '--'. Starting with '#' + -- means that this was probably a CPP. + ITlineComment s + | isCPPline s -> TkCpp + | otherwise -> TkComment + + ITdocCommentNext {} -> TkComment + ITdocCommentPrev {} -> TkComment + ITdocCommentNamed {} -> TkComment + ITdocSection {} -> TkComment + ITdocOptions {} -> TkComment + + -- The lexer considers top-level pragmas as comments (see `pragState` in + -- the GHC lexer for more), so we have to manually reverse this. The + -- following is a hammer: it smashes _all_ pragma-like block comments into + -- pragmas. + ITblockComment c + | isPrefixOf "{-#" c + , isSuffixOf "#-}" c -> TkPragma + | otherwise -> TkComment + +-- | Classify given tokens as beginning pragmas (or not). +inPragma :: Bool -- ^ currently in pragma + -> L.Token -- ^ current token + -> Bool -- ^ new information about whether we are in a pragma +inPragma _ ITclose_prag = False +inPragma True _ = True +inPragma False tok = + case tok of + ITinline_prag {} -> True + ITspec_prag {} -> True + ITspec_inline_prag {} -> True + ITsource_prag {} -> True + ITrules_prag {} -> True + ITwarning_prag {} -> True + ITdeprecated_prag {} -> True + ITline_prag {} -> True + ITcolumn_prag {} -> True + ITscc_prag {} -> True + ITgenerated_prag {} -> True + ITcore_prag {} -> True + ITunpack_prag {} -> True + ITnounpack_prag {} -> True + ITann_prag {} -> True + ITcomplete_prag {} -> True + IToptions_prag {} -> True + ITinclude_prag {} -> True + ITlanguage_prag -> True + ITvect_prag {} -> True + ITvect_scalar_prag {} -> True + ITnovect_prag {} -> True + ITminimal_prag {} -> True + IToverlappable_prag {} -> True + IToverlapping_prag {} -> True + IToverlaps_prag {} -> True + ITincoherent_prag {} -> True + ITctype {} -> True + + _ -> False + diff --git a/src/Haddock/Backends/Hyperlinker/Renderer.hs b/src/Haddock/Backends/Hyperlinker/Renderer.hs --- a/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -15,7 +15,6 @@ import Data.List import Data.Maybe -import Data.Monoid import qualified Data.Map as Map import Text.XHtml (Html, HtmlAttr, (!)) @@ -82,7 +81,7 @@ tokenGroup :: SrcMap -> TokenGroup -> Html tokenGroup _ (GrpNormal tok@(Token { .. })) - | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue + | tkType == TkSpace = renderSpace (GHC.srcSpanStartLine tkSpan) tkValue | otherwise = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle $ tkType ] @@ -155,7 +154,7 @@ Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html -externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of +externalNameHyperlink srcs name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ] Just (SrcExternal path) -> Html.anchor content ! @@ -165,12 +164,14 @@ mdl = GHC.nameModule name externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html -externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of - Just SrcLocal -> Html.anchor content ! +externalModHyperlink srcs name content = + let srcs' = Map.mapKeys GHC.moduleName srcs in + case Map.lookup name srcs' of + Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleUrl' name ] - Just (SrcExternal path) -> Html.anchor content ! + Just (SrcExternal path) -> Html.anchor content ! [ Html.href $ path hypSrcModuleUrl' name ] - Nothing -> content + Nothing -> content renderSpace :: Int -> String -> Html diff --git a/src/Haddock/Backends/Hyperlinker/Types.hs b/src/Haddock/Backends/Hyperlinker/Types.hs --- a/src/Haddock/Backends/Hyperlinker/Types.hs +++ b/src/Haddock/Backends/Hyperlinker/Types.hs @@ -4,27 +4,16 @@ import qualified GHC import Data.Map (Map) -import qualified Data.Map as Map - data Token = Token { tkType :: TokenType , tkValue :: String - , tkSpan :: Span - } - deriving (Show) - -data Position = Position - { posRow :: !Int - , posCol :: !Int + , tkSpan :: {-# UNPACK #-} !Span } deriving (Show) -data Span = Span - { spStart :: Position - , spEnd :: Position - } - deriving (Show) +type Position = GHC.RealSrcLoc +type Span = GHC.RealSrcSpan data TokenType = TkIdentifier @@ -74,15 +63,5 @@ | SrcLocal -- | Mapping from modules to cross-package source paths. --- --- This mapping is actually a pair of maps instead of just one map. The reason --- for this is because when hyperlinking modules in import lists we have no --- 'GHC.Module' available. On the other hand, we can't just use map with --- 'GHC.ModuleName' as indices because certain modules may have common name --- but originate in different packages. Hence, we use both /rich/ and /poor/ --- versions, where the /poor/ is just projection of /rich/ one cached in pair --- for better performance. -type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath) +type SrcMap = Map GHC.Module SrcPath -mkSrcMap :: Map GHC.Module SrcPath -> SrcMap -mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs) diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -16,6 +16,7 @@ ) where +import Documentation.Haddock.Markup import Haddock.Types import Haddock.Utils import Haddock.GhcUtils @@ -36,6 +37,7 @@ import Control.Monad import Data.Maybe import Data.List +import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -178,7 +180,7 @@ string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 -exportListItem :: ExportItem DocName -> LaTeX +exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } = sep (punctuate comma . map ppDocBinder $ declNames decl) <> case subdocs of @@ -196,7 +198,7 @@ -- Deal with a group of undocumented exports together, to avoid lots -- of blank vertical space between them. -processExports :: [ExportItem DocName] -> LaTeX +processExports :: [ExportItem DocNameI] -> LaTeX processExports [] = empty processExports (decl : es) | Just sig <- isSimpleSig decl @@ -212,19 +214,19 @@ processExport e $$ processExports es -isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) +isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing -isExportModule :: ExportItem DocName -> Maybe Module +isExportModule :: ExportItem DocNameI -> Maybe Module isExportModule (ExportModule m) = Just m isExportModule _ = Nothing -processExport :: ExportItem DocName -> LaTeX +processExport :: ExportItem DocNameI -> LaTeX processExport (ExportGroup lev _id0 doc) = ppDocGroup lev (docToLaTeX doc) processExport (ExportDecl decl pats doc subdocs insts fixities _splice) @@ -247,7 +249,7 @@ sec _ = text "\\paragraph" -declNames :: LHsDecl DocName -> [DocName] +declNames :: LHsDecl DocNameI -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d] SigD (TypeSig lnames _ ) -> map unLoc lnames @@ -257,7 +259,7 @@ _ -> error "declaration not supported by declNames" -forSummary :: (ExportItem DocName) -> Bool +forSummary :: (ExportItem DocNameI) -> Bool forSummary (ExportGroup _ _ _) = False forSummary (ExportDoc _) = False forSummary _ = True @@ -277,10 +279,10 @@ ------------------------------------------------------------------------------- -ppDecl :: LHsDecl DocName - -> [(HsDecl DocName,DocForDecl DocName)] +ppDecl :: LHsDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] -> DocForDecl DocName - -> [DocInstance DocName] + -> [DocInstance DocNameI] -> [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] -> LaTeX @@ -308,12 +310,12 @@ ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> - TyClDecl DocName -> Bool -> LaTeX + TyClDecl DocNameI -> Bool -> LaTeX ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX +ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = ppFunSig loc doc [name] (hsSigType typ) unicode ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" @@ -326,7 +328,7 @@ -- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX +ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode @@ -345,7 +347,7 @@ ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> Bool -> LaTeX ppFunSig loc doc docnames (L _ typ) unicode = ppTypeOrFunSig loc docnames typ doc @@ -357,7 +359,7 @@ names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] - -> LHsSigType DocName + -> LHsSigType DocNameI -> Bool -> LaTeX ppLPatSig _loc (doc, _argDocs) docnames ty unicode = declWithDoc pref1 (documentationToLaTeX doc) @@ -368,7 +370,7 @@ , ppLType unicode (hsSigType ty) ] -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName +ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) @@ -386,7 +388,7 @@ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - do_args :: Int -> LaTeX -> HsType DocName -> LaTeX + do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX do_args _n leader (HsForAllTy tvs ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) @@ -402,18 +404,18 @@ = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl -ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX +ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) <+> dcolon unicode <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars :: [LHsTyVarBndr DocNameI] -> [LaTeX] ppTyVars = map (ppSymName . getName . hsLTyVarName) -tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit @@ -462,8 +464,8 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName + -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -481,9 +483,9 @@ hsep (map (ppDocName . unLoc) vars2) -ppClassDecl :: [DocInstance DocName] -> SrcSpan +ppClassDecl :: [DocInstance DocNameI] -> SrcSpan -> Documentation DocName -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> LaTeX + -> TyClDecl DocNameI -> Bool -> LaTeX ppClassDecl instances loc doc subdocs (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode @@ -506,19 +508,17 @@ methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + vcat [ ppFunSig loc doc [name] (hsSigWcType typ) unicode | L _ (TypeSig lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + ] instancesBit = ppDocInstances unicode instances ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX +ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty ppDocInstances unicode (i : rest) | Just ihead <- isUndocdInstance i @@ -536,22 +536,22 @@ -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. -ppDocInstance :: Bool -> DocInstance DocName -> LaTeX +ppDocInstance :: Bool -> DocInstance DocNameI -> LaTeX ppDocInstance unicode (instHead, doc, _) = declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) -ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl :: Bool -> InstHead DocNameI -> LaTeX ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead -ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead :: Bool -> InstHead DocNameI -> LaTeX ppInstHead unicode (InstHead {..}) = case ihdInstType of ClassInst ctx _ _ _ -> ppContextNoLocs ctx unicode <+> typ TypeInst rhs -> keyword "type" <+> typ <+> tibody rhs DataInst _ -> error "data instances not supported by --latex yet" where - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode + typ = ppAppNameTypes ihdClsName ihdTypes unicode tibody = maybe empty (\t -> equals <+> ppType unicode t) lookupAnySubdoc :: (Eq name1) => @@ -566,9 +566,9 @@ ------------------------------------------------------------------------------- -ppDataDecl :: [(HsDecl DocName,DocForDecl DocName)] -> [DocInstance DocName] -> +ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] -> [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> + Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool -> LaTeX ppDataDecl pats instances subdocs _loc doc dataDecl unicode @@ -614,7 +614,7 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Bool -> LaTeX ppConstrHdr forall tvs ctxt unicode = (if null tvs then empty else ppForall) <+> @@ -626,7 +626,7 @@ ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX + -> LConDecl DocNameI -> LaTeX ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = leader <-> case con_details con of @@ -755,7 +755,7 @@ mkFunTy a b = noLoc (HsFunTy a b) -} -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc @@ -813,7 +813,7 @@ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX +ppDataHeader :: TyClDecl DocNameI -> Bool -> LaTeX ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode = -- newtype or data @@ -829,27 +829,27 @@ -------------------------------------------------------------------------------- --- | Print an application of a DocName and two lists of HsTypes (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX -ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) +-- | Print an application of a DocName to its list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Bool -> LaTeX +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) -- | Print an application of a DocName and a list of Names ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX ppAppDocNameNames _summ n ns = - ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName + ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX -ppTypeApp n [] (t1:t2:rest) ppDN ppT +ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX +ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN n <+> ppT t2 -ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) +ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- @@ -857,29 +857,29 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX +ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX +ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode -ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX +ppContextNoArrow :: HsContext DocNameI -> Bool -> LaTeX ppContextNoArrow cxt unicode = fromMaybe empty $ ppContextNoLocsMaybe (map unLoc cxt) unicode -ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX +ppContextNoLocs :: [HsType DocNameI] -> Bool -> LaTeX ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $ ppContextNoLocsMaybe cxt unicode -ppContext :: HsContext DocName -> Bool -> LaTeX +ppContext :: HsContext DocNameI -> Bool -> LaTeX ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode -pp_hs_context :: [HsType DocName] -> Bool -> LaTeX +pp_hs_context :: [HsType DocNameI] -> Bool -> LaTeX pp_hs_context [] _ = empty pp_hs_context [p] unicode = ppType unicode p pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) @@ -929,32 +929,32 @@ | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode -ppLKind :: Bool -> LHsKind DocName -> LaTeX +ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) -ppKind :: Bool -> HsKind DocName -> LaTeX +ppKind :: Bool -> HsKind DocNameI -> LaTeX ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX +ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode -ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX +ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot @@ -1017,7 +1017,7 @@ -- XXX: Do something with Unicode parameter? -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX +ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX ppr_fun_ty ctxt_prec ty1 ty2 unicode = let p1 = ppr_mono_lty pREC_FUN ty1 unicode p2 = ppr_mono_lty pREC_TOP ty2 unicode @@ -1138,7 +1138,8 @@ markupAName = \_ _ -> empty, markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p) + markupHeader = \(Header l h) p -> header l (h p), + markupTable = \(Table h b) p -> table h b p } where header 1 d = text "\\section*" <> braces d @@ -1146,6 +1147,8 @@ header l d | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + + table _ _ _ = text "{TODO: Table}" fixString Plain s = latexFilter s fixString Verb s = s diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -11,7 +11,7 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, NamedFieldPuns #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents, @@ -31,15 +31,18 @@ import Haddock.Types import Haddock.Version import Haddock.Utils +import Haddock.Utils.Json import Text.XHtml hiding ( name, title, p, quote ) import Haddock.GhcUtils import Control.Monad ( when, unless ) +import qualified Data.ByteString.Builder as Builder import Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, intercalate, isPrefixOf, intersperse ) +import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) import Data.Maybe -import System.FilePath hiding ( () ) import System.Directory +import System.FilePath hiding ( () ) +import qualified System.IO as IO import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) @@ -48,17 +51,16 @@ import DynFlags (Language(..)) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import Name -import Module -------------------------------------------------------------------------------- -- * Generating HTML documentation -------------------------------------------------------------------------------- - ppHtml :: DynFlags -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] + -> [InstalledInterface] -- ^ Reexported interfaces -> FilePath -- ^ Destination directory -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes @@ -70,12 +72,13 @@ -> Bool -- ^ Whether to use unicode in output (--use-unicode) -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) + -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces odir prologue +ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode - qual debug = do + qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -83,28 +86,34 @@ when (isNothing maybe_contents_url) $ ppHtmlContents dflags odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) + (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents prologue debug (makeContentsQual qual) - when (isNothing maybe_index_url) $ + when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) debug + (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual + visible_ifaces + mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces -copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () -copyHtmlBits odir libdir themes = do +copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () +copyHtmlBits odir libdir themes withQuickjump = do let libhtmldir = joinPath [libdir, "html"] copyCssFile f = copyFile f (combine odir (takeFileName f)) copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) - copyLibFile jsFile + copyLibFile haddockJsFile + copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) + when withQuickjump (copyLibFile jsQuickJumpFile) return () @@ -114,13 +123,9 @@ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], thetitle << docTitle, styleSheet themes, - script ! [src jsFile, thetype "text/javascript"] << noHtml, - script ! [src mjUrl, thetype "text/javascript"] << noHtml, - script ! [thetype "text/javascript"] - -- NB: Within XHTML, the content of script tags needs to be - -- a \n" + thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml, + script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml, + script ! [src mjUrl, thetype "text/javascript"] << noHtml ] where mjUrl = maybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" id mathjax_url @@ -187,7 +192,6 @@ ) ] - moduleInfo :: Interface -> Html moduleInfo iface = let @@ -306,33 +310,35 @@ mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg srcPkg short ts) = +mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_:_, False) -> collapseControl p True "module" + (_:_, Nothing) -> collapseControl p "module" (_, _ ) -> [theclass "module"] cBtn = case (ts, leaf) of - (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml (_, _ ) -> noHtml -- We only need an explicit collapser button when the module name -- is also a leaf, and so is a link to a module page. Indeed, the -- spaceHtml is a minor hack and does upset the layout a fraction. htmlModule = thespan ! modAttrs << (cBtn +++ - if leaf - then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) - (mkModuleName mdl)) - else toHtml s + case leaf of + Just m -> ppModule m + Nothing -> toHtml s ) - mdl = intercalate "." (reverse (s:ss)) - shortDescr = maybe noHtml (origDocToHtml qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg - subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + subtree = + if null ts then noHtml else + collapseDetails p DetailsOpen ( + thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++ + mkNodeList qual (s:ss) p ts + ) @@ -340,7 +346,60 @@ -- * Generate the index -------------------------------------------------------------------------------- +ppJsonIndex :: FilePath + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Bool + -> QualOption + -> [Interface] + -> IO () +ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do + createDirectoryIfMissing True odir + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do + Builder.hPutBuilder h (encodeToBuilder modules) + where + modules :: Value + modules = Array (concatMap goInterface ifaces) + goInterface :: Interface -> [Value] + goInterface iface = + concatMap (goExport mdl qual) (ifaceRnExportItems iface) + where + aliases = ifaceModuleAliases iface + qual = makeModuleQual qual_opt aliases mdl + mdl = ifaceMod iface + + goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value] + goExport mdl qual item + | Just item_html <- processExport True links_info unicode qual item + = [ Object + [ "display_html" .= String (showHtmlFragment item_html) + , "name" .= String (intercalate " " (map nameString names)) + , "module" .= String (moduleString mdl) + , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names))) + ] + ] + | otherwise = [] + where + names = exportName item ++ exportSubs item + + exportSubs :: ExportItem name -> [IdP name] + exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs + exportSubs _ = [] + + exportName :: ExportItem name -> [IdP name] + exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) + exportName ExportNoDecl { expItemName } = [expItemName] + exportName _ = [] + + nameString :: NamedThing name => name -> String + nameString = occNameString . nameOccName . getName + + nameLink :: NamedThing name => Module -> name -> String + nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName + + links_info = (maybe_source_url, maybe_wiki_url) + ppHtmlIndex :: FilePath -> String -> Maybe String @@ -505,6 +564,7 @@ signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" + ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual = ppModuleContents qual exports (not . null $ ifaceRnOrphanInstances iface) +++ @@ -532,10 +592,12 @@ | no_doc_at_all = noHtml | otherwise = divSynopsis $ - paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ - shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports - ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + collapseDetails "syn" DetailsClosed ( + thesummary << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! collapseToggle "syn" "" + ) -- if the documentation doesn't begin with a section header, then -- add one ("Documentation"). @@ -556,7 +618,7 @@ ppModuleContents :: Qualification - -> [ExportItem DocName] + -> [ExportItem DocNameI] -> Bool -- ^ Orphans sections -> Html ppModuleContents qual exports orphan @@ -572,7 +634,7 @@ | orphan = [ linkedAnchor "section.orphans" << "Orphan instances" ] | otherwise = [] - process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI]) process _ [] = ([], []) process n items@(ExportGroup lev id0 doc : rest) | lev <= n = ( [], items ) @@ -589,9 +651,9 @@ -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: -numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI] numberSectionHeadings = go 1 - where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es) = ExportGroup lev (show n) doc : go (n+1) es @@ -600,7 +662,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Qualification - -> ExportItem DocName -> Maybe Html + -> ExportItem DocNameI -> Maybe Html processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) @@ -636,7 +698,8 @@ processDeclOneLiner False = Just . divTopDecl . declElem groupHeading :: Int -> String -> Html -> Html -groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] +groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId] + where grpId = groupId id0 groupTag :: Int -> Html -> Html groupTag lev diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -40,9 +40,9 @@ import BooleanFormula import RdrName ( rdrNameOcc ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocName - -> [(HsDecl DocName, DocForDecl DocName)] - -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] +ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] + -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual @@ -60,23 +60,23 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = ppFunSig summary links loc doc (map unLoc lnames) lty fixities splice unicode qual ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFunSig summary links loc doc docnames typ fixities splice unicode qual = ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) - splice unicode qual + splice unicode qual HideEmptyContexts where - pp_typ = ppLType unicode qual typ + pp_typ = ppLType unicode qual HideEmptyContexts typ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocName -> + [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual @@ -87,20 +87,20 @@ pref1 = hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> - Splice -> Unicode -> Qualification -> Html + [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> + Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual = + splice unicode qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) - splice unicode qual + splice unicode qual emptyCtxts where occnames = map (nameOccName . getName) docnames addFixities html @@ -108,10 +108,10 @@ | otherwise = html <+> ppFixities fixities qual -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual + -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++ @@ -122,7 +122,7 @@ do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> HsType DocName -> [SubDecl] + do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] do_args n leader (HsForAllTy tvs ltype) = do_largs n leader' ltype where @@ -132,16 +132,16 @@ | null (unLoc lctxt) = do_largs n leader ltype | otherwise - = (leader <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = [(leader <+> ppType unicode qual t, argDoc n, [])] + = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] -ppForAll :: [LHsTyVarBndr DocName] -> Unicode -> Qualification -> Html +ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of [] -> noHtml @@ -172,15 +172,15 @@ -- | Pretty-print type variables. -ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> [Html] +ppTyVars :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> [Html] ppTyVars unicode qual tvs = map (ppHsTyVarBndr unicode qual . unLoc) tvs -tyvarNames :: LHsQTyVars DocName -> [Name] +tyvarNames :: LHsQTyVars DocNameI -> [Name] tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> ForeignDecl DocName -> [(DocName, Fixity)] + -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities splice unicode qual @@ -190,18 +190,18 @@ -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan - -> DocForDecl DocName -> TyClDecl DocName + -> DocForDecl DocName -> TyClDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) splice unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual + splice unicode qual ShowEmptyToplevelContexts where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) - full = hdr <+> equals <+> ppLType unicode qual ltype + full = hdr <+> equals <+> ppPatSigType unicode qual ltype occ = nameOccName . getName $ name fixs | summary = noHtml @@ -220,14 +220,14 @@ ppTyName = ppName Prefix -ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> SrcSpan - -> [DocName] -> HsType DocName +ppSimpleSig :: LinksInfo -> Splice -> Unicode -> Qualification -> HideEmptyContexts -> SrcSpan + -> [DocName] -> HsType DocNameI -> Html -ppSimpleSig links splice unicode qual loc names typ = +ppSimpleSig links splice unicode qual emptyCtxts loc names typ = topDeclElem' names $ ppTypeSig True occNames ppTyp unicode where topDeclElem' = topDeclElem links loc splice - ppTyp = ppType unicode qual typ + ppTyp = ppType unicode qual emptyCtxts typ occNames = map getOccName names @@ -236,7 +236,7 @@ -------------------------------------------------------------------------------- -ppFamilyInfo :: Bool -> FamilyInfo DocName -> Html +ppFamilyInfo :: Bool -> FamilyInfo DocNameI -> Html ppFamilyInfo assoc OpenTypeFamily | assoc = keyword "type" | otherwise = keyword "type family" @@ -246,7 +246,7 @@ ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family" -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName +ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocNameI -> Unicode -> Qualification -> Html ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info , fdResultSig = L _ result @@ -276,28 +276,28 @@ _ -> mempty ) -ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html +ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of NoSig -> noHtml KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr -ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName +ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppFamilyInfo True pfdInfo <+> - ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+> ppResultSig (unLoc pfdKindSig) unicode qual -ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html +ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) = char '|' <+> ppLDocName qual Raw lhs <+> arrow unicode <+> hsep (map (ppLDocName qual Raw) rhs) -ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> +ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html + FamilyDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppTyFam summary associated links instances fixities loc doc decl splice unicode qual | summary = ppTyFamHeader True associated decl unicode qual @@ -318,16 +318,17 @@ = ppInstances links (OriginFamily docname) instances splice unicode qual -- Individual equation of a closed type family - ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs - , tfe_pats = HsIB { hsib_body = ts }} - = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual - <+> equals <+> ppType unicode qual (unLoc rhs) + ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl + ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs + , feqn_pats = ts } }) + = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual + <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) ppPseudoFamilyDecl :: LinksInfo -> Splice -> Unicode -> Qualification - -> PseudoFamilyDecl DocName + -> PseudoFamilyDecl DocNameI -> Html ppPseudoFamilyDecl links splice unicode qual decl@(PseudoFamilyDecl { pfdLName = L loc name, .. }) = @@ -341,7 +342,7 @@ -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual @@ -352,12 +353,12 @@ -------------------------------------------------------------------------------- -- | Print a type family and its variables -ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocName -> Html +ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) -- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocName -> Html +ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html ppDataBinderWithVars summ unicode qual decl = ppAppDocNameTyVarBndrs summ unicode qual (tcdName decl) (hsQTvExplicit $ tcdTyVars decl) @@ -365,31 +366,30 @@ -- * Type applications -------------------------------------------------------------------------------- -ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocName] -> Html +ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = - ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc) + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix ppBinderFixity _ = ppBinder --- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] - -> Unicode -> Qualification -> Html -ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) +-- | Print an application of a 'DocName' to its list of 'HsType's +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypes n ts unicode qual = + ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html -ppTypeApp n [] (t1:t2:rest) ppDN ppT +ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 -ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) +ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- @@ -397,33 +397,36 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html +ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode + -> Qualification -> HideEmptyContexts -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow cxt unicode qual = fromMaybe noHtml $ - ppContextNoLocsMaybe (map unLoc cxt) unicode qual +ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ + ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $ - ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocs :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContextNoLocs cxt unicode qual emptyCtxts = maybe noHtml (<+> darrow unicode) $ + ppContextNoLocsMaybe cxt unicode qual emptyCtxts -ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html -ppContextNoLocsMaybe [] _ _ = Nothing -ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocNameI] -> Unicode -> Qualification -> HideEmptyContexts -> Maybe Html +ppContextNoLocsMaybe [] _ _ emptyCtxts = + case emptyCtxts of + HideEmptyContexts -> Nothing + ShowEmptyToplevelContexts -> Just (toHtml "()") +ppContextNoLocsMaybe cxt unicode qual _ = Just $ ppHsContext cxt unicode qual -ppContext :: HsContext DocName -> Unicode -> Qualification -> Html -ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual +ppContext :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppContext cxt unicode qual emptyCtxts = ppContextNoLocs (map unLoc cxt) unicode qual emptyCtxts -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html -ppHsContext [] _ _ = noHtml +ppHsContext :: [HsType DocNameI] -> Unicode -> Qualification -> Html +ppHsContext [] _ _ = noHtml ppHsContext [p] unicode qual = ppCtxType unicode qual p -ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyContexts) cxt) ------------------------------------------------------------------------------- @@ -431,12 +434,12 @@ ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsQTyVars DocName -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName + -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml) <+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs) <+> ppFds fds unicode qual @@ -449,7 +452,7 @@ fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs @@ -481,9 +484,9 @@ -ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> SrcSpan -> Documentation DocName - -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName + -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars @@ -513,14 +516,14 @@ doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) + methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) subfixs splice unicode qual | L _ (ClassOpSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - subfixs = [ f | n <- names - , f@(n',_) <- fixities - , n == n' ] - names = map unLoc lnames ] + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = [ f | f@(n',_) <- fixities + , name == n' ] + ] -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. @@ -554,7 +557,7 @@ ppInstances :: LinksInfo - -> InstOrigin DocName -> [DocInstance DocName] + -> InstOrigin DocName -> [DocInstance DocNameI] -> Splice -> Unicode -> Qualification -> Html ppInstances links origin instances splice unicode qual @@ -562,22 +565,22 @@ -- force Splice = True to use line URLs where instName = getOccString origin - instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = ((ppInstHead links splice unicode qual mdoc origin False no inst), loc) ppOrphanInstances :: LinksInfo - -> [DocInstance DocName] + -> [DocInstance DocNameI] -> Splice -> Unicode -> Qualification -> Html ppOrphanInstances links instances splice unicode qual = subOrphanInstances qual links True (zipWith instDecl [1..] instances) where - instOrigin :: InstHead name -> InstOrigin name + instOrigin :: InstHead name -> InstOrigin (IdP name) instOrigin inst = OriginClass (ihdClsName inst) - instDecl :: Int -> DocInstance DocName -> (SubDecl,Located DocName) + instDecl :: Int -> DocInstance DocNameI -> (SubDecl,Located DocName) instDecl no (inst, mdoc, loc) = ((ppInstHead links splice unicode qual mdoc (instOrigin inst) True no inst), loc) @@ -587,12 +590,12 @@ -> InstOrigin DocName -> Bool -- ^ Is instance orphan -> Int -- ^ Normal - -> InstHead DocName + -> InstHead DocNameI -> SubDecl ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = case ihdInstType of ClassInst { .. } -> - ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual <+> typ + ( subInstHead iid $ ppContextNoLocs clsiCtx unicode qual HideEmptyContexts <+> typ , mdoc , [subInstDetails iid ats sigs] ) @@ -607,7 +610,7 @@ where ptype = keyword "type" <+> typ prhs = ptype <+> maybe noHtml - (\t -> equals <+> ppType unicode qual t) rhs + (\t -> equals <+> ppType unicode qual HideEmptyContexts t) rhs DataInst dd -> ( subInstHead iid pdata , mdoc @@ -617,11 +620,11 @@ pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where iid = instanceId origin no orphan ihd - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + typ = ppAppNameTypes ihdClsName ihdTypes unicode qual ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification - -> [PseudoFamilyDecl DocName] + -> [PseudoFamilyDecl DocNameI] -> [Html] ppInstanceAssocTys links splice unicode qual = map ppFamilyDecl' @@ -630,22 +633,22 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification - -> [Sig DocName] + -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do TypeSig lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ - -- Instance methods signatures are synified and thus don't have a useful + -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead. - return $ ppSimpleSig links splice unicode qual (getLoc $ head $ lnames) names rtyp + return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n -instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocName -> String +instanceId :: InstOrigin DocName -> Int -> Bool -> InstHead DocNameI -> String instanceId origin no orphan ihd = concat $ [ "o:" | orphan ] ++ [ qual origin @@ -665,8 +668,8 @@ -- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName - -> [(HsDecl DocName,DocForDecl DocName)] +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocNameI + -> [(HsDecl DocNameI, DocForDecl DocName)] -> Unicode -> Qualification -> Html ppShortDataDecl summary dataInst dataDecl pats unicode qual @@ -698,16 +701,16 @@ pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] | (SigD (PatSynSig lnames typ),_) <- pats ] -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> - [(HsDecl DocName,DocForDecl DocName)] -> + SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> + [(HsDecl DocNameI, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual @@ -744,7 +747,7 @@ [ (hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode - , ppLType unicode qual (hsSigType typ) + , ppPatSigType unicode qual (hsSigType typ) ] <+> ppFixities subfixs qual ,combineDocumentation (fst d), []) | (SigD (PatSynSig lnames typ),d) <- pats @@ -756,7 +759,7 @@ -ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html +ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual @@ -764,22 +767,22 @@ -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration -ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) +ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{} -> case con_details con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual) args), noHtml, noHtml) + : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) RecCon (L _ fields) -> (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppOccInfix, ppLParendType unicode qual arg2], + (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1, + ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], noHtml, noHtml) - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual resTy,noHtml,noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) where resTy = hsib_body (con_type con) @@ -805,13 +808,13 @@ -- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocName -> Unicode +ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode -> Qualification -> Html ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual + else ppContextNoArrow ctxt unicode qual HideEmptyContexts <+> darrow unicode +++ toHtml " ") where ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) @@ -819,7 +822,7 @@ | otherwise = noHtml ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocName -> SubDecl + -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where @@ -827,15 +830,15 @@ ConDeclH98{} -> case con_details con of PrefixCon args -> hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual) args) + : map (ppLParendType unicode qual HideEmptyContexts) args) <+> fixity RecCon _ -> header_ +++ ppOcc <+> fixity InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual arg1, + hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, ppOccInfix, - ppLParendType unicode qual arg2] + ppLParendType unicode qual HideEmptyContexts arg2] <+> fixity ConDeclGADT{} -> doGADTCon resTy @@ -849,10 +852,10 @@ doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: Located (HsType DocName) -> Html + doGADTCon :: Located (HsType DocNameI) -> Html doGADTCon ty = ppOcc <+> dcolon unicode -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual ty + <+> ppLType unicode qual HideEmptyContexts ty <+> fixity fixity = ppFixities fixities qual @@ -877,26 +880,29 @@ ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification - -> ConDeclField DocName -> SubDecl + -> ConDeclField DocNameI -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - (hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, - mbDoc, - []) + ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts ltype + , mbDoc + , [] + ) where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst -ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) - <+> dcolon unicode <+> ppLType unicode qual ltype + <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html ppDataHeader summary decl@(DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd , dd_ctxt = ctxt @@ -906,7 +912,7 @@ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext ctxt unicode qual <+> + ppLContext ctxt unicode qual HideEmptyContexts <+> -- T a b c ..., or a :+: b ppDataBinderWithVars summary unicode qual decl <+> case ks of @@ -958,87 +964,109 @@ | otherwise = p -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification - -> Located (HsType DocName) -> Html -ppLType unicode qual y = ppType unicode qual (unLoc y) -ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) -ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html +ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) +ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) +ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) +ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts -ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification - -> HsType DocName -> Html -ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual -ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual -ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual +ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html +ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts -ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html +ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) -ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html +ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) -ppKind :: Unicode -> Qualification -> HsKind DocName -> Html -ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual +ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts -ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocName] -> Html +ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = + if hasNonEmptyContext typ && isFirstContextEmpty typ + then ShowEmptyToplevelContexts + else HideEmptyContexts + in ppLType unicode qual emptyCtxts typ + where + hasNonEmptyContext :: LHsType name -> Bool + hasNonEmptyContext t = + case unLoc t of + HsForAllTy _ s -> hasNonEmptyContext s + HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ s -> hasNonEmptyContext s + _ -> False + isFirstContextEmpty :: LHsType name -> Bool + isFirstContextEmpty t = + case unLoc t of + HsForAllTy _ s -> isFirstContextEmpty s + HsQualTy cxt _ -> null (unLoc cxt) + HsFunTy _ s -> isFirstContextEmpty s + _ -> False + +ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual +ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual + ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual +ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual + ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ +ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q -ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) -ppr_mono_ty _ (HsSumTy tys) u q = sumParens (map (ppLType u q) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q = - parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q -ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = toHtml "{..}" +ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e +ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q e = + parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) +ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts +ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q = brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = promoQuote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ = error "ppr_mono_ty HsAppsTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _ = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _ = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual + ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts where -- `(:)` is valid in type signature only as constructor to promoted list -- and needs to be quoted in code so we explicitly quote it here too. @@ -1047,25 +1075,24 @@ | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts -- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual - = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts + = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n +ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) - -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual +ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts in maybeParen ctxt_prec pREC_FUN $ hsep [p1, arrow unicode <+> p2] diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -20,6 +20,7 @@ ) where import Data.List +import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types @@ -72,7 +73,8 @@ markupMathDisplay = \mathjax -> toHtml ("\\[" ++ mathjax ++ "\\]"), markupProperty = pre . toHtml, markupExample = examplesToHtml, - markupHeader = \(Header l t) -> makeHeader l t + markupHeader = \(Header l t) -> makeHeader l t, + markupTable = \(Table h r) -> makeTable h r } where makeHeader :: Int -> Html -> Html @@ -84,7 +86,23 @@ makeHeader 6 mkup = h6 mkup makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + makeTable :: [TableRow Html] -> [TableRow Html] -> Html + makeTable hs bs = table (concatHtml (hs' ++ bs')) + where + hs' | null hs = [] + | otherwise = [thead (concatHtml (map (makeTableRow th) hs))] + bs' = [tbody (concatHtml (map (makeTableRow td) bs))] + + makeTableRow :: (Html -> Html) -> TableRow Html -> Html + makeTableRow thr (TableRow cs) = tr (concatHtml (map (makeTableCell thr) cs)) + + makeTableCell :: (Html -> Html) -> TableCell Html -> Html + makeTableCell thr (TableCell i j c) = thr c ! (i' ++ j') + where + i' = if i == 1 then [] else [ colspan i ] + j' = if j == 1 then [] else [ rowspan j ] + examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] exampleToHtml (Example expression result) = htmlExample @@ -164,9 +182,9 @@ UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - expanded = False - col' = collapseControl id_ expanded "caption" - instTable = (thediv ! collapseSection id_ expanded [] <<) + col' = collapseControl id_ "caption" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" + instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -199,10 +199,10 @@ -> [(SubDecl,Located DocName)] -> Html subInstances qual nm lnks splice = maybe noHtml wrap . instTable where - wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) + instTable = subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] - subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + summary = thesummary << "Instances" id_ = makeAnchorId $ "i:" ++ nm @@ -212,7 +212,7 @@ subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice id_ = makeAnchorId $ "orphans" @@ -222,7 +222,7 @@ subInstHead iid hdr = expander noHtml <+> hdr where - expander = thespan ! collapseControl (instAnchorId iid) False "instance" + expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails :: String -- ^ Instance unique id (for anchor generation) @@ -241,7 +241,9 @@ subInstSection :: String -- ^ Instance unique id (for anchor generation) -> Html -> Html -subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details" +subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) + where + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details" instAnchorId :: String -> String instAnchorId iid = makeAnchorId $ "i:" ++ iid diff --git a/src/Haddock/Backends/Xhtml/Meta.hs b/src/Haddock/Backends/Xhtml/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Meta.hs @@ -0,0 +1,28 @@ +module Haddock.Backends.Xhtml.Meta where + +import Haddock.Utils.Json +import Haddock.Version + +import Data.ByteString.Builder (hPutBuilder) +import System.FilePath (()) +import System.IO (withFile, IOMode (WriteMode)) + +-- | Everytime breaking changes to the Quckjump api +-- happen this needs to be modified. +quickjumpVersion :: Int +quickjumpVersion = 1 + +-- | Writes a json encoded file containing additional +-- information about the generated documentation. This +-- is useful for external tools (e.g. hackage). +writeHaddockMeta :: FilePath -> Bool -> IO () +writeHaddockMeta odir withQuickjump = do + let + meta_json :: Value + meta_json = object (concat [ + [ "haddock_version" .= String projectVersion ] + , [ "quickjump_version" .= quickjumpVersion | withQuickjump ] + ]) + + withFile (odir "meta.json") WriteMode $ \h -> + hPutBuilder h (encodeToBuilder meta_json) diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -22,7 +22,7 @@ import Haddock.Types import Haddock.Utils -import Text.XHtml hiding ( name, title, p, quote ) +import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M import qualified Data.List as List @@ -147,17 +147,19 @@ linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html linkIdOcc mdl mbName insertAnchors = if insertAnchors - then anchor ! [href url] + then anchor ! [href url, title ttl] else id where + ttl = moduleNameString (moduleName mdl) url = case mbName of Nothing -> moduleUrl mdl Just name -> moduleNameUrl mdl name linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html -linkIdOcc' mdl mbName = anchor ! [href url] +linkIdOcc' mdl mbName = anchor ! [href url, title ttl] where + ttl = moduleNameString mdl url = case mbName of Nothing -> moduleHtmlFile' mdl Just name -> moduleNameUrl' mdl name diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -25,7 +25,8 @@ hsep, vcat, - collapseSection, collapseToggle, collapseControl, + DetailsState(..), collapseDetails, thesummary, + collapseToggle, collapseControl, ) where @@ -213,26 +214,22 @@ -- A section of HTML which is collapsible. -- --- | Attributes for an area that can be collapsed -collapseSection :: String -> Bool -> String -> [HtmlAttr] -collapseSection id_ state classes = [ identifier sid, theclass cs ] - where cs = unwords (words classes ++ [pick state "show" "hide"]) - sid = "section." ++ id_ +data DetailsState = DetailsOpen | DetailsClosed +collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) + where openAttrs = case state of { DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] } + +thesummary :: Html -> Html +thesummary = tag "summary" + -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> [HtmlAttr] -collapseToggle id_ = [ strAttr "onclick" js ] - where js = "toggleSection('" ++ id_ ++ "')"; +collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] + where cs = unwords (words classes ++ ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> Bool -> String -> [HtmlAttr] -collapseControl id_ state classes = - [ identifier cid, theclass cs ] ++ collapseToggle id_ - where cs = unwords (words classes ++ [pick state "collapser" "expander"]) - cid = "control." ++ id_ - - -pick :: Bool -> a -> a -> a -pick True t _ = t -pick False _ f = f +collapseControl :: String -> String -> [HtmlAttr] +collapseControl id_ classes = collapseToggle id_ cs + where cs = unwords (words classes ++ ["details-toggle-control"]) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -24,6 +24,7 @@ import Data.Either (lefts, rights) import DataCon import FamInstEnv +import FV import HsSyn import Name import NameSet ( emptyNameSet ) @@ -39,8 +40,10 @@ import PrelNames ( hasKey, eqTyConKey, ipClassKey , tYPETyConKey, liftedRepDataConKey ) import Unique ( getUnique ) -import Util ( filterByList, filterOut ) +import Util ( chkAppend, compareLength, dropList, filterByList, filterOut + , splitAtList ) import Var +import VarSet import Haddock.Types import Haddock.Interface.Specialize @@ -48,7 +51,7 @@ -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name)) +tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) tyThingToLHsDecl t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. @@ -76,7 +79,7 @@ in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) , tcdFixity = Prefix , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ @@ -107,25 +110,30 @@ withErrs e x = return (e, x) allOK x = return (mempty, x) -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) - = let name = synifyName tc - typats = map (synifyType WithinType) args - hs_rhs = synifyType WithinType rhs - in TyFamEqn { tfe_tycon = name - , tfe_pats = HsIB { hsib_body = typats - , hsib_vars = map tyVarName tkvs - , hsib_closed = True } - , tfe_fixity = Prefix - , tfe_rhs = hs_rhs } + = let name = synifyName tc + args_types_only = filterOutInvisibleTypes tc args + typats = map (synifyType WithinType) args_types_only + annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) + args_types_only typats + hs_rhs = synifyType WithinType rhs + in HsIB { hsib_vars = map tyVarName tkvs + , hsib_closed = True + , hsib_body = FamEqn { feqn_tycon = name + , feqn_pats = annot_typats + , feqn_fixity = Prefix + , feqn_rhs = hs_rhs } } + where + fam_tvs = tyConVisibleTyVars tc -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) +synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD (TyFamInstD - (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNamesTc })) + = return $ InstD + $ TyFamInstD + $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error @@ -135,7 +143,7 @@ = Left "synifyAxiom: closed/open family confusion" -- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ @@ -155,7 +163,7 @@ -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + , dd_kindSig = synifyDataTyConReturnKind tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } @@ -184,19 +192,19 @@ mkFamDecl i = return $ FamDecl $ FamilyDecl { fdInfo = i , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = Prefix , fdResultSig = synifyFamilyResultSig resultVar (tyConResKind tc) , fdInjectivityAnn = synifyInjectivityAnn resultVar (tyConTyVars tc) - (familyTyConInjectivityInfo tc) + (tyConInjectivityInfo tc) } synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc = return $ SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix , tcdRhs = synifyType WithinType ty , tcdFVs = placeHolderNamesTc } @@ -209,8 +217,8 @@ Just a -> synifyName a -- Data families are named according to their -- CoAxioms, not their TyCons _ -> synifyName tc - tyvars = synifyTyVars (tyConTyVars tc) - kindSig = Just (tyConKind tc) + tyvars = synifyTyVars (tyConVisibleTyVars tc) + kindSig = synifyDataTyConReturnKind tc -- The data constructors. -- -- Any data-constructors not exported from the module that *defines* the @@ -235,7 +243,7 @@ defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing - , dd_kindSig = fmap synifyKindSig kindSig + , dd_kindSig = kindSig , dd_cons = cons , dd_derivs = alg_deriv } in case lefts consRaw of @@ -245,15 +253,36 @@ , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs +-- In this module, every TyCon being considered has come from an interface +-- file. This means that when considering a data type constructor such as: +-- +-- data Foo (w :: *) (m :: * -> *) (a :: *) +-- +-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are +-- also rendering the type variables of Foo, so if we synify the tyConKind of +-- Foo in full, we will end up displaying this in Haddock: +-- +-- data Foo (w :: *) (m :: * -> *) (a :: *) +-- :: * -> (* -> *) -> * -> * +-- +-- Which is entirely wrong (#548). We only want to display the *return* kind, +-- which this function obtains. +synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) +synifyDataTyConReturnKind tc + = case splitFunTys (tyConKind tc) of + (_, ret_kind) + | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * + | otherwise -> Just (synifyKindSig ret_kind) + synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity - -> Maybe (LInjectivityAnn Name) + -> Maybe (LInjectivityAnn GhcRn) synifyInjectivityAnn Nothing _ _ = Nothing synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = let rhs = map (noLoc . tyVarName) (filterByList inj tvs) in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs -synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig Name +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = @@ -264,7 +293,7 @@ -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name) +synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn) synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with @@ -321,22 +350,22 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) -synifyIdSig :: SynifyTypeState -> Id -> Sig Name +synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig Name +synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) -synifyCtx :: [PredType] -> LHsContext Name +synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsQTyVars Name +synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_implicit = [] , hsq_explicit = map synifyTyVar ktvs , hsq_dependent = emptyNameSet } -synifyTyVar :: TyVar -> LHsTyVarBndr Name +synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) @@ -344,6 +373,33 @@ kind = tyVarKind tv name = getName tv +-- | Annotate (with HsKingSig) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to synify type patterns for poly-kinded tyvars in +-- synifying class and type instances. +annotHsType :: Bool -- True <=> annotate + -> Type -> LHsType GhcRn -> LHsType GhcRn + -- tiny optimization: if the type is annotated, don't annotate again. +annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty +annotHsType True ty hs_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = let ki = typeKind ty + hs_ki = synifyType WithinType ki + in noLoc (HsKindSig hs_ty hs_ki) +annotHsType _ _ hs_ty = hs_ty + +-- | For every type variable in the input, +-- report whether or not the tv is poly-kinded. This is used to eventually +-- feed into 'annotHsType'. +mkIsPolyTvs :: [TyVar] -> [Bool] +mkIsPolyTvs = map is_poly_tv + where + is_poly_tv tv = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType $ + tyVarKind tv + --states of what to do with foralls: data SynifyTypeState = WithinType @@ -360,53 +416,95 @@ -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType Name +synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType Name +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) -synifyPatSynSigType :: PatSyn -> LHsSigType Name +synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType Name +synifyType :: SynifyTypeState -> Type -> LHsType GhcRn synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) - -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) - | tc `hasKey` tYPETyConKey - , [TyConApp lev []] <- tys - , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) - -- Use non-prefix tuple syntax where possible, because it looks nicer. - | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = noLoc $ HsTupleTy (case sort of - BoxedTuple -> HsBoxedTuple - ConstraintTuple -> HsConstraintTuple - UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) tys) - -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy (synifyType WithinType ty) - -- ditto for implicit parameter tycons - | tc `hasKey` ipClassKey - , [name, ty] <- tys - , Just x <- isStrLitTy name - = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) - -- and equalities - | tc `hasKey` eqTyConKey - , [ty1, ty2] <- tys - = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) - -- Most TyCons: - | otherwise = - foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar NotPromoted $ noLoc (getName tc)) - (map (synifyType WithinType) $ - filterOut isCoercionTy tys) + = maybe_sig res_ty + where + res_ty :: LHsType GhcRn + res_ty + -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) + | tc `hasKey` tYPETyConKey + , [TyConApp lev []] <- tys + , lev `hasKey` liftedRepDataConKey + = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) + -- Use non-prefix tuple syntax where possible, because it looks nicer. + | Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = noLoc $ HsTupleTy (case sort of + BoxedTuple -> HsBoxedTuple + ConstraintTuple -> HsConstraintTuple + UnboxedTuple -> HsUnboxedTuple) + (map (synifyType WithinType) vis_tys) + -- ditto for lists + | getName tc == listTyConName, [ty] <- tys = + noLoc $ HsListTy (synifyType WithinType ty) + -- ditto for implicit parameter tycons + | tc `hasKey` ipClassKey + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) + -- and equalities + | tc `hasKey` eqTyConKey + , [ty1, ty2] <- tys + = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + -- and infix type operators + | isSymOcc (nameOccName (getName tc)) + , ty1:ty2:tys_rest <- vis_tys + = mk_app_tys (HsOpTy (synifyType WithinType ty1) + (noLoc $ getName tc) + (synifyType WithinType ty2)) + tys_rest + -- Most TyCons: + | otherwise + = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc)) + vis_tys + where + mk_app_tys ty_app ty_args = + foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2) + (noLoc ty_app) + (map (synifyType WithinType) $ + filterOut isCoercionTy ty_args) + + vis_tys = filterOutInvisibleTypes tc tys + binders = tyConBinders tc + res_kind = tyConResKind tc + + maybe_sig :: LHsType GhcRn -> LHsType GhcRn + maybe_sig ty' + | needs_kind_sig + = let full_kind = typeKind (mkTyConApp tc tys) + full_kind' = synifyType WithinType full_kind + in noLoc $ HsKindSig ty' full_kind' + | otherwise = ty' + + needs_kind_sig :: Bool + needs_kind_sig + | GT <- compareLength tys binders + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAtList tys binders + result_kind = mkTyConKind remaining_binders res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injectiveVarsOfBinder dropped_binders + + in not (subVarSet result_vars dropped_vars) + synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 @@ -430,7 +528,7 @@ synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" -synifyPatSynType :: PatSyn -> LHsType Name +synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] @@ -450,17 +548,16 @@ synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s -synifyKindSig :: Kind -> LHsKind Name +synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls - , ihdKinds = map (unLoc . synifyType WithinType) ks - , ihdTypes = map (unLoc . synifyType WithinType) ts + , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst { clsiCtx = map (unLoc . synifyType WithinType) preds - , clsiTyVars = synifyTyVars $ classTyVars cls + , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls @@ -468,24 +565,48 @@ } } where - (ks,ts) = partitionInvisibles (classTyCon cls) id types + cls_tycon = classTyCon cls + ts = filterOutInvisibleTypes cls_tycon types + ts' = map (synifyType WithinType) ts + annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' + is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) +synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) synifyFamInst fi opaque = do - ityp' <- ityp $ fi_flavor fi + ityp' <- ityp fam_flavor return InstHead { ihdClsName = fi_fam fi - , ihdKinds = synifyTypes ks - , ihdTypes = synifyTypes ts + , ihdTypes = map unLoc annot_ts , ihdInstType = ityp' } where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c - (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi - synifyTypes = map (unLoc. synifyType WithinType) + fam_tc = famInstTyCon fi + fam_flavor = fi_flavor fi + fam_lhs = fi_tys fi + fam_rhs = fi_rhs fi + + eta_expanded_lhs + -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See Trac #9692 + -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC + | DataFamilyInst rep_tc <- fam_flavor + = let (_, rep_tc_args) = splitTyConApp fam_rhs + etad_tyvars = dropList rep_tc_args $ tyConTyVars rep_tc + etad_tys = mkTyVarTys etad_tyvars + eta_exp_lhs = fam_lhs `chkAppend` etad_tys + in eta_exp_lhs + | otherwise + = fam_lhs + + ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs + synifyTypes = map (synifyType WithinType) + ts' = synifyTypes ts + annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' + is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -43,7 +43,7 @@ isConSym = isLexConSym . occNameFS -getMainDeclBinder :: HsDecl name -> [name] +getMainDeclBinder :: HsDecl name -> [IdP name] getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of @@ -59,21 +59,22 @@ -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l +getInstLoc (DataFamInstD (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l getInstLoc (TyFamInstD (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) +filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name) filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig filterSigNames p (FixSig (FixitySig ns ty)) = @@ -99,10 +100,10 @@ ifTrueJust True = Just ifTrueJust False = const Nothing -sigName :: LSig name -> [name] +sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig -sigNameNoLoc :: Sig name -> [name] +sigNameNoLoc :: Sig name -> [IdP name] sigNameNoLoc (TypeSig ns _) = map unLoc ns sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns sigNameNoLoc (PatSynSig ns _) = map unLoc ns @@ -128,7 +129,7 @@ isValD _ = False -declATs :: HsDecl a -> [a] +declATs :: HsDecl a -> [IdP a] declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -164,7 +165,7 @@ ------------------------------------------------------------------------------- -instance NamedThing (TyClDecl Name) where +instance NamedThing (TyClDecl GhcRn) where getName = tcdName ------------------------------------------------------------------------------- @@ -176,14 +177,14 @@ children :: a -> [Name] -instance Parent (ConDecl Name) where +instance Parent (ConDecl GhcRn) where children con = case getConDetails con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] -instance Parent (TyClDecl Name) where +instance Parent (TyClDecl GhcRn) where children d | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d @@ -198,12 +199,12 @@ family = getName &&& children -familyConDecl :: ConDecl Name -> [(Name, [Name])] +familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. -families :: TyClDecl Name -> [(Name, [Name])] +families :: TyClDecl GhcRn -> [(Name, [Name])] families d | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] @@ -211,12 +212,12 @@ -- | A mapping from child to parent -parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap :: TyClDecl GhcRn -> [(Name, Name)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration -parents :: Name -> HsDecl Name -> [Name] +parents :: Name -> HsDecl GhcRn -> [Name] parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -58,6 +58,8 @@ import HscTypes import FastString (unpackFS) import MonadUtils (liftIO) +import TcRnTypes (tcg_rdr_env) +import RdrName (plusGlobalRdrEnv) #if defined(mingw32_HOST_OS) import System.IO @@ -122,11 +124,7 @@ -- resulting ModSummaries. (if useTempDir then withTempOutputDir else id) $ do modGraph <- depAnalysis - if needsTemplateHaskell modGraph then do - modGraph' <- enableCompilation modGraph - createIfaces verbosity flags instIfaceMap modGraph' - else - createIfaces verbosity flags instIfaceMap modGraph + createIfaces verbosity flags instIfaceMap modGraph where useTempDir :: Bool @@ -149,17 +147,6 @@ depanal [] False - enableCompilation :: ModuleGraph -> Ghc ModuleGraph - enableCompilation modGraph = do - let enableComp d = let platform = targetPlatform d - in d { hscTarget = defaultObjectTarget platform } - modifySessionDynFlags enableComp - -- We need to update the DynFlags of the ModSummaries as well. - let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } - let modGraph' = map upd modGraph - return modGraph' - - createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] createIfaces verbosity flags instIfaceMap mods = do let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing @@ -178,6 +165,18 @@ processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tm <- loadModule =<< typecheckModule =<< parseModule modsum + + -- We need to modify the interactive context's environment so that when + -- Haddock later looks for instances, it also looks in the modules it + -- encountered while typechecking. + -- + -- See https://github.com/haskell/haddock/issues/469. + hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession + let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm + setSession hsc_env{ hsc_IC = old_IC { + ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env + } } + if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap @@ -194,7 +193,7 @@ , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface ] where - formatName :: SrcSpan -> HsDecl Name -> String + formatName :: SrcSpan -> HsDecl GhcRn -> String formatName loc n = p (getMainDeclBinder n) ++ case loc of RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> "" @@ -206,12 +205,13 @@ then drop (length ms) n else n - out verbosity normal coverageMsg - when (Flag_NoPrintMissingDocs `notElem` flags - && not (null undocumentedExports && header)) $ do - out verbosity normal " Missing documentation for:" - unless header $ out verbosity normal " Module header" - mapM_ (out verbosity normal . (" " ++)) undocumentedExports + when (OptHide `notElem` ifaceOptions interface) $ do + out verbosity normal coverageMsg + when (Flag_NoPrintMissingDocs `notElem` flags + && not (null undocumentedExports && header)) $ do + out verbosity normal " Missing documentation for:" + unless header $ out verbosity normal " Module header" + mapM_ (out verbosity normal . (" " ++)) undocumentedExports interface' <- liftIO $ evaluate interface return (Just interface') else diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances @@ -18,7 +19,6 @@ import Haddock.Convert import Haddock.GhcUtils -import Control.Applicative import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) @@ -53,7 +53,7 @@ -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] attachInstances expInfo ifaces instIfaceMap = do - (_msgs, mb_index) <- getNameToInstancesIndex + (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input @@ -67,7 +67,7 @@ , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] @@ -82,8 +82,8 @@ -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem Name - -> Ghc (ExportItem Name) + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do @@ -117,12 +117,12 @@ where attachFixities e@ExportDecl{ expItemDecl = L _ d , expItemPats = patsyns + , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d - , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []] - , n' <- n : (subs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , n' <- n : (map fst subDocs ++ patsyn_names) + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -30,27 +31,30 @@ import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bifunctor +import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Map (Map) import Data.List import Data.Maybe -import Data.Monoid import Data.Ord import Control.Applicative -import Control.Arrow (second) -import Control.DeepSeq (force) import Control.Exception (evaluate) import Control.Monad import Data.Traversable +import Avail hiding (avail) +import qualified Avail import qualified Packages import qualified Module import qualified SrcLoc +import ConLike (ConLike(..)) import GHC import HscTypes import Name import NameSet +import NameEnv import Bag import RdrName import TcRnTypes @@ -59,6 +63,7 @@ import qualified Outputable as O import HsDecls ( getConDetails ) + -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. @@ -83,48 +88,36 @@ (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_patsyns = patsyns + , tcg_exports = all_exports }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. - (group_, mayExports, mayDocHeader) <- + (group_, imports, mayExports, mayDocHeader) <- case renamedSource tm of Nothing -> do liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, Nothing, Nothing) - Just (x, _, y, z) -> return (x, y, z) + return (emptyRnGroup, [], Nothing, Nothing) + Just x -> return x - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - let opts - | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 - | otherwise = opts0 + opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ - exports0 = fmap (reverse . map unLoc) mayExports + exports0 = fmap (reverse . map (first unLoc)) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - warningMap = mkWarningMap dflags warnings gre exportedNames - localBundledPatSyns :: Map Name [Name] - localBundledPatSyns = - case exports of - Nothing -> M.empty - Just ies -> - M.map (nubByName id) $ - M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns) - | IEThingWith (L _ ty_name) _ exported _ <- ies - , let bundled_patsyns = - filter is_patsyn (map (ieWrappedName . unLoc) exported) - , not (null bundled_patsyns) - ] - where - is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns)) + unrestrictedImportedMods + -- module re-exports are only possible with + -- explicit export list + | Just{} <- exports + = unrestrictedModuleImports (map unLoc imports) + | otherwise = M.empty fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs @@ -134,15 +127,18 @@ -- Locations of all TH splices splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] - maps@(!docMap, !argMap, !subMap, !declMap, _) = - mkMaps dflags gre localInsts declsWithDocs + warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) + maps@(!docMap, !argMap, !declMap, _) <- + liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) + let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls - maps localBundledPatSyns fixMap splices exports instIfaceMap dflags + exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre + exportedNames decls maps fixMap unrestrictedImportedMods + splices exports all_exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -161,10 +157,11 @@ let !aliases = mkAliasMap dflags $ tm_renamed_source tm - modWarn = moduleWarning dflags gre warnings - tokenizedSrc <- mkMaybeTokenizedSrc flags tm + modWarn <- liftErrMsg (moduleWarning dflags gre warnings) + tokenizedSrc <- mkMaybeTokenizedSrc dflags flags tm + return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig @@ -182,8 +179,6 @@ , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap - , ifaceBundledPatSynMap = localBundledPatSyns - , ifaceSubMap = subMap , ifaceFixMap = fixMap , ifaceModuleAliases = aliases , ifaceInstances = instances @@ -229,6 +224,41 @@ alias)) impDecls +-- We want to know which modules are imported without any qualification. This +-- way we can display module reexports more compactly. This mapping also looks +-- through aliases: +-- +-- module M (module X) where +-- import M1 as X +-- import M2 as X +-- +-- With our mapping we know that we can display exported modules M1 and M2. +-- +unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports idecls = + M.map (map (unLoc . ideclName)) + $ M.filter (all isInteresting) impModMap + where + impModMap = + M.fromListWith (++) (concatMap moduleMapping idecls) + + moduleMapping idecl = + concat [ [ (unLoc (ideclName idecl), [idecl]) ] + , [ (unLoc mod_name, [idecl]) + | Just mod_name <- [ideclAs idecl] + ] + ] + + isInteresting idecl = + case ideclHiding idecl of + -- i) no subset selected + Nothing -> True + -- ii) an import with a hiding clause + -- without any names + Just (True, L _ []) -> True + -- iii) any other case of qualification + _ -> False + -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: @@ -245,27 +275,29 @@ -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of - NoWarnings -> M.empty - WarnAll _ -> M.empty + NoWarnings -> pure M.empty + WarnAll _ -> pure M.empty WarnSome ws -> - let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + let ws' = [ (n, w) + | (occ, w) <- ws + , elt <- lookupGlobalRdrEnv gre occ , let n = gre_name elt, n `elem` exps ] - in M.fromList $ map (second $ parseWarning dflags gre) ws' + in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) -moduleWarning _ _ NoWarnings = Nothing -moduleWarning _ _ (WarnSome _) = Nothing -moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) +moduleWarning _ _ NoWarnings = pure Nothing +moduleWarning _ _ (WarnSome _) = pure Nothing +moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name -parseWarning dflags gre w = force $ case w of +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) +parseWarning dflags gre w = case w of DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - . processDocString dflags gre $ HsDocString xs + <$> processDocString dflags gre (HsDocString xs) ------------------------------------------------------------------------------- @@ -282,13 +314,17 @@ [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] xs -> liftM catMaybes (mapM parseOption xs) Nothing -> return [] - hm <- if Flag_HideModule (moduleString mdl) `elem` flags - then return $ OptHide : opts - else return opts - if Flag_ShowExtensions (moduleString mdl) `elem` flags - then return $ OptShowExtensions : hm - else return hm + pure (foldl go opts flags) + where + mdlStr = moduleString mdl + -- Later flags override earlier ones + go os m | m == Flag_HideModule mdlStr = OptHide : os + | m == Flag_ShowModule mdlStr = filter (/= OptHide) os + | m == Flag_ShowAllModules = filter (/= OptHide) os + | m == Flag_IgnoreAllExports = OptIgnoreExports : os + | m == Flag_ShowExtensions mdlStr = OptIgnoreExports : os + | otherwise = os parseOption :: String -> ErrMsgM (Maybe DocOption) parseOption "hide" = return (Just OptHide) @@ -304,7 +340,7 @@ -------------------------------------------------------------------------------- -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) +type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings @@ -312,17 +348,15 @@ mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] - -> [(LHsDecl Name, [HsDocString])] - -> Maps -mkMaps dflags gre instances decls = - let - (a, b, c, d) = unzip4 $ map mappings decls - in ( f' (map (nubByName fst) a) - , f (filterMapping (not . M.null) b) - , f (filterMapping (not . null) c) - , f (filterMapping (not . null) d) - , instanceMap - ) + -> [(LHsDecl GhcRn, [HsDocString])] + -> ErrMsgM Maps +mkMaps dflags gre instances decls = do + (a, b, c) <- unzip3 <$> traverse mappings decls + pure ( f' (map (nubByName fst) a) + , f (filterMapping (not . M.null) b) + , f (filterMapping (not . null) c) + , instanceMap + ) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat @@ -333,41 +367,46 @@ filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] filterMapping p = map (filter (p . snd)) - mappings :: (LHsDecl Name, [HsDocString]) - -> ( [(Name, MDoc Name)] - , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] - , [(Name, [LHsDecl Name])] - ) - mappings (ldecl, docStrs) = + mappings :: (LHsDecl GhcRn, [HsDocString]) + -> ErrMsgM ( [(Name, MDoc Name)] + , [(Name, Map Int (MDoc Name))] + , [(Name, [LHsDecl GhcRn])] + ) + mappings (ldecl, docStrs) = do let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString - -> (Maybe (MDoc Name), Map Int (MDoc Name)) - declDoc strs m = - let doc' = processDocStrings dflags gre strs - m' = M.map (processDocStringParas dflags gre) m - in (doc', m') - (doc, args) = declDoc docStrs (typeDocs decl) + -> ErrMsgM (Maybe (MDoc Name), Map Int (MDoc Name)) + declDoc strs m = do + doc' <- processDocStrings dflags gre strs + m' <- traverse (processDocStringParas dflags gre) m + pure (doc', m') + + (doc, args) <- declDoc docStrs (typeDocs decl) + + let subs :: [(Name, [HsDocString], Map Int HsDocString)] subs = subordinates instanceMap decl - (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + + (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs + + let ns = names l decl subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - in seqList ns `seq` - seqList subNs `seq` - doc `seq` - seqList subDocs `seq` - seqList subArgs `seq` - (dm, am, sm, cm) + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + pure (dm, am, cm) + instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - names :: SrcSpan -> HsDecl Name -> [Name] + names :: SrcSpan -> HsDecl GhcRn -> [Name] names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs @@ -392,15 +431,17 @@ -- A subordinate declaration is something like the associate type or data -- family of a type class. subordinates :: InstMap - -> HsDecl Name + -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = def } <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def + DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + -> dataSubs (feqn_rhs d) TyClD d | isClassDecl d -> classSubs d | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] @@ -408,7 +449,7 @@ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] - dataSubs :: HsDataDefn Name -> [(Name, [HsDocString], Map Int HsDocString)] + dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) @@ -425,7 +466,7 @@ , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. -typeDocs :: HsDecl Name -> Map Int HsDocString +typeDocs :: HsDecl GhcRn -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of @@ -446,7 +487,7 @@ -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -458,18 +499,19 @@ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls = + filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only -mkFixMap :: HsGroup Name -> FixMap +mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) | L _ (FixitySig ns f) <- hs_fixds group_, L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup Name -> [LHsDecl Name] +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ @@ -519,7 +561,6 @@ isHandled (DocD _) = True isHandled _ = False - -- | Go through all class declarations and filter their sub-declarations filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x @@ -569,53 +610,78 @@ -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl Name] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps - -> Map Name [Name] -> FixMap + -> M.Map ModuleName [ModuleName] -> [SrcSpan] -- splice locations - -> Maybe [IE Name] + -> Maybe [(IE GhcRn, Avails)] + -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem Name] + -> ErrMsgGhc [ExportItem GhcRn] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags = - case optExports of - Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls + maps fixMap unrestricted_imp_mods splices exportList allExports + instIfaceMap dflags = + case exportList of + Nothing -> + fullModuleContents is_sig modMap thisMod semMod warnings gre + exportedNames decls maps fixMap splices instIfaceMap dflags + allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x - lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t - lookupExport (IEThingAll (L _ t)) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEThingWith (L _ t) _ _ _) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEModuleContents (L _ m)) = - -- TODO: We could get more accurate reporting here if IEModuleContents - -- also recorded the actual names that are exported here. We CAN - -- compute this info using @gre@ but 'moduleExports does not seem to - -- do so. - -- NB: Pass in identity module, so we can look it up in index correctly - moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = return $ - return . ExportGroup lev "" $ processDocString dflags gre docStr + lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do + doc <- processDocString dflags gre docStr + return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr) = return $ - return . ExportDoc $ processDocStringParas dflags gre docStr + lookupExport (IEDoc docStr, _) = liftErrMsg $ do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] - lookupExport (IEDocNamed str) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= return . \case - Nothing -> [] - Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + lookupExport (IEDocNamed str, _) = liftErrMsg $ + findNamedDoc str [ unL d | d <- decls ] >>= \case + Nothing -> return [] + Just docStr -> do + doc <- processDocStringParas dflags gre docStr + return [ExportDoc doc] - declWith :: [(HsDecl Name, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem Name ] - declWith pats t = do - r <- findDecl t + lookupExport (IEModuleContents (L _ mod_name), _) + -- only consider exporting a module if we are sure we + -- are really exporting the whole module and not some + -- subset. We also look through module aliases here. + | Just mods <- M.lookup mod_name unrestricted_imp_mods + , not (null mods) + = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods + + lookupExport (_, avails) = + concat <$> traverse availExport (nubAvails avails) + + availExport avail = + availExportItem is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avail + +availExportItem :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> ErrMsgGhc [ExportItem GhcRn] +availExportItem is_sig modMap thisMod semMod warnings exportedNames + (docMap, argMap, declMap, _) fixMap splices instIfaceMap + dflags availInfo = declWith availInfo + where + declWith :: AvailInfo -> ErrMsgGhc [ ExportItem GhcRn ] + declWith avail = do + let t = availName avail + r <- findDecl avail case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature @@ -625,11 +691,6 @@ let declNames = getMainDeclBinder (unL decl) in case () of _ - -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | t `elem` declATs (unL decl) -> return [] - -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, @@ -651,15 +712,15 @@ -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig - in return [ mkExportDecl t newDecl pats docs_ ] + in availExportDecl avail newDecl docs_ L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - return [ mkExportDecl t - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] + availExportDecl avail + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ - _ -> return [ mkExportDecl t decl pats docs_ ] + _ -> availExportDecl avail decl docs_ -- Declaration from another package ([], _) -> do @@ -675,34 +736,65 @@ Nothing -> do liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] - let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] - return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] + let subs_ = availNoDocs avail + availExportDecl avail decl (noDocForDecl, subs_) Just iface -> - return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + availExportDecl avail decl (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) _ -> return [] + availExportDecl :: AvailInfo -> LHsDecl GhcRn + -> (DocForDecl Name, [(Name, DocForDecl Name)]) + -> ErrMsgGhc [ ExportItem GhcRn ] + availExportDecl avail decl (doc, subs) + | availExportsDecl avail = do + -- bundled pattern synonyms only make sense if the declaration is + -- exported (otherwise there would be nothing to bundle to) + bundledPatSyns <- findBundledPatterns avail - mkExportDecl :: Name -> LHsDecl Name -> [(HsDecl Name, DocForDecl Name)] - -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name - mkExportDecl name decl pats (doc, subs) = decl' - where - decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False - subs' = filter (isExported . fst) subs - pats' = [ d | d@(patsyn_decl, _) <- pats - , all isExported (getMainDeclBinder patsyn_decl) ] - sub_names = map fst subs' - pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl] - fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] + let + patSynNames = + concatMap (getMainDeclBinder . fst) bundledPatSyns + fixities = + [ (n, f) + | n <- availName avail : fmap fst subs ++ patSynNames + , Just f <- [M.lookup n fixMap] + ] + + return [ ExportDecl { + expItemDecl = restrictTo (fmap fst subs) + (extractDecl declMap (availName avail) decl) + , expItemPats = bundledPatSyns + , expItemMbDoc = doc + , expItemSubDocs = subs + , expItemInstances = [] + , expItemFixities = fixities + , expItemSpliced = False + } + ] + + | otherwise = + return [ ExportDecl { + expItemDecl = extractDecl declMap sub decl + , expItemPats = [] + , expItemMbDoc = sub_doc + , expItemSubDocs = [] + , expItemInstances = [] + , expItemFixities = [ (sub, f) | Just f <- [M.lookup sub fixMap] ] + , expItemSpliced = False + } + | (sub, sub_doc) <- subs + ] + exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: Name -> ErrMsgGhc ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) - findDecl n + findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl avail | m == semMod = case M.lookup n declMap of - Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap) + Just ds -> return (ds, lookupDocs avail warnings docMap argMap) Nothing | is_sig -> do -- OK, so it wasn't in the local declaration map. It could @@ -710,57 +802,57 @@ -- from the type. mb_r <- hiDecl dflags n case mb_r of - Nothing -> return ([], (noDocForDecl, [])) + Nothing -> return ([], (noDocForDecl, availNoDocs avail)) -- TODO: If we try harder, we might be able to find -- a Haddock! Look in the Haddocks for each thing in -- requirementContext (pkgState) - Just decl -> return ([decl], (noDocForDecl, [])) + Just decl -> return ([decl], (noDocForDecl, availNoDocs avail)) | otherwise -> - return ([], (noDocForDecl, [])) + return ([], (noDocForDecl, availNoDocs avail)) | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = - return (ds, lookupDocs n warnings + return (ds, lookupDocs avail warnings (ifaceDocMap iface) - (ifaceArgMap iface) - (ifaceSubMap iface)) - | otherwise = return ([], (noDocForDecl, [])) + (ifaceArgMap iface)) + | otherwise = return ([], (noDocForDecl, availNoDocs avail)) where + n = availName avail m = nameModule n - findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl Name, DocForDecl Name)] - findBundledPatterns t = - let - m = nameModule t - - local_bundled_patsyns = - M.findWithDefault [] t patSynMap - - iface_bundled_patsyns - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap - , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface) - = patsyns - - | Just iface <- M.lookup m instIfaceMap - , Just patsyns <- M.lookup t (instBundledPatSynMap iface) - = patsyns - - | otherwise - = [] - - patsyn_decls = do - for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do - -- call declWith here so we don't have to prepare the pattern synonym for - -- showing ourselves. - export_items <- declWith [] patsyn_name + findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns avail = do + patsyns <- for constructor_names $ \name -> do + mtyThing <- liftGhcToErrMsgGhc (lookupName name) + case mtyThing of + Just (AConLike PatSynCon{}) -> do + export_items <- declWith (Avail.avail name) pure [ (unLoc patsyn_decl, patsyn_doc) | ExportDecl { expItemDecl = patsyn_decl , expItemMbDoc = patsyn_doc } <- export_items ] + _ -> pure [] + pure (concat patsyns) + where + constructor_names = + filter isDataConName (availSubordinates avail) - in concat <$> patsyn_decls +-- this heavily depends on the invariants stated in Avail +availExportsDecl :: AvailInfo -> Bool +availExportsDecl (AvailTC ty_name names _) + | n : _ <- names = ty_name == n + | otherwise = False +availExportsDecl _ = True +availSubordinates :: AvailInfo -> [Name] +availSubordinates avail = + filter (/= availName avail) (availNamesWithSelectors avail) + +availNoDocs :: AvailInfo -> [(Name, DocForDecl Name)] +availNoDocs avail = + zip (availSubordinates avail) (repeat noDocForDecl) + -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. semToIdMod :: UnitId -> Module -> Module @@ -768,7 +860,7 @@ | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of @@ -790,7 +882,7 @@ -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) + -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -804,48 +896,29 @@ -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap +lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings docMap argMap subMap = +lookupDocs avail warnings docMap argMap = + let n = availName avail in let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in - let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) + | s <- availSubordinates avail + ] in (doc, subDocs) where lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) --- | Return all export items produced by an exported module. That is, we're --- interested in the exports produced by \"module B\" in such a scenario: --- --- > module A (module B) where --- > import B (...) hiding (...) --- --- There are three different cases to consider: --- --- 1) B is hidden, in which case we return all its exports that are in scope in A. --- 2) B is visible, but not all its exports are in scope in A, in which case we --- only return those that are. --- 3) B is visible and all its exports are in scope, in which case we return --- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A (identity, NOT semantic) - -> ModuleName -- ^ The real name of B, the exported module - -> DynFlags -- ^ The flags used when typechecking A - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment used for A - -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the renamed declarations in A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> Maps - -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | expMod == moduleName thisMod - = fullModuleContents dflags warnings gre maps fixMap splices decls - | otherwise = +-- | Export the given module as `ExportModule`. We are not concerned with the +-- single export items of the given module. +moduleExport :: Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. case M.lookup m ifaceMap of @@ -866,7 +939,6 @@ m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod - -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if @@ -887,124 +959,149 @@ -- | Simplified variant of 'mkExportItems', where we can assume that -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: DynFlags + +fullModuleContents :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> [LHsDecl Name] -- ^ All the renamed declarations - -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSigDecls decls) + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails + -> ErrMsgGhc [ExportItem GhcRn] +fullModuleContents is_sig modMap thisMod semMod warnings gre exportedNames + decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do + let availEnv = availsToNameEnv (nubAvails avails) + (concat . concat) `fmap` (for decls $ \decl -> do + case decl of + (L _ (DocD (DocGroup lev docStr))) -> do + doc <- liftErrMsg (processDocString dflags gre docStr) + return [[ExportGroup lev "" doc]] + (L _ (DocD (DocCommentNamed _ docStr))) -> do + doc <- liftErrMsg (processDocStringParas dflags gre docStr) + return [[ExportDoc doc]] + (L _ (ValD valDecl)) + | name:_ <- collectHsBindBinders valDecl + , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap + -> return [] + _ -> + for (getMainDeclBinder (unLoc decl)) $ \nm -> do + case lookupNameEnv availEnv nm of + Just avail -> + availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags avail + Nothing -> pure []) where - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- - -- We go through the list of declarations and expand type signatures, so - -- that every type signature has exactly one name! - expandSigDecls :: [LHsDecl name] -> [LHsDecl name] - expandSigDecls = concatMap f - where - f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ] - - -- also expand type signatures for class methods - f (L l (TyClD cls@ClassDecl{})) = - [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ] - f x = [x] - - expandLSig :: LSig name -> [LSig name] - expandLSig (L l sig) = [ L l s | s <- expandSig sig ] - - expandSig :: Sig name -> [Sig name] - expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] - expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] - expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ] - expandSig x = [x] - - mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) - mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - return . Just . ExportGroup lev "" $ processDocString dflags gre docStr - mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - return . Just . ExportDoc $ processDocStringParas dflags gre docStr - mkExportItem (L l (ValD d)) - | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = - -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) - | otherwise = return Nothing - mkExportItem decl@(L l (InstD d)) - | Just name <- M.lookup (getInstLoc d) instMap = - expInst decl l name - mkExportItem decl@(L l (DerivD {})) - | Just name <- M.lookup l instMap = - expInst decl l name - mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do - mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name - mkExportItem decl@(L l d) - | name:_ <- getMainDeclBinder d = expDecl decl l name - | otherwise = return Nothing - - fixities name subs = [ (n,f) | n <- name : map fst subs - , Just f <- [M.lookup n fixMap] ] - - expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) - where (doc, subs) = lookupDocs name warnings docMap argMap subMap - - expInst decl l name = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) - + isSigD (L _ SigD{}) = True + isSigD _ = False -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> LHsDecl Name -> LHsDecl Name -extractDecl name decl +extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of TyClD d@ClassDecl {} -> - let matches = [ lsig - | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig - -- Note: exclude `default` declarations (see #505) - , name `elem` sigName lsig - ] + let + matchesMethod = + [ lsig + | lsig <- tcdSigs d + , ClassOpSig False _ _ <- pure $ unLoc lsig + -- Note: exclude `default` declarations (see #505) + , name `elem` sigName lsig + ] + + matchesAssociatedType = + [ lfam_decl + | lfam_decl <- tcdATs d + , name == unLoc (fdLName (unLoc lfam_decl)) + ] + -- TODO: document fixity - in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) - L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) + in case (matchesMethod, matchesAssociatedType) of + ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 + in L pos (SigD sig) + (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + + ([], []) + | Just (famInstDecl:_) <- M.lookup name declMap + -> extractDecl declMap name famInstDecl _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" - O.$$ O.nest 4 (O.ppr matches)) + O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) - InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsIB { hsib_body = tys } - , dfid_defn = defn }) -> + in if isDataConName name + then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + TyClD FamDecl {} + | isValName name + , Just (famInst:_) <- M.lookup name declMap + -> extractDecl declMap name famInst + InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + FamEqn { feqn_tycon = L _ n + , feqn_pats = tys + , feqn_rhs = defn }}))) -> SigD <$> extractRecSel name n tys (dd_cons defn) InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> - let matches = [ d | L _ d <- insts - -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (dfid_defn d)) - , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) - , L _ n <- ns - , selectorFieldOcc n == name + let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) + <- insts + -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) + , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) + , L _ n <- ns + , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Name -> [LHsType Name] -> [LConDecl Name] - -> LSig Name + +extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn nm t tvs cons = + case filter matches cons of + [] -> error "extractPatternSyn: constructor pattern not found" + con:_ -> extract <$> con + where + matches :: LConDecl GhcRn -> Bool + matches (L _ con) = nm `elem` (unLoc <$> getConNames con) + extract :: ConDecl GhcRn -> Sig GhcRn + extract con = + let args = + case getConDetails con of + PrefixCon args' -> args' + RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields + InfixCon arg1 arg2 -> [arg1, arg2] + typ = longArrow args (data_ty con) + typ' = + case con of + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + _ -> typ + typ'' = noLoc (HsQualTy (noLoc []) typ') + in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + + longArrow :: [LHsType name] -> LHsType name -> LHsType name + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs + + data_ty con + | ConDeclGADT{} <- con = hsib_body $ con_type con + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + +extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] + -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -1013,7 +1110,7 @@ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where - matching_fields :: [LConDeclField Name] -> [(SrcSpan, LConDeclField Name)] + matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty @@ -1022,15 +1119,15 @@ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. -pruneExportItems :: [ExportItem Name] -> [ExportItem Name] +pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts +mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns @@ -1049,12 +1146,12 @@ seqList [] = () seqList (x : xs) = x `seq` seqList xs -mkMaybeTokenizedSrc :: [Flag] -> TypecheckedModule +mkMaybeTokenizedSrc :: DynFlags -> [Flag] -> TypecheckedModule -> ErrMsgGhc (Maybe [RichToken]) -mkMaybeTokenizedSrc flags tm +mkMaybeTokenizedSrc dflags flags tm | Flag_HyperlinkedSource `elem` flags = case renamedSource tm of Just src -> do - tokens <- liftGhcToErrMsgGhc . liftIO $ mkTokenizedSrc summary src + tokens <- liftGhcToErrMsgGhc (liftIO (mkTokenizedSrc dflags summary src)) return $ Just tokens Nothing -> do liftErrMsg . tell . pure $ concat @@ -1067,15 +1164,18 @@ where summary = pm_mod_summary . tm_parsed_module $ tm -mkTokenizedSrc :: ModSummary -> RenamedSource -> IO [RichToken] -mkTokenizedSrc ms src = do +mkTokenizedSrc :: DynFlags -> ModSummary -> RenamedSource -> IO [RichToken] +mkTokenizedSrc dflags ms src = do -- make sure to read the whole file at once otherwise -- we run out of file descriptors (see #495) rawSrc <- BS.readFile (msHsFilePath ms) >>= evaluate - return $ Hyperlinker.enrich src (Hyperlinker.parse (decodeUtf8 rawSrc)) + let tokens = Hyperlinker.parse dflags filepath (Utf8.decodeUtf8 rawSrc) + return $ Hyperlinker.enrich src tokens + where + filepath = msHsFilePath ms -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do diff --git a/src/Haddock/Interface/Json.hs b/src/Haddock/Interface/Json.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Interface/Json.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE RecordWildCards #-} +module Haddock.Interface.Json ( + jsonInstalledInterface + , jsonInterfaceFile + , renderJson + ) where + +import BasicTypes +import Json +import Module +import Name +import Outputable + +import Control.Arrow +import Data.Map (Map) +import Data.Bifunctor +import qualified Data.Map as Map + +import Haddock.Types +import Haddock.InterfaceFile + +jsonInterfaceFile :: InterfaceFile -> JsonDoc +jsonInterfaceFile InterfaceFile{..} = + jsonObject [ ("link_env" , jsonMap nameStableString (jsonString . moduleNameString . moduleName) ifLinkEnv) + , ("inst_ifaces", jsonArray (map jsonInstalledInterface ifInstalledIfaces)) + ] + +jsonInstalledInterface :: InstalledInterface -> JsonDoc +jsonInstalledInterface InstalledInterface{..} = jsonObject properties + where + properties = + [ ("module" , jsonModule instMod) + , ("is_sig" , jsonBool instIsSig) + , ("info" , jsonHaddockModInfo instInfo) + , ("doc_map" , jsonMap nameStableString jsonMDoc instDocMap) + , ("arg_map" , jsonMap nameStableString (jsonMap show jsonMDoc) instArgMap) + , ("exports" , jsonArray (map jsonName instExports)) + , ("visible_exports" , jsonArray (map jsonName instVisibleExports)) + , ("options" , jsonArray (map (jsonString . show) instOptions)) + , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap) + ] + +jsonHaddockModInfo :: HaddockModInfo Name -> JsonDoc +jsonHaddockModInfo HaddockModInfo{..} = + jsonObject [ ("description" , jsonMaybe jsonDoc hmi_description) + , ("copyright" , jsonMaybe jsonString hmi_copyright) + , ("maintainer" , jsonMaybe jsonString hmi_maintainer) + , ("stability" , jsonMaybe jsonString hmi_stability) + , ("protability" , jsonMaybe jsonString hmi_portability) + , ("safety" , jsonMaybe jsonString hmi_safety) + , ("language" , jsonMaybe (jsonString . show) hmi_language) + , ("extensions" , jsonArray (map (jsonString . show) hmi_extensions)) + ] + +jsonMap :: (a -> String) -> (b -> JsonDoc) -> Map a b -> JsonDoc +jsonMap f g = jsonObject . map (f *** g) . Map.toList + +jsonMDoc :: MDoc Name -> JsonDoc +jsonMDoc MetaDoc{..} = + jsonObject [ ("meta", jsonObject [("version", jsonMaybe (jsonString . show) (_version _meta))]) + , ("doc", jsonDoc _doc) + ] + +jsonDoc :: Doc Name -> JsonDoc +jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) + +jsonModule :: Module -> JsonDoc +jsonModule = JSString . moduleStableString + +jsonName :: Name -> JsonDoc +jsonName = JSString . nameStableString + +jsonFixity :: Fixity -> JsonDoc +jsonFixity (Fixity _ prec dir) = + jsonObject [ ("prec" , jsonInt prec) + , ("direction" , jsonFixityDirection dir) + ] + +jsonFixityDirection :: FixityDirection -> JsonDoc +jsonFixityDirection InfixL = jsonString "infixl" +jsonFixityDirection InfixR = jsonString "infixr" +jsonFixityDirection InfixN = jsonString "infix" + +renderJson :: JsonDoc -> SDoc +renderJson = renderJSON + +jsonMaybe :: (a -> JsonDoc) -> Maybe a -> JsonDoc +jsonMaybe = maybe jsonNull + +jsonString :: String -> JsonDoc +jsonString = JSString + +jsonObject :: [(String, JsonDoc)] -> JsonDoc +jsonObject = JSObject + +jsonArray :: [JsonDoc] -> JsonDoc +jsonArray = JSArray + +jsonNull :: JsonDoc +jsonNull = JSNull + +jsonInt :: Int -> JsonDoc +jsonInt = JSInt + +jsonBool :: Bool -> JsonDoc +jsonBool = JSBool diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -18,7 +18,6 @@ , processModuleHeader ) where -import Data.IntSet (toList) import Data.List import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) @@ -31,23 +30,25 @@ import Name import Outputable ( showPpr ) import RdrName +import EnumSet import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] - -> Maybe (MDoc Name) -processDocStrings dflags gre strs = - case metaDocConcat $ map (processDocStringParas dflags gre) strs of + -> ErrMsgM (Maybe (MDoc Name)) +processDocStrings dflags gre strs = do + mdoc <- metaDocConcat <$> traverse (processDocStringParas dflags gre) strs + case mdoc of -- We check that we don't have any version info to render instead -- of just checking if there is no comment: there may not be a -- comment but we still want to pass through any meta data. - MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing - x -> Just x + MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> pure Nothing + x -> pure (Just x) -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags gre (HsDocString fs) = - overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) + overDocF (rename dflags gre) $ parseParas dflags (unpackFS fs) -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre (HsDocString fs) = rename dflags gre $ parseString dflags (unpackFS fs) @@ -60,14 +61,16 @@ Just (L _ (HsDocString fs)) -> do let str = unpackFS fs (hmi, doc) = parseModuleHeader dflags str - !descr = rename dflags gre <$> hmi_description hmi - hmi' = hmi { hmi_description = descr } - doc' = overDoc (rename dflags gre) doc + !descr <- case hmi_description hmi of + Just hmi_descr -> Just <$> rename dflags gre hmi_descr + Nothing -> pure Nothing + let hmi' = hmi { hmi_description = descr } + doc' <- overDocF (rename dflags gre) doc return (hmi', Just doc') let flags :: [LangExt.Extension] -- We remove the flags implied by the language setting and we display the language instead - flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) + flags = EnumSet.toList (extensionFlags dflags) \\ languageExtensions (language dflags) return (hmi { hmi_safety = Just $ showPpr dflags safety , hmi_language = language dflags , hmi_extensions = flags @@ -82,12 +85,12 @@ -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) + DocAppend a b -> DocAppend <$> rn a <*> rn b + DocParagraph doc -> DocParagraph <$> rn doc DocIdentifier x -> do -- Generate the choices for the possible kind of thing this -- is. @@ -100,7 +103,7 @@ -- We found no names in the env so we start guessing. [] -> case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) + [] -> pure (DocMonospaced (DocString (showPpr dflags x))) -- There was nothing in the environment so we need to -- pick some default from what's available to us. We -- diverge here from the old way where we would default @@ -109,37 +112,38 @@ -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> pure (outOfScope dflags a) -- There is only one name in the environment that matches so -- use it. - [a] -> DocIdentifier a + [a] -> pure (DocIdentifier a) -- But when there are multiple names available, default to -- type constructors: somewhat awfully GHC returns the -- values in the list positionally. - a:b:_ | isTyConName a -> DocIdentifier a - | otherwise -> DocIdentifier b + a:b:_ | isTyConName a -> pure (DocIdentifier a) + | otherwise -> pure (DocIdentifier b) - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule str -> DocModule str - DocHyperlink l -> DocHyperlink l - DocPic str -> DocPic str - DocMathInline str -> DocMathInline str - DocMathDisplay str -> DocMathDisplay str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) + DocWarning doc -> DocWarning <$> rn doc + DocEmphasis doc -> DocEmphasis <$> rn doc + DocBold doc -> DocBold <$> rn doc + DocMonospaced doc -> DocMonospaced <$> rn doc + DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs + DocOrderedList docs -> DocOrderedList <$> traverse rn docs + DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list + DocCodeBlock doc -> DocCodeBlock <$> rn doc + DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) + DocModule str -> pure (DocModule str) + DocHyperlink l -> pure (DocHyperlink l) + DocPic str -> pure (DocPic str) + DocMathInline str -> pure (DocMathInline str) + DocMathDisplay str -> pure (DocMathDisplay str) + DocAName str -> pure (DocAName str) + DocProperty p -> pure (DocProperty p) + DocExamples e -> pure (DocExamples e) + DocEmpty -> pure (DocEmpty) + DocString str -> pure (DocString str) + DocHeader (Header l t) -> DocHeader . Header l <$> rn t + DocTable t -> DocTable <$> traverse rn t -- | Wrap an identifier that's out of scope (i.e. wasn't found in -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -37,21 +37,22 @@ (copyrightOpt,str3) = getKey "Copyright" str2 (licenseOpt,str4) = getKey "License" str3 (licenceOpt,str5) = getKey "Licence" str4 - (maintainerOpt,str6) = getKey "Maintainer" str5 - (stabilityOpt,str7) = getKey "Stability" str6 - (portabilityOpt,str8) = getKey "Portability" str7 + (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 + (maintainerOpt,str7) = getKey "Maintainer" str6 + (stabilityOpt,str8) = getKey "Stability" str7 + (portabilityOpt,str9) = getKey "Portability" str8 in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags str8) + }, parseParas dflags str9) -- | This function is how we read keys. -- diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -21,6 +21,8 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name +import RdrName (RdrName(Exact)) +import PrelNames (eqTyCon_RDR) import Control.Applicative import Control.Monad hiding (mapM) @@ -59,11 +61,18 @@ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4 ++ missingNames5) - -- filter out certain built in type constructors using their string - -- representation. TODO: use the Name constants from the GHC API. --- strings = filter (`notElem` ["()", "[]", "(->)"]) --- (map pretty missingNames) - strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + -- Filter out certain built in type constructors using their string + -- representation. + -- + -- Note that since the renamed AST represents equality constraints as + -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to + -- manually filter out 'eqTyCon_RDR' (aka @~@). + strings = [ pretty dflags n + | n <- missingNames + , not (isSystemName n) + , not (isBuiltInSyntax n) + , Exact n /= eqTyCon_RDR + ] in do -- report things that we couldn't link to. Only do this for non-hidden @@ -147,7 +156,7 @@ renameL = mapM rename -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] +renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -172,22 +181,22 @@ renameFnArgsDoc = mapM renameDoc -renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType Name -> RnM (LHsSigType DocName) +renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType -renameLSigWcType :: LHsSigWcType Name -> RnM (LHsSigWcType DocName) +renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) renameLSigWcType = renameWc (renameImplicit renameLType) -renameLKind :: LHsKind Name -> RnM (LHsKind DocName) +renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig Name -> RnM (LFamilyResultSig DocName) +renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc NoSig) = return (L loc NoSig) renameFamilyResultSig (L loc (KindSig ki)) @@ -197,17 +206,17 @@ = do { bndr' <- renameLTyVarBndr bndr ; return (L loc (TyVarSig bndr')) } -renameInjectivityAnn :: LInjectivityAnn Name -> RnM (LInjectivityAnn DocName) +renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) = do { lhs' <- renameL lhs ; rhs' <- mapM renameL rhs ; return (L loc (InjectivityAnn lhs' rhs')) } -renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn Name) - -> RnM (Maybe (LInjectivityAnn DocName)) +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) + -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType Name -> RnM (HsType DocName) +renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars @@ -264,17 +273,28 @@ HsCoreTy a -> pure (HsCoreTy a) HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsSpliceTy s _ -> renameHsSpliceTy s HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a HsAppsTy _ -> error "renameType: HsAppsTy" -renameLHsQTyVars :: LHsQTyVars Name -> RnM (LHsQTyVars DocName) +-- | Rename splices, but _only_ those that turn out to be for types. +-- I think this is actually safe for our possible inputs: +-- +-- * the input is from after GHC's renamer, so should have an 'HsSpliced' +-- * the input is typechecked, and only 'HsSplicedTy' should get through that +-- +renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI) +renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t +renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy" +renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced" + +renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } -- This is rather bogus, but I'm not sure what else to do -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) +renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n ; return (L loc (UserTyVar (L l n'))) } @@ -283,18 +303,17 @@ ; kind' <- renameLKind kind ; return (L loc (KindedTyVar (L lv n') kind')) } -renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) +renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) +renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name -renameInstHead :: InstHead Name -> RnM (InstHead DocName) +renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName - kinds <- mapM renameType ihdKinds types <- mapM renameType ihdTypes itype <- case ihdInstType of ClassInst { .. } -> ClassInst @@ -306,21 +325,20 @@ DataInst dd -> DataInst <$> renameTyClD dd return InstHead { ihdClsName = cname - , ihdKinds = kinds , ihdTypes = types , ihdInstType = itype } -renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) +renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renamePats :: [(HsDecl Name,DocForDecl Name)] -> RnM [(HsDecl DocName,DocForDecl DocName)] +renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)] renamePats = mapM (\(d,doc) -> do { d' <- renameDecl d ; doc' <- renameDocForDecl doc ; return (d',doc')}) -renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d @@ -339,10 +357,10 @@ return (DerivD d') _ -> error "renameDecl" -renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) renameLThing fn (L loc x) = return . L loc =<< fn x -renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) +renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do @@ -384,7 +402,7 @@ renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars , fdFixity = fixity @@ -402,8 +420,8 @@ , fdInjectivityAnn = injectivity' }) -renamePseudoFamilyDecl :: PseudoFamilyDecl Name - -> RnM (PseudoFamilyDecl DocName) +renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn + -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo <*> renameL pfdLName @@ -411,14 +429,14 @@ <*> renameFamilyResultSig pfdKindSig -renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) +renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns + = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) +renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- renameLContext lcontext @@ -429,7 +447,7 @@ , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_doc = mbldoc }) = do @@ -460,19 +478,19 @@ return (decl { con_names = lnames' , con_type = lty', con_doc = mbldoc' }) -renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName) +renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') -renameLFieldOcc :: LFieldOcc Name -> RnM (LFieldOcc DocName) +renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc lbl sel)) = do sel' <- rename sel return $ L l (FieldOcc lbl sel') -renameSig :: Sig Name -> RnM (Sig DocName) +renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames @@ -496,7 +514,7 @@ _ -> error "expected TypeSig" -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) +renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLSigType ltype @@ -507,7 +525,7 @@ return (ForeignExport lname' ltype' co x) -renameInstD :: InstDecl Name -> RnM (InstDecl DocName) +renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d return (ClsInstD { cid_inst = d' }) @@ -518,7 +536,7 @@ d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) -renameDerivD :: DerivDecl Name -> RnM (DerivDecl DocName) +renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do @@ -527,7 +545,7 @@ , deriv_strategy = strat , deriv_overlap_mode = omode }) -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) +renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do @@ -540,45 +558,60 @@ , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) +renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn' <- renameLTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' - , tfid_fvs = placeHolderNames }) } + = do { eqn' <- renameTyFamInstEqn eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' }) } -renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName) -renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs })) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = pats' - , tfe_fixity = fixity - , tfe_rhs = rhs' })) } +renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI) +renameTyFamInstEqn eqn + = renameImplicit rename_ty_fam_eqn eqn + where + rename_ty_fam_eqn + :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) + -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI)) + rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = rhs }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; rhs' <- renameLType rhs + ; return (FamEqn { feqn_tycon = tc' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) } -renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName) -renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) +renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) +renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs + , feqn_fixity = fixity, feqn_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs - ; return (L loc (TyFamEqn { tfe_tycon = tc' - , tfe_pats = tvs' - , tfe_fixity = fixity - , tfe_rhs = rhs' })) } + ; return (L loc (FamEqn { feqn_tycon = tc' + , feqn_pats = tvs' + , feqn_fixity = fixity + , feqn_rhs = rhs' })) } -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) - = do { tc' <- renameL tc - ; pats' <- renameImplicit (mapM renameLType) pats - ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc' - , dfid_pats = pats' - , dfid_fixity = fixity - , dfid_defn = defn', dfid_fvs = placeHolderNames }) } +renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) +renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) + = do { eqn' <- renameImplicit rename_data_fam_eqn eqn + ; return (DataFamInstDecl { dfid_eqn = eqn' }) } + where + rename_data_fam_eqn + :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) + -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI)) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType pats + ; defn' <- renameDataDefn defn + ; return (FamEqn { feqn_tycon = tc' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = defn' }) } renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs Name in_thing - -> RnM (HsImplicitBndrs DocName out_thing) + -> HsImplicitBndrs GhcRn in_thing + -> RnM (HsImplicitBndrs DocNameI out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' @@ -586,21 +619,21 @@ , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildCardBndrs Name in_thing - -> RnM (HsWildCardBndrs DocName out_thing) + -> HsWildCardBndrs GhcRn in_thing + -> RnM (HsWildCardBndrs DocNameI out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' , hswc_wcs = PlaceHolder }) } -renameDocInstance :: DocInstance Name -> RnM (DocInstance DocName) +renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do inst' <- renameInstHead inst n' <- rename n idoc' <- mapM renameDoc idoc return (inst', idoc',L l n') -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) +renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) ExportGroup lev id_ doc -> do diff --git a/src/Haddock/Interface/Specialize.hs b/src/Haddock/Interface/Specialize.hs --- a/src/Haddock/Interface/Specialize.hs +++ b/src/Haddock/Interface/Specialize.hs @@ -17,7 +17,6 @@ import FastString import Control.Monad -import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.Data @@ -29,27 +28,33 @@ import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: forall name a. (Ord name, DataId name, NamedThing name) +specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) => Data a - => [(name, HsType name)] -> a -> a -specialize specs = go + => [(IdP name, HsType name)] -> a -> a +specialize specs = go spec_map0 where - go :: forall x. Data x => x -> x - go = everywhereButType @name $ mkT $ sugar . specialize_ty_var - specialize_ty_var (HsTyVar _ (L _ name')) + go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x + go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map + + strip_kind_sig :: HsType name -> HsType name + strip_kind_sig (HsKindSig (L _ t) _) = t + strip_kind_sig typ = typ + + specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name + specialize_ty_var spec_map (HsTyVar _ (L _ name')) | Just t <- Map.lookup name' spec_map = t - specialize_ty_var typ = typ - -- This is a tricky recursive definition that is guaranteed to terminate - -- because a type binder cannot be instantiated with a type that depends - -- on that binder. i.e. @a -> Maybe a@ is invalid - spec_map = Map.fromList [ (n, go t) | (n, t) <- specs] + specialize_ty_var _ typ = typ + -- This is a tricky recursive definition. By adding in the specializations + -- one by one, we should avoid infinite loops. + spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs + -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Ord name, DataId name, NamedThing name) +specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name)) => Data a => LHsQTyVars name -> [HsType name] -> a -> a @@ -61,14 +66,14 @@ bname (KindedTyVar (L _ name) _) = name -specializePseudoFamilyDecl :: (Ord name, DataId name, NamedThing name) +specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) => LHsQTyVars name -> [HsType name] -> PseudoFamilyDecl name -> PseudoFamilyDecl name specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord name, DataId name, SetName name, NamedThing name) +specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) => LHsQTyVars name -> [HsType name] -> Sig name -> Sig name @@ -85,7 +90,7 @@ -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Ord name, DataId name, SetName name, NamedThing name) +specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) => InstHead name -> InstHead name specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } @@ -105,11 +110,11 @@ -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing name, DataId name) +sugar :: forall name. (NamedThing (IdP name), DataId name) => HsType name -> HsType name sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists :: NamedThing (IdP name) => HsType name -> HsType name sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp where @@ -118,7 +123,7 @@ sugarLists typ = typ -sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name sugarTuples typ = aux [] typ where @@ -135,7 +140,7 @@ aux _ _ = typ -sugarOperators :: NamedThing name => HsType name -> HsType name +sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb @@ -203,8 +208,8 @@ -- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing name, DataId name) - => HsType name -> Set NameRep +freeVariables :: forall name. (NamedThing (IdP name), DataId name) + => HsType name -> Set Name freeVariables = everythingWithState Set.empty Set.union query where @@ -213,7 +218,7 @@ (Set.empty, Set.union ctx (bndrsNames bndrs)) Just (HsTyVar _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) - | otherwise -> (Set.singleton $ getNameRep name, ctx) + | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) @@ -225,33 +230,36 @@ -- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something --- like @(a -> c) -> b@). -rename :: SetName name => Set NameRep -> HsType name -> HsType name -rename fv typ = runReader (renameType typ) $ RenameEnv - { rneFV = fv - , rneCtx = Map.empty - } - +-- like @(a -> b0) -> b@). +rename :: (Eq (IdP name), DataId name, SetName (IdP name)) + => Set Name-> HsType name -> HsType name +rename fv typ = evalState (renameType typ) env + where + env = RenameEnv + { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv + , rneSigFVs = Set.map getNameRep $ freeVariables typ + , rneCtx = Map.empty + } + mkPair name = (getNameRep name, name) -- | Renaming monad. -type Rename name = Reader (RenameEnv name) - --- | Binding generation monad. -type Rebind name = State (RenameEnv name) +type Rename name = State (RenameEnv name) data RenameEnv name = RenameEnv - { rneFV :: Set NameRep - , rneCtx :: Map Name name - } + { rneHeadFVs :: Map NameRep Name + , rneSigFVs :: Set NameRep + , rneCtx :: Map Name name + } -renameType :: SetName name => HsType name -> Rename name (HsType name) -renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' -> +renameType :: (Eq (IdP name), SetName (IdP name)) + => HsType name -> Rename (IdP name) (HsType name) +renameType (HsForAllTy bndrs lt) = HsForAllTy - <$> pure bndrs' + <$> mapM (located renameBinder) bndrs <*> renameLType lt renameType (HsQualTy lctxt lt) = - HsQualTy + HsQualTy <$> located renameContext lctxt <*> renameLType lt renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name @@ -281,85 +289,58 @@ renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" -renameLType :: SetName name => LHsType name -> Rename name (LHsType name) +renameLType :: (Eq (IdP name), SetName (IdP name)) + => LHsType name -> Rename (IdP name) (LHsType name) renameLType = located renameType -renameLTypes :: SetName name => [LHsType name] -> Rename name [LHsType name] +renameLTypes :: (Eq (IdP name), SetName (IdP name)) + => [LHsType name] -> Rename (IdP name) [LHsType name] renameLTypes = mapM renameLType -renameContext :: SetName name => HsContext name -> Rename name (HsContext name) +renameContext :: (Eq (IdP name), SetName (IdP name)) + => HsContext name -> Rename (IdP name) (HsContext name) renameContext = renameLTypes -{- -renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name) -renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname --} +renameBinder :: (Eq (IdP name), SetName (IdP name)) + => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) +renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname +renameBinder (KindedTyVar lname lkind) = + KindedTyVar <$> located renameName lname <*> located renameType lkind -renameName :: SetName name => name -> Rename name name +-- | Core renaming logic. +renameName :: (Eq name, SetName name) => name -> Rename name name renameName name = do - RenameEnv { rneCtx = ctx } <- ask - pure $ fromMaybe name (Map.lookup (getName name) ctx) - - -rebind :: SetName name - => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a) - -> Rename name a -rebind lbndrs action = do - (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask - local (const env') (action lbndrs') - - -rebindLTyVarBndrs :: SetName name - => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name] -rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs - - -rebindTyVarBndr :: SetName name - => HsTyVarBndr name -> Rebind name (HsTyVarBndr name) -rebindTyVarBndr (UserTyVar (L l name)) = - UserTyVar . L l <$> rebindName name -rebindTyVarBndr (KindedTyVar name kinds) = - KindedTyVar <$> located rebindName name <*> pure kinds - - -rebindName :: SetName name => name -> Rebind name name -rebindName name = do RenameEnv { .. } <- get - taken <- takenNames case Map.lookup (getName name) rneCtx of - Just name' -> pure name' - Nothing | getNameRep name `Set.member` taken -> freshName name - Nothing -> reuseName name + Nothing + | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs + , headTv /= getName name -> freshName name + Just name' -> return name' + _ -> return name -- | Generate fresh occurrence name, put it into context and return. -freshName :: SetName name => name -> Rebind name name +freshName :: SetName name => name -> Rename name name freshName name = do - env@RenameEnv { .. } <- get taken <- takenNames let name' = setInternalNameRep (findFreshName taken rep) name - put $ env { rneCtx = Map.insert nname name' rneCtx } + modify $ \rne -> rne + { rneCtx = Map.insert (getName name) name' (rneCtx rne) } return name' where nname = getName name rep = getNameRep nname -reuseName :: SetName name => name -> Rebind name name -reuseName name = do - env@RenameEnv { .. } <- get - put $ env { rneCtx = Map.insert (getName name) name rneCtx } - return name - - -takenNames :: NamedThing name => Rebind name (Set NameRep) +takenNames :: NamedThing name => Rename name (Set NameRep) takenNames = do RenameEnv { .. } <- get - return $ Set.union rneFV (ctxElems rneCtx) + return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx] where + headReps = Set.fromList . Map.keys ctxElems = Set.fromList . map getNameRep . Map.elems @@ -371,15 +352,7 @@ alternativeNames :: NameRep -> [NameRep] -alternativeNames name - | [_] <- nameRepString name = letterNames ++ alternativeNames' name - where - letterNames = map (stringNameRep . pure) ['a'..'z'] -alternativeNames name = alternativeNames' name - - -alternativeNames' :: NameRep -> [NameRep] -alternativeNames' name = +alternativeNames name = [ stringNameRep $ str ++ show i | i :: Int <- [0..] ] where str = nameRepString name @@ -389,6 +362,6 @@ located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> name +tyVarName :: HsTyVarBndr name -> IdP name tyVarName (UserTyVar name) = unLoc name tyVarName (KindedTyVar (L _ name) _) = name diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -82,8 +82,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 802) && (__GLASGOW_HASKELL__ < 804) -binaryInterfaceVersion = 31 +#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) +binaryInterfaceVersion = 32 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -158,7 +158,7 @@ type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: NameCacheAccessor Ghc +nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do @@ -373,7 +373,7 @@ instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap patSynMap fixMap) = do + exps visExps opts fixMap) = do put_ bh modu put_ bh is_sig put_ bh info @@ -381,8 +381,6 @@ put_ bh exps put_ bh visExps put_ bh opts - put_ bh subMap - put_ bh patSynMap put_ bh fixMap get bh = do @@ -393,12 +391,9 @@ exps <- get bh visExps <- get bh opts <- get bh - subMap <- get bh - patSynMap <- get bh fixMap <- get bh - return (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap patSynMap fixMap) + exps visExps opts fixMap) instance Binary DocOption where @@ -464,6 +459,32 @@ t <- get bh return (Header l t) +instance Binary a => Binary (Table a) where + put_ bh (Table h b) = do + put_ bh h + put_ bh b + get bh = do + h <- get bh + b <- get bh + return (Table h b) + +instance Binary a => Binary (TableRow a) where + put_ bh (TableRow cs) = put_ bh cs + get bh = do + cs <- get bh + return (TableRow cs) + +instance Binary a => Binary (TableCell a) where + put_ bh (TableCell i j c) = do + put_ bh i + put_ bh j + put_ bh c + get bh = do + i <- get bh + j <- get bh + c <- get bh + return (TableCell i j c) + instance Binary Meta where put_ bh Meta { _version = v } = put_ bh v get bh = (\v -> Meta { _version = v }) <$> get bh @@ -547,6 +568,9 @@ put_ bh (DocMathDisplay x) = do putByte bh 22 put_ bh x + put_ bh (DocTable x) = do + putByte bh 23 + put_ bh x get bh = do h <- getByte bh @@ -620,6 +644,9 @@ 22 -> do x <- get bh return (DocMathDisplay x) + 23 -> do + x <- get bh + return (DocTable x) _ -> error "invalid binary data found in the interface file" diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -20,39 +20,41 @@ import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) +import qualified Control.Applicative as A -data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] +data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] + mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing - fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short -addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ _ ts = ts -addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short -addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts +addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ _ ts = ts +addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short +addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) m pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ _ = [] -mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] -mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] +mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ _ = [] +mkSubTree [s] m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []] +mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)] splitModule :: Module -> [String] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -25,11 +25,13 @@ sourceUrls, wikiUrls, optDumpInterfaceFile, + optShowInterfaceFile, optLaTeXStyle, optMathjax, qualification, verbosity, ghcFlags, + reexportFlags, readIfaceArgs, optPackageName, optPackageVersion @@ -53,6 +55,7 @@ -- | Flag_DocBook | Flag_ReadInterface String | Flag_DumpInterface String + | Flag_ShowInterface String | Flag_Heading String | Flag_Html | Flag_Hoogle @@ -68,6 +71,7 @@ | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String + | Flag_QuickJumpIndex | Flag_HyperlinkedSource | Flag_SourceCss String | Flag_Mathjax String @@ -82,6 +86,8 @@ | Flag_GenIndex | Flag_IgnoreAllExports | Flag_HideModule String + | Flag_ShowModule String + | Flag_ShowAllModules | Flag_ShowExtensions String | Flag_OptGhc String | Flag_GhcLibDir String @@ -96,6 +102,7 @@ | Flag_NoPrintMissingDocs | Flag_PackageName String | Flag_PackageVersion String + | Flag_Reexport String deriving (Eq, Show) @@ -112,6 +119,8 @@ "read an interface from FILE", Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") "write the resulting interface to FILE", + Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE") + "print the interface in a human readable form", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) @@ -122,6 +131,8 @@ Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle; you may want --package-name and --package-version too", + Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex) + "generate an index for interactive documentation navigation", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") @@ -173,6 +184,10 @@ "behave as if all modules have the\nignore-exports atribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", + Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") + "behave as if MODULE does not have the hide attribute", + Option [] ["show-all"] (NoArg Flag_ShowAllModules) + "behave as if not modules have the hide attribute", Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE") "behave as if MODULE has the show-extensions attribute", Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") @@ -190,6 +205,8 @@ "generate html with newlines and indenting (for use with --html)", Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) "don't print information about any undocumented entities", + Option [] ["reexport"] (ReqArg Flag_Reexport "MOD") + "reexport the module MOD, adding it to the index", Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") @@ -270,6 +287,8 @@ optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] +optShowInterfaceFile :: [Flag] -> Maybe FilePath +optShowInterfaceFile flags = optLast [ str | Flag_ShowInterface str <- flags ] optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] @@ -303,6 +322,9 @@ ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] + +reexportFlags :: [Flag] -> [String] +reexportFlags flags = [ option | Flag_Reexport option <- flags ] readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module GHC.PlaceHolder - {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -59,7 +57,7 @@ type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl Name] +type DeclMap = Map Name [LHsDecl GhcRn] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -101,10 +99,7 @@ -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl Name]) - - -- | Bundled pattern synonym declarations for specific types. - , ifaceBundledPatSynMap :: !(Map Name [Name]) + , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) -- | Documentation of declarations originating from the module (including -- subordinates). @@ -116,11 +111,10 @@ , ifaceRnDocMap :: !(DocMap DocName) , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: ![ExportItem DocName] + , ifaceExportItems :: ![ExportItem GhcRn] + , ifaceRnExportItems :: ![ExportItem DocNameI] -- | All names exported by the module. , ifaceExports :: ![Name] @@ -138,8 +132,8 @@ , ifaceFamInstances :: ![FamInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance Name] - , ifaceRnOrphanInstances :: ![DocInstance DocName] + , ifaceOrphanInstances :: ![DocInstance GhcRn] + , ifaceRnOrphanInstances :: ![DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. @@ -186,10 +180,6 @@ -- | Haddock options for this module (prune, ignore-exports, etc). , instOptions :: [DocOption] - , instSubMap :: Map Name [Name] - - , instBundledPatSynMap :: Map Name [Name] - , instFixMap :: Map Name Fixity } @@ -205,8 +195,6 @@ , instExports = ifaceExports interface , instVisibleExports = ifaceVisibleExports interface , instOptions = ifaceOptions interface - , instSubMap = ifaceSubMap interface - , instBundledPatSynMap = ifaceBundledPatSynMap interface , instFixMap = ifaceFixMap interface } @@ -225,21 +213,21 @@ expItemDecl :: !(LHsDecl name) -- | Bundled patterns for a data type declaration - , expItemPats :: ![(HsDecl name, DocForDecl name)] + , expItemPats :: ![(HsDecl name, DocForDecl (IdP name))] -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). - , expItemMbDoc :: !(DocForDecl name) + , expItemMbDoc :: !(DocForDecl (IdP name)) -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: ![(name, DocForDecl name)] + , expItemSubDocs :: ![(IdP name, DocForDecl (IdP name))] -- | Instances relevant to this declaration, possibly with -- documentation. , expItemInstances :: ![DocInstance name] -- | Fixity decls relevant to this declaration (including subordinates). - , expItemFixities :: ![(name, Fixity)] + , expItemFixities :: ![(IdP name, Fixity)] -- | Whether the ExportItem is from a TH splice or not, for generating -- the appropriate type of Source link. @@ -249,10 +237,10 @@ -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl - { expItemName :: !name + { expItemName :: !(IdP name) -- | Subordinate names. - , expItemSubs :: ![name] + , expItemSubs :: ![IdP name] } -- | A section heading. @@ -265,11 +253,11 @@ , expItemSectionId :: !String -- | Section heading text. - , expItemSectionText :: !(Doc name) + , expItemSectionText :: !(Doc (IdP name)) } -- | Some documentation. - | ExportDoc !(MDoc name) + | ExportDoc !(MDoc (IdP name)) -- | A cross-reference to another module. | ExportModule !Module @@ -309,15 +297,11 @@ -- documentation, as far as Haddock knows. deriving (Eq, Data) -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName [Name] = PlaceHolder +data DocNameI -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder +type instance IdP DocNameI = DocName + instance NamedThing DocName where getName (Documented name _) = name getName (Undocumented name) = name @@ -363,7 +347,7 @@ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (OutputableBndrId a) +instance (SourceTextX a, OutputableBndrId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx @@ -382,7 +366,7 @@ -- 'PseudoFamilyDecl' type is introduced. data PseudoFamilyDecl name = PseudoFamilyDecl { pfdInfo :: FamilyInfo name - , pfdLName :: Located name + , pfdLName :: Located (IdP name) , pfdTyVars :: [LHsType name] , pfdKindSig :: LFamilyResultSig name } @@ -404,13 +388,12 @@ -- | An instance head that may have documentation and a source location. -type DocInstance name = (InstHead name, Maybe (MDoc name), Located name) +type DocInstance name = (InstHead name, Maybe (MDoc (IdP name)), Located (IdP name)) --- | The head of an instance. Consists of a class name, a list of kind --- parameters, a list of type parameters and an instance type +-- | The head of an instance. Consists of a class name, a list of type +-- parameters (which may be annotated with kinds), and an instance type data InstHead name = InstHead - { ihdClsName :: name - , ihdKinds :: [HsType name] + { ihdClsName :: IdP name , ihdTypes :: [HsType name] , ihdInstType :: InstType name } @@ -443,6 +426,8 @@ type Doc id = DocH (ModuleName, OccName) id type MDoc id = MetaDoc (ModuleName, OccName) id +type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a + instance (NFData a, NFData mod) => NFData (DocH mod a) where rnf doc = case doc of @@ -469,6 +454,7 @@ DocProperty a -> a `deepseq` () DocExamples a -> a `deepseq` () DocHeader a -> a `deepseq` () + DocTable a -> a `deepseq` () #if !MIN_VERSION_ghc(8,0,2) -- These were added to GHC itself in 8.0.2 @@ -489,39 +475,19 @@ instance NFData Example where rnf (Example a b) = a `deepseq` b `deepseq` () +instance NFData id => NFData (Table id) where + rnf (Table h b) = h `deepseq` b `deepseq` () +instance NFData id => NFData (TableRow id) where + rnf (TableRow cs) = cs `deepseq` () + +instance NFData id => NFData (TableCell id) where + rnf (TableCell i j c) = i `deepseq` j `deepseq` c `deepseq` () + exampleToString :: Example -> String exampleToString (Example expression result) = ">>> " ++ expression ++ "\n" ++ unlines result - -data DocMarkup id a = Markup - { markupEmpty :: a - , markupString :: String -> a - , markupParagraph :: a -> a - , markupAppend :: a -> a -> a - , markupIdentifier :: id -> a - , markupIdentifierUnchecked :: (ModuleName, OccName) -> a - , markupModule :: String -> a - , markupWarning :: a -> a - , markupEmphasis :: a -> a - , markupBold :: a -> a - , markupMonospaced :: a -> a - , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a - , markupDefList :: [(a,a)] -> a - , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a - , markupAName :: String -> a - , markupPic :: Picture -> a - , markupMathInline :: String -> a - , markupMathDisplay :: String -> a - , markupProperty :: String -> a - , markupExample :: [Example] -> a - , markupHeader :: Header a -> a - } - - data HaddockModInfo name = HaddockModInfo { hmi_description :: Maybe (Doc name) , hmi_copyright :: Maybe String @@ -605,6 +571,12 @@ OptFullQual -> FullQual OptNoQual -> NoQual +-- | Whether to hide empty contexts +-- Since pattern synonyms have two contexts with different semantics, it is +-- important to all of them, even if one of them is empty. +data HideEmptyContexts + = HideEmptyContexts + | ShowEmptyToplevelContexts ----------------------------------------------------------------------------- -- * Error handling @@ -688,14 +660,14 @@ -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName (Located Name) = Located DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +type instance PostRn DocNameI NameSet = PlaceHolder +type instance PostRn DocNameI Fixity = PlaceHolder +type instance PostRn DocNameI Bool = PlaceHolder +type instance PostRn DocNameI Name = DocName +type instance PostRn DocNameI (Located Name) = Located DocName +type instance PostRn DocNameI [Name] = PlaceHolder +type instance PostRn DocNameI DocName = DocName -type instance PostTc DocName Kind = PlaceHolder -type instance PostTc DocName Type = PlaceHolder -type instance PostTc DocName Coercion = PlaceHolder +type instance PostTc DocNameI Kind = PlaceHolder +type instance PostTc DocNameI Type = PlaceHolder +type instance PostTc DocNameI Coercion = PlaceHolder diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -20,10 +20,11 @@ -- * Filename utilities moduleHtmlFile, moduleHtmlFile', - contentsHtmlFile, indexHtmlFile, + contentsHtmlFile, indexHtmlFile, indexJsonFile, moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, - jsFile, + haddockJsFile, jsQuickJumpFile, + quickJumpCssFile, -- * Anchor and URL utilities moduleNameUrl, moduleNameUrl', moduleUrl, @@ -37,8 +38,6 @@ html_xrefs_ref, html_xrefs_ref', -- * Doc markup - markup, - idMarkup, mkMeta, -- * List utilities @@ -125,12 +124,12 @@ mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType Name -> LHsSigWcType Name +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) -addClassContext :: Name -> LHsQTyVars Name -> LSig Name -> LSig Name +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) @@ -148,7 +147,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars Name -> [LHsType Name] +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -158,7 +157,7 @@ -------------------------------------------------------------------------------- -restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of TyClD d | isDataDecl d -> TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) @@ -167,7 +166,7 @@ tcdATs = restrictATs names (tcdATs d) }) _ -> decl -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) | DataType <- new_or_data = defn { dd_cons = restrictCons names cons } @@ -177,7 +176,7 @@ [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] +restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = @@ -197,7 +196,7 @@ h98ConDecl c@ConDeclGADT{} = c' where (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl Name + c' :: ConDecl GhcRn c' = ConDeclH98 { con_name = head (con_names c) , con_qvars = Just $ HsQTvs { hsq_implicit = mempty @@ -208,18 +207,18 @@ , con_doc = con_doc c } - field_avail :: LConDeclField Name -> Bool + field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] emptyHsQTvs :: LHsQTyVars Name @@ -256,9 +255,10 @@ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] -contentsHtmlFile, indexHtmlFile :: String +contentsHtmlFile, indexHtmlFile, indexJsonFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" +indexJsonFile = "doc-index.json" @@ -326,10 +326,15 @@ ------------------------------------------------------------------------------- -jsFile :: String -jsFile = "haddock-util.js" +haddockJsFile :: String +haddockJsFile = "haddock-bundle.min.js" +jsQuickJumpFile :: String +jsQuickJumpFile = "quick-jump.min.js" +quickJumpCssFile :: String +quickJumpCssFile = "quick-jump.css" + ------------------------------------------------------------------------------- -- * Misc. ------------------------------------------------------------------------------- @@ -447,71 +452,6 @@ spanWith p xs@(a:as) | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) | otherwise = ([],xs) - - ------------------------------------------------------------------------------ --- * Put here temporarily ------------------------------------------------------------------------------ - - -markup :: DocMarkup id a -> Doc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - - --- | The identity markup -idMarkup :: DocMarkup a (Doc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupMathInline = DocMathInline, - markupMathDisplay = DocMathDisplay, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - ----------------------------------------------------------------------------- -- * System tools diff --git a/src/Haddock/Utils/Json.hs b/src/Haddock/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/Json.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Minimal JSON / RFC 7159 support +-- +-- The API is heavily inspired by @aeson@'s API but puts emphasis on +-- simplicity rather than performance. The 'ToJSON' instances are +-- intended to have an encoding compatible with @aeson@'s encoding. +-- +module Haddock.Utils.Json + ( Value(..) + , Object, object, Pair, (.=) + , encodeToString + , encodeToBuilder + , ToJSON(toJSON) + ) + where + +import Data.Char +import Data.Int +import Data.String +import Data.Word +import Data.List +import Data.Monoid + +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as BB + +-- TODO: We may want to replace 'String' with 'Text' or 'ByteString' + +-- | A JSON value represented as a Haskell value. +data Value = Object !Object + | Array [Value] + | String String + | Number !Double + | Bool !Bool + | Null + deriving (Eq, Read, Show) + +-- | A key\/value pair for an 'Object' +type Pair = (String, Value) + +-- | A JSON \"object\" (key/value map). +type Object = [Pair] + +infixr 8 .= + +-- | A key-value pair for encoding a JSON object. +(.=) :: ToJSON v => String -> v -> Pair +k .= v = (k, toJSON v) + +-- | Create a 'Value' from a list of name\/value 'Pair's. +object :: [Pair] -> Value +object = Object + +instance IsString Value where + fromString = String + + +-- | A type that can be converted to JSON. +class ToJSON a where + -- | Convert a Haskell value to a JSON-friendly intermediate type. + toJSON :: a -> Value + +instance ToJSON () where + toJSON () = Array [] + +instance ToJSON Value where + toJSON = id + +instance ToJSON Bool where + toJSON = Bool + +instance ToJSON a => ToJSON [a] where + toJSON = Array . map toJSON + +instance ToJSON a => ToJSON (Maybe a) where + toJSON Nothing = Null + toJSON (Just a) = toJSON a + +instance (ToJSON a,ToJSON b) => ToJSON (a,b) where + toJSON (a,b) = Array [toJSON a, toJSON b] + +instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where + toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c] + +instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where + toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] + +instance ToJSON Float where + toJSON = Number . realToFrac + +instance ToJSON Double where + toJSON = Number + +instance ToJSON Int where toJSON = Number . realToFrac +instance ToJSON Int8 where toJSON = Number . realToFrac +instance ToJSON Int16 where toJSON = Number . realToFrac +instance ToJSON Int32 where toJSON = Number . realToFrac + +instance ToJSON Word where toJSON = Number . realToFrac +instance ToJSON Word8 where toJSON = Number . realToFrac +instance ToJSON Word16 where toJSON = Number . realToFrac +instance ToJSON Word32 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Int64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Word64 where toJSON = Number . realToFrac + +-- | Possibly lossy due to conversion to 'Double' +instance ToJSON Integer where toJSON = Number . fromInteger + +------------------------------------------------------------------------------ +-- 'BB.Builder'-based encoding + +-- | Serialise value as JSON/UTF8-encoded 'Builder' +encodeToBuilder :: ToJSON a => a -> Builder +encodeToBuilder = encodeValueBB . toJSON + +encodeValueBB :: Value -> Builder +encodeValueBB jv = case jv of + Bool True -> "true" + Bool False -> "false" + Null -> "null" + Number n + | isNaN n || isInfinite n -> encodeValueBB Null + | Just i <- doubleToInt64 n -> BB.int64Dec i + | otherwise -> BB.doubleDec n + Array a -> encodeArrayBB a + String s -> encodeStringBB s + Object o -> encodeObjectBB o + +encodeArrayBB :: [Value] -> Builder +encodeArrayBB [] = "[]" +encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']' + where + go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB + +encodeObjectBB :: Object -> Builder +encodeObjectBB [] = "{}" +encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}' + where + go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair + encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x + +encodeStringBB :: String -> Builder +encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"' + where + go = BB.stringUtf8 . escapeString + +------------------------------------------------------------------------------ +-- 'String'-based encoding + +-- | Serialise value as JSON-encoded Unicode 'String' +encodeToString :: ToJSON a => a -> String +encodeToString jv = encodeValue (toJSON jv) [] + +encodeValue :: Value -> ShowS +encodeValue jv = case jv of + Bool b -> showString (if b then "true" else "false") + Null -> showString "null" + Number n + | isNaN n || isInfinite n -> encodeValue Null + | Just i <- doubleToInt64 n -> shows i + | otherwise -> shows n + Array a -> encodeArray a + String s -> encodeString s + Object o -> encodeObject o + +encodeArray :: [Value] -> ShowS +encodeArray [] = showString "[]" +encodeArray jvs = ('[':) . go jvs . (']':) + where + go [] = id + go [x] = encodeValue x + go (x:xs) = encodeValue x . (',':) . go xs + +encodeObject :: Object -> ShowS +encodeObject [] = showString "{}" +encodeObject jvs = ('{':) . go jvs . ('}':) + where + go [] = id + go [(l,x)] = encodeString l . (':':) . encodeValue x + go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs + +encodeString :: String -> ShowS +encodeString str = ('"':) . showString (escapeString str) . ('"':) + +------------------------------------------------------------------------------ +-- helpers + +-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not +-- representable loss-free as integral 'Int64' value. +doubleToInt64 :: Double -> Maybe Int64 +doubleToInt64 x + | fromInteger x' == x + , x' <= toInteger (maxBound :: Int64) + , x' >= toInteger (minBound :: Int64) + = Just (fromIntegral x') + | otherwise = Nothing + where + x' = round x + +-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings" +escapeString :: String -> String +escapeString s + | not (any needsEscape s) = s + | otherwise = escape s + where + escape [] = [] + escape (x:xs) = case x of + '\\' -> '\\':'\\':escape xs + '"' -> '\\':'"':escape xs + '\b' -> '\\':'b':escape xs + '\f' -> '\\':'f':escape xs + '\n' -> '\\':'n':escape xs + '\r' -> '\\':'r':escape xs + '\t' -> '\\':'t':escape xs + c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs + | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs + | otherwise -> c : escape xs + + -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF + needsEscape c = ord c < 0x20 || c `elem` ['\\','"'] diff --git a/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/test/Haddock/Backends/Hyperlinker/ParserSpec.hs --- a/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -4,95 +4,149 @@ import Test.Hspec import Test.QuickCheck +import qualified GHC +import Control.Monad.IO.Class + +import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types +withDynFlags :: (GHC.DynFlags -> IO ()) -> IO () +withDynFlags cont = do + libDir <- fmap snd (getGhcDirs []) + GHC.runGhc (Just libDir) $ do + dflags <- GHC.getSessionDynFlags + liftIO $ cont dflags + main :: IO () main = hspec spec spec :: Spec -spec = do - describe "parse" parseSpec +spec = describe "parse" parseSpec +-- | Defined for its instance of 'Arbitrary'. Represents strings that, when +-- considered as GHC source, won't be rewritten. +newtype NoGhcRewrite = NoGhcRewrite String deriving (Show, Eq) + +-- | Filter out strings where GHC would replace/remove some characters during +-- lexing. +noGhcRewrite :: String -> Bool +noGhcRewrite ('\t':_) = False -- GHC replaces tabs with 8 spaces +noGhcRewrite ('\r':_) = False +noGhcRewrite ('\f':_) = False +noGhcRewrite ('\v':_) = False +noGhcRewrite (' ':'\n':_) = False -- GHC strips whitespace on empty lines +noGhcRewrite (_:s) = noGhcRewrite s +noGhcRewrite "" = True + +instance Arbitrary NoGhcRewrite where + arbitrary = fmap NoGhcRewrite (arbitrary `suchThat` noGhcRewrite) + shrink (NoGhcRewrite src) = [ NoGhcRewrite shrunk + | shrunk <- shrink src + , noGhcRewrite shrunk + ] + + parseSpec :: Spec -parseSpec = do +parseSpec = around withDynFlags $ do - it "is total" $ - property $ \src -> length (parse src) `shouldSatisfy` (>= 0) + it "is total" $ \dflags -> + property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0) - it "retains file layout" $ - property $ \src -> concatMap tkValue (parse src) == src + it "retains file layout" $ \dflags -> + property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ - "-- some very simple comment\nidentifier" - `shouldParseTo` - [TkComment, TkSpace, TkIdentifier] + it "should ignore content until the end of line" $ \dflags -> + shouldParseTo + "-- some very simple comment\nidentifier" + [TkComment, TkSpace, TkIdentifier] + dflags - it "should allow endline escaping" $ - "-- first line\\\nsecond line\\\nand another one" - `shouldParseTo` - [TkComment] + it "should allow endline escaping" $ \dflags -> + shouldParseTo + "#define first line\\\nsecond line\\\nand another one" + [TkCpp] + dflags context "when parsing multi-line comments" $ do - it "should support nested comments" $ - "{- comment {- nested -} still comment -} {- next comment -}" - `shouldParseTo` - [TkComment, TkSpace, TkComment] + it "should support nested comments" $ \dflags -> + shouldParseTo + "{- comment {- nested -} still comment -} {- next comment -}" + [TkComment, TkSpace, TkComment] + dflags - it "should distinguish compiler pragma" $ - "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" - `shouldParseTo` - [TkComment, TkPragma, TkComment] + it "should distinguish compiler pragma" $ \dflags -> + shouldParseTo + "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" + [TkComment, TkPragma, TkComment] + dflags - it "should recognize preprocessor directives" $ do - "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp] - "x # y" `shouldParseTo` - [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + it "should recognize preprocessor directives" $ \dflags -> do + shouldParseTo + "\n#define foo bar" + [TkSpace, TkCpp] + dflags + shouldParseTo + "x # y" + [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] + dflags - it "should distinguish basic language constructs" $ do - "(* 2) <$> (\"abc\", foo)" `shouldParseTo` + it "should distinguish basic language constructs" $ \dflags -> do + + shouldParseTo + "(* 2) <$> (\"abc\", foo)" [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] - "let foo' = foo in foo' + foo'" `shouldParseTo` + dflags + + shouldParseTo + "let foo' = foo in foo' + foo'" [ TkKeyword, TkSpace, TkIdentifier , TkSpace, TkGlyph, TkSpace , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] - "square x = y^2 where y = x" `shouldParseTo` + dflags + + shouldParseTo + "square x = y^2 where y = x" [ TkIdentifier, TkSpace, TkIdentifier , TkSpace, TkGlyph, TkSpace , TkIdentifier, TkOperator, TkNumber , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] + dflags - it "should parse do-notation syntax" $ do - "do { foo <- getLine; putStrLn foo }" `shouldParseTo` + it "should parse do-notation syntax" $ \dflags -> do + shouldParseTo + "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] + dflags - unlines - [ "do" - , " foo <- getLine" - , " putStrLn foo" - ] `shouldParseTo` + shouldParseTo + (unlines + [ "do" + , " foo <- getLine" + , " putStrLn foo" + ]) [ TkKeyword, TkSpace, TkIdentifier , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] - - -shouldParseTo :: String -> [TokenType] -> Expectation -str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens + dflags + where + shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation + shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens