From a7a5ccec3fc44f3f2deab9ba32a5b9fe95aa9f6c Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 11 Nov 2018 20:00:30 -0800 Subject: Rename 'NewOcean' theme to 'Linuwial' --- CHANGES.md | 2 +- doc/invoking.rst | 6 +- ghc.mk | 4 +- haddock-api/haddock-api.cabal | 4 +- .../resources/html/Linuwial.std-theme/linuwial.css | 891 +++++++++++++++++++++ .../resources/html/Linuwial.std-theme/synopsis.png | Bin 0 -> 11327 bytes .../html/NewOcean.std-theme/new-ocean.css | 891 --------------------- .../resources/html/NewOcean.std-theme/synopsis.png | Bin 11327 -> 0 bytes haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 2 +- html-test/ref/A.html | 4 +- html-test/ref/Bold.html | 4 +- html-test/ref/Bug1.html | 4 +- html-test/ref/Bug195.html | 4 +- html-test/ref/Bug2.html | 4 +- html-test/ref/Bug201.html | 4 +- html-test/ref/Bug253.html | 4 +- html-test/ref/Bug26.html | 2 +- html-test/ref/Bug280.html | 4 +- html-test/ref/Bug294.html | 2 +- html-test/ref/Bug298.html | 4 +- html-test/ref/Bug3.html | 4 +- html-test/ref/Bug308.html | 4 +- html-test/ref/Bug308CrossModule.html | 4 +- html-test/ref/Bug310.html | 2 +- html-test/ref/Bug313.html | 4 +- html-test/ref/Bug335.html | 4 +- html-test/ref/Bug387.html | 2 +- html-test/ref/Bug4.html | 4 +- html-test/ref/Bug458.html | 4 +- html-test/ref/Bug546.html | 4 +- html-test/ref/Bug548.html | 2 +- html-test/ref/Bug574.html | 2 +- html-test/ref/Bug6.html | 4 +- html-test/ref/Bug613.html | 2 +- html-test/ref/Bug647.html | 4 +- html-test/ref/Bug679.html | 2 +- html-test/ref/Bug7.html | 2 +- html-test/ref/Bug8.html | 4 +- html-test/ref/Bug85.html | 4 +- html-test/ref/Bug953.html | 4 +- html-test/ref/BugDeprecated.html | 4 +- html-test/ref/BugExportHeadings.html | 2 +- html-test/ref/Bugs.html | 4 +- html-test/ref/BundledPatterns.html | 4 +- html-test/ref/BundledPatterns2.html | 4 +- html-test/ref/ConstructorArgs.html | 2 +- html-test/ref/ConstructorPatternExport.html | 4 +- html-test/ref/DeprecatedClass.html | 4 +- html-test/ref/DeprecatedData.html | 4 +- html-test/ref/DeprecatedFunction.html | 4 +- html-test/ref/DeprecatedFunction2.html | 4 +- html-test/ref/DeprecatedFunction3.html | 4 +- html-test/ref/DeprecatedModule.html | 4 +- html-test/ref/DeprecatedModule2.html | 4 +- html-test/ref/DeprecatedNewtype.html | 4 +- html-test/ref/DeprecatedReExport.html | 2 +- html-test/ref/DeprecatedRecord.html | 4 +- html-test/ref/DeprecatedTypeFamily.html | 4 +- html-test/ref/DeprecatedTypeSynonym.html | 4 +- html-test/ref/DuplicateRecordFields.html | 4 +- html-test/ref/Examples.html | 4 +- html-test/ref/Extensions.html | 4 +- html-test/ref/FunArgs.html | 2 +- html-test/ref/GADTRecords.html | 4 +- html-test/ref/GadtConstructorArgs.html | 2 +- html-test/ref/Hash.html | 2 +- html-test/ref/HiddenInstances.html | 2 +- html-test/ref/HiddenInstancesB.html | 2 +- html-test/ref/Hyperlinks.html | 4 +- html-test/ref/ImplicitParams.html | 4 +- html-test/ref/Instances.html | 2 +- html-test/ref/Math.html | 4 +- html-test/ref/Minimal.html | 4 +- html-test/ref/ModuleWithWarning.html | 4 +- html-test/ref/NamedDoc.html | 4 +- html-test/ref/Nesting.html | 4 +- html-test/ref/NoLayout.html | 4 +- html-test/ref/NonGreedy.html | 4 +- html-test/ref/Operators.html | 4 +- html-test/ref/OrphanInstances.html | 2 +- html-test/ref/OrphanInstancesClass.html | 2 +- html-test/ref/OrphanInstancesType.html | 2 +- html-test/ref/PR643.html | 4 +- html-test/ref/PR643_1.html | 4 +- html-test/ref/PatternSyns.html | 4 +- html-test/ref/PromotedTypes.html | 4 +- html-test/ref/Properties.html | 4 +- html-test/ref/PruneWithWarning.html | 4 +- html-test/ref/QuantifiedConstraints.html | 2 +- html-test/ref/QuasiExpr.html | 2 +- html-test/ref/QuasiQuote.html | 4 +- html-test/ref/SpuriousSuperclassConstraints.html | 2 +- html-test/ref/TH.html | 4 +- html-test/ref/TH2.html | 4 +- html-test/ref/Table.html | 2 +- html-test/ref/Test.html | 2 +- html-test/ref/Threaded.html | 4 +- html-test/ref/Threaded_TH.html | 4 +- html-test/ref/Ticket112.html | 4 +- html-test/ref/Ticket61.html | 4 +- html-test/ref/Ticket75.html | 4 +- html-test/ref/TitledPicture.html | 4 +- html-test/ref/TypeFamilies.html | 2 +- html-test/ref/TypeFamilies2.html | 2 +- html-test/ref/TypeFamilies3.html | 2 +- html-test/ref/TypeOperators.html | 4 +- html-test/ref/Unicode.html | 4 +- html-test/ref/Unicode2.html | 2 +- html-test/ref/Visible.html | 4 +- 109 files changed, 1070 insertions(+), 1070 deletions(-) create mode 100644 haddock-api/resources/html/Linuwial.std-theme/linuwial.css create mode 100644 haddock-api/resources/html/Linuwial.std-theme/synopsis.png delete mode 100644 haddock-api/resources/html/NewOcean.std-theme/new-ocean.css delete mode 100644 haddock-api/resources/html/NewOcean.std-theme/synopsis.png diff --git a/CHANGES.md b/CHANGES.md index 1250a726..36e5b5a1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,6 @@ ## Changes in TBA - * NewOcean is the new default theme (#721, #782, #949) + * "Linuwial" is the new default theme (#721, #782, #949) * Fix style switcher (enabled by `--built-in-themes`) (#949) diff --git a/doc/invoking.rst b/doc/invoking.rst index 3e6e667a..ebf9792f 100644 --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -295,7 +295,7 @@ The following options are available: reader can switch between themes with browsers that support alternate style sheets, or with the "Style" menu that gets added when the page is loaded. If no themes are specified, then just the - default built-in theme ("NewOcean") is used. + default built-in theme ("Linuwial") is used. The path parameter can be one of: @@ -307,11 +307,11 @@ The following options are available: - A *CSS file*: The base name of the file becomes the name of the theme. - - The *name* of a built-in theme ("NewOcean", "Ocean", or "Classic"). + - The *name* of a built-in theme ("Linuwial", "Ocean", or "Classic"). .. option:: --built-in-themes - Includes the built-in themes ("NewOcean", "Ocean", and "Classic"). Can be + Includes the built-in themes ("Linuwial", "Ocean", and "Classic"). Can be combined with :option:`--theme`. Note that order matters: The first specified theme will be the default. diff --git a/ghc.mk b/ghc.mk index d3b02b6e..fc4a4632 100644 --- a/ghc.mk +++ b/ghc.mk @@ -45,8 +45,8 @@ utils/haddock_dist_DATA_FILES += html/Ocean.theme/minus.gif utils/haddock_dist_DATA_FILES += html/Ocean.theme/ocean.css utils/haddock_dist_DATA_FILES += html/Ocean.theme/plus.gif utils/haddock_dist_DATA_FILES += html/Ocean.theme/synopsis.png -utils/haddock_dist_DATA_FILES += html/NewOcean.std-theme/new-ocean.css -utils/haddock_dist_DATA_FILES += html/NewOcean.std-theme/synopsis.png +utils/haddock_dist_DATA_FILES += html/Linuwial.std-theme/linuwial.css +utils/haddock_dist_DATA_FILES += html/Linuwial.std-theme/synopsis.png utils/haddock_dist_DATA_FILES += html/solarized.css utils/haddock_dist_DATA_FILES += html/highlight.js utils/haddock_dist_DATA_FILES += latex/haddock.sty diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index a410f436..68653c84 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -34,8 +34,8 @@ data-files: html/Ocean.theme/ocean.css html/Ocean.theme/plus.gif html/Ocean.theme/synopsis.png - html/NewOcean.std-theme/new-ocean.css - html/NewOcean.std-theme/synopsis.png + html/Linuwial.std-theme/linuwial.css + html/Linuwial.std-theme/synopsis.png latex/haddock.sty library diff --git a/haddock-api/resources/html/Linuwial.std-theme/linuwial.css b/haddock-api/resources/html/Linuwial.std-theme/linuwial.css new file mode 100644 index 00000000..5450ae2e --- /dev/null +++ b/haddock-api/resources/html/Linuwial.std-theme/linuwial.css @@ -0,0 +1,891 @@ +/* @group Fundamentals */ + +* { margin: 0; padding: 0 } + +/* Is this portable? */ +html { + background-color: white; + width: 100%; + height: 100%; +} + +body { + background: #fefefe; + color: #333; + text-align: left; + min-height: 100vh; + position: relative; + -webkit-text-size-adjust: 100%; + -webkit-font-feature-settings: "kern" 1, "liga" 0; + -moz-font-feature-settings: "kern" 1, "liga" 0; + -o-font-feature-settings: "kern" 1, "liga" 0; + font-feature-settings: "kern" 1, "liga" 0; + letter-spacing: 0.0015rem; +} + +#content a { + overflow-wrap: break-word; +} + +p { + margin: 0.8em 0; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +dl { + margin: 0.8em 0; +} + +dt { + font-weight: bold; +} +dd { + margin-left: 2em; +} + +a { text-decoration: none; } +a[href]:link { color: #9E358F; } +a[href]:visited {color: #6F5F9C; } +a[href]:hover { text-decoration:underline; } + +a[href].def:link, a[href].def:visited { color: rgba(69, 59, 97, 0.8); } +a[href].def:hover { color: rgb(78, 98, 114); } + +/* @end */ + +/* @group Show and hide with JS */ + +body.js-enabled .hide-when-js-enabled { + display: none; +} + +/* @end */ + + +/* @group responsive */ + +#package-header .caption { + margin: 0px 1em 0 2em; +} + +@media only screen and (min-width: 1280px) { + #content { + width: 63vw; + max-width: 1450px; + } + + #table-of-contents { + position: fixed; + max-width: 10vw; + top: 10.2em; + left: 2em; + bottom: 1em; + overflow-y: auto; + } + + #synopsis { + display: block; + position: fixed; + float: left; + top: 5em; + bottom: 1em; + right: 0; + max-width: 65vw; + overflow-y: auto; + /* Ensure that synopsis covers everything (including MathJAX markup) */ + z-index: 1; + } + + #synopsis .show { + border: 1px solid #5E5184; + padding: 0.7em; + max-height: 65vh; + } + +} + +@media only screen and (max-width: 1279px) { + #content { + width: 80vw; + } + + #synopsis { + display: block; + padding: 0; + position: relative; + margin: 0; + width: 100%; + } +} + +@media only screen and (max-width: 999px) { + #content { + width: 93vw; + } +} + + +/* menu for wider screens + + Display the package name at the left and the menu links at the right, + inline with each other: + The package name Source . Contents . Index +*/ +@media only screen and (min-width: 1000px) { + #package-header { + text-align: left; + white-space: nowrap; + height: 40px; + padding: 4px 1.5em 0px 1.5em; + overflow: visible; + + display: flex; + justify-content: space-between; + align-items: center; + } + + #package-header .caption { + display: inline-block; + margin: 0; + } + + #package-header ul.links { + margin: 0; + display: inline-table; + } + + #package-header .caption + ul.links { + margin-left: 1em; + } +} + +/* menu for smaller screens + +Display the package name on top of the menu links and center both elements: + The package name + Source . Contents . Index +*/ +@media only screen and (max-width: 999px) { + #package-header { + text-align: center; + padding: 6px 0 4px 0; + overflow: hidden; + } + + #package-header ul.links { + display: block; + text-align: center; + margin: 0; + + /* Hide scrollbar but allow scrolling menu links horizontally */ + white-space: nowrap; + overflow-x: auto; + overflow-y: hidden; + margin-bottom: -17px; + height: 50px; + } + + #package-header .caption { + display: block; + margin: 4px 0; + text-align: center; + } + + #package-header ul.links::-webkit-scrollbar { + display: none; + } + + #package-header ul.links li:first-of-type { + padding-left: 1em; + } + + #package-header ul.links li:last-of-type { + /* + The last link of the menu should offer the same distance to the right + as the #package-header enforces at the left. + */ + padding-right: 1em; + } + + #package-header .caption + ul.links { + padding-top: 9px; + } + + #module-header table.info { + float: none; + top: 0; + margin: 0 auto; + overflow: hidden; + max-width: 80vw; + } +} + +/* @end */ + + +/* @group Fonts & Sizes */ + +/* Basic technique & IE workarounds from YUI 3 + For reasons, see: + http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css + */ + + body, button { + font: 400 15px/1.4 'PT Sans', + /* Fallback Font Stack */ + -apple-system, + BlinkMacSystemFont, + 'Segoe UI', + Roboto, + Oxygen-Sans, + Cantarell, + 'Helvetica Neue', + sans-serif; + *font-size: medium; /* for IE */ + *font:x-small; /* for IE in quirks mode */ + } + +h1 { font-size: 146.5%; /* 19pt */ } +h2 { font-size: 131%; /* 17pt */ } +h3 { font-size: 116%; /* 15pt */ } +h4 { font-size: 100%; /* 13pt */ } +h5 { font-size: 100%; /* 13pt */ } + +table { + font-size:inherit; + font:100%; +} + +pre, code, kbd, samp, tt, .src { + font-family:monospace; +} + +.links, .link { + font-size: 85%; /* 11pt */ +} + +#module-header .caption { + font-size: 182%; /* 24pt */ +} + +#module-header .caption sup { + font-size: 80%; + font-weight: normal; +} + +#package-header #page-menu a:link, #package-header #page-menu a:visited { color: white; } + + +.info { + font-size: 90%; +} + + +/* @end */ + +/* @group Common */ + +.caption, h1, h2, h3, h4, h5, h6, summary { + font-weight: bold; + color: #5E5184; + margin: 1.5em 0 1em 0; +} + + +* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { + margin-top: 2em; +} + +h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { + margin-top: inherit; +} + +ul li + li { + margin-top: 0.2rem; +} + +ul + p { + margin-top: 0.93em; +} + +p + ul { + margin-top: 0.5em; +} + +p { + margin-top: 0.7rem; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +ul.links { + list-style: none; + text-align: left; + font-size: 0.95em; +} + +#package-header ul.links, #package-header ul.links button { + font-size: 1rem; +} + +ul.links li { + display: inline; + white-space: nowrap; + padding: 0; +} + +ul.links > li + li:before { + content: '\00B7'; +} + +ul.links li a { + padding: 0.2em 0.5em; +} + +.hide { display: none; } +.show { display: inherit; } +.clear { clear: both; } + +.collapser:before, .expander:before, .noexpander:before { + font-size: 1.2em; + color: #9C5791; + display: inline-block; + padding-right: 7px; +} + +.collapser:before { + content: '▿'; +} +.expander:before { + content: '▹'; +} +.noexpander:before { + content: '▿'; + visibility: hidden; +} + +.collapser, .expander { + cursor: pointer; +} + +.instance.collapser, .instance.expander { + margin-left: 0px; + background-position: left center; + min-width: 9px; + min-height: 9px; +} + +summary { + cursor: pointer; + outline: none; +} + +pre { + padding: 0.5rem 1rem; + margin: 1em 0 0 0; + background-color: #f7f7f7; + overflow: auto; +} + +pre + p { + margin-top: 1em; +} + +pre + pre { + margin-top: 0.5em; +} + +.src { + background: #f4f4f4; + padding: 0.2em 0.5em; +} + +.keyword { font-weight: normal; } +.def { font-weight: bold; } + +@media print { + #footer { display: none; } +} + +/* @end */ + +/* @group Page Structure */ + +#content { + margin: 3em auto 6em auto; + padding: 0; +} + +#package-header { + background: #5E5184; + border-bottom: 5px solid rgba(69, 59, 97, 0.5); + color: #ddd; + position: relative; + font-size: 1.2em; + text-align: left; + margin: 0 auto; +} + +#package-header .caption { + color: white; + font-style: normal; + font-size: 1rem; + font-weight: bold; +} + +#module-header .caption { + font-weight: bold; + border-bottom: 1px solid #ddd; +} + +table.info { + float: right; + padding: 0.5em 1em; + border: 1px solid #ddd; + color: rgb(78,98,114); + background-color: #fff; + max-width: 60%; + border-spacing: 0; + position: relative; + top: -0.78em; + margin: 0 0 0 2em; +} + +.info th { + padding: 0 1em 0 0; + text-align: right; +} + +div#style-menu-holder { + position: relative; + z-index: 2; + display: inline; +} + +#style-menu { + position: absolute; + z-index: 1; + overflow: visible; + background: #374c5e; + margin: 0; + text-align: center; + right: 0; + padding: 0; + top: 1.25em; +} + +#style-menu li { + display: inline-block; + border-style: none; + margin: 0; + padding: 0; + color: #000; + list-style-type: none; + border-top: 1px solid #919191 +} + +#style-menu li + li { + border-left: 1px solid #919191; +} + +#style-menu a { + width: 6em; + padding: 3px; + display: block; +} + +#footer { + background: #ededed; + border-top: 1px solid #aaa; + padding: 0.5em 0; + color: #222; + text-align: center; + width: 100%; + height: 3em; + margin-top: 3em; + position: relative; + clear: both; +} + +/* @end */ + +/* @group Front Matter */ + +#synopsis .caption, +#contents-list .caption { + font-size: 1rem; +} + +#synopsis, #table-of-contents { + font-size: 16px; +} + +#contents-list { + background: #f7f7f7; + padding: 1em; + margin: 0; +} + +#contents-list .caption { + text-align: left; + margin: 0; +} + +#contents-list ul { + list-style: none; + margin: 0; + margin-top: 10px; + font-size: 14px; +} + +#contents-list ul ul { + margin-left: 1.5em; +} + +#description .caption { + display: none; +} + +#synopsis summary { + display: block; + float: right; + width: 29px; + color: rgba(255,255,255,0); + height: 110px; + margin: 0; + font-size: 1px; + padding: 0; + background: url(synopsis.png) no-repeat 0px -8px; +} + +#synopsis details[open] > summary { + background: url(synopsis.png) no-repeat -75px -8px; +} + +#synopsis ul { + height: 100%; + overflow: auto; + padding: 0.5em; + margin: 0; +} + +#synopsis ul ul { + overflow: hidden; +} + +#synopsis ul, +#synopsis ul li.src { + background-color: rgb(250,247,224); + white-space: nowrap; + list-style: none; + margin-left: 0; +} + +#interface td.src { + white-space: nowrap; +} + +/* @end */ + +/* @group Main Content */ + +#interface div.top + div.top { + margin-top: 1.5em; +} + +#interface p + div.top, +#interface h1 + div.top, +#interface h2 + div.top, +#interface h3 + div.top, +#interface h4 + div.top, +#interface h5 + div.top { + margin-top: 1em; +} +#interface .src .selflink, +#interface .src .link { + float: right; + color: #888; + padding: 0 7px; + -moz-user-select: none; + font-weight: bold; + line-height: 30px; +} +#interface .src .selflink { + margin: 0 -0.5em 0 0.5em; +} + +#interface span.fixity { + color: #919191; + border-left: 1px solid #919191; + padding: 0.2em 0.5em 0.2em 0.5em; + margin: 0 -1em 0 1em; +} + +#interface span.rightedge { + border-left: 1px solid #919191; + padding: 0.2em 0 0.2em 0; + margin: 0 0 0 1em; +} + +#interface table { border-spacing: 2px; } +#interface td { + vertical-align: top; + padding-left: 0.5em; +} + +#interface td.doc p { + margin: 0; +} +#interface td.doc p + p { + margin-top: 0.8em; +} + +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} + +.clearfix:after { + clear: both; + content: " "; + display: block; + height: 0; + visibility: hidden; +} + +.subs, .top > .doc, .subs > .doc { + padding-left: 1em; + border-left: 1px solid gainsboro; + margin-bottom: 1em; +} + +.top .subs { + margin-bottom: 0.6em; +} + +.subs.fields ul { + list-style: none; + display: table; + margin: 0; +} + +.subs.fields ul li { + display: table-row; +} + +.subs ul li dfn { + display: table-cell; + font-style: normal; + font-weight: bold; + margin: 1px 0; + white-space: nowrap; +} + +.subs ul li > .doc { + display: table-cell; + padding-left: 0.5em; + margin-bottom: 0.5em; +} + +.subs ul li > .doc p { + margin: 0; +} + +.subs .subs p.src { + border: none; + background-color: #f8f8f8; +} + +.subs .subs .caption { + margin-top: 1em ; + margin-bottom: 0px; +} + +.subs p.caption { + margin-top: 0; +} + +.subs .subs .caption + .src { + margin: 0px; + margin-top: 8px; +} + +.subs .subs .src + .src { + margin: 7px 0 0 0; +} + +/* Render short-style data instances */ +.inst ul { + height: 100%; + padding: 0.5em; + margin: 0; +} + +.inst, .inst li { + list-style: none; + margin-left: 1em; +} + +/* Workaround for bug in Firefox (issue #384) */ +.inst-left { + float: left; +} + +.top p.src { + border-bottom: 3px solid #e5e5e5; + line-height: 2rem; + margin-bottom: 1em; +} + +.warning { + color: red; +} + +.arguments { + margin-top: -0.4em; +} +.arguments .caption { + display: none; +} + +.fields { padding-left: 1em; } + +.fields .caption { display: none; } + +.fields p { margin: 0 0; } + +/* this seems bulky to me +.methods, .constructors { + background: #f8f8f8; + border: 1px solid #eee; +} +*/ + +/* @end */ + +/* @group Auxillary Pages */ + + +.extension-list { + list-style-type: none; + margin-left: 0; +} + +#mini { + margin: 0 auto; + padding: 0 1em 1em; +} + +#mini > * { + font-size: 93%; /* 12pt */ +} + +#mini #module-list .caption, +#mini #module-header .caption { + font-size: 125%; /* 15pt */ +} + +#mini #interface h1, +#mini #interface h2, +#mini #interface h3, +#mini #interface h4 { + font-size: 109%; /* 13pt */ + margin: 1em 0 0; +} + +#mini #interface .top, +#mini #interface .src { + margin: 0; +} + +#mini #module-list ul { + list-style: none; + margin: 0; +} + +#alphabet ul { + list-style: none; + padding: 0; + margin: 0.5em 0 0; + text-align: center; +} + +#alphabet li { + display: inline; + margin: 0 0.25em; +} + +#alphabet a { + font-weight: bold; +} + +#index .caption, +#module-list .caption { font-size: 131%; /* 17pt */ } + +#index table { + margin-left: 2em; +} + +#index .src { + font-weight: bold; +} +#index .alt { + font-size: 77%; /* 10pt */ + font-style: italic; + padding-left: 2em; +} + +#index td + td { + padding-left: 1em; +} + +#module-list ul { + list-style: none; + margin: 0 0 0 2em; +} + +#module-list li { + clear: right; +} + +#module-list span.collapser, +#module-list span.expander { + background-position: 0 0.3em; +} + +#module-list .package { + float: right; +} + +:target { + background: -webkit-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -moz-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -o-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -ms-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: linear-gradient(to bottom, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); +} + +:target:hover { + background: -webkit-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -moz-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -o-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -ms-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: linear-gradient(to bottom, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); +} + +/* @end */ diff --git a/haddock-api/resources/html/Linuwial.std-theme/synopsis.png b/haddock-api/resources/html/Linuwial.std-theme/synopsis.png new file mode 100644 index 00000000..85fb86ec Binary files /dev/null and b/haddock-api/resources/html/Linuwial.std-theme/synopsis.png differ diff --git a/haddock-api/resources/html/NewOcean.std-theme/new-ocean.css b/haddock-api/resources/html/NewOcean.std-theme/new-ocean.css deleted file mode 100644 index 5450ae2e..00000000 --- a/haddock-api/resources/html/NewOcean.std-theme/new-ocean.css +++ /dev/null @@ -1,891 +0,0 @@ -/* @group Fundamentals */ - -* { margin: 0; padding: 0 } - -/* Is this portable? */ -html { - background-color: white; - width: 100%; - height: 100%; -} - -body { - background: #fefefe; - color: #333; - text-align: left; - min-height: 100vh; - position: relative; - -webkit-text-size-adjust: 100%; - -webkit-font-feature-settings: "kern" 1, "liga" 0; - -moz-font-feature-settings: "kern" 1, "liga" 0; - -o-font-feature-settings: "kern" 1, "liga" 0; - font-feature-settings: "kern" 1, "liga" 0; - letter-spacing: 0.0015rem; -} - -#content a { - overflow-wrap: break-word; -} - -p { - margin: 0.8em 0; -} - -ul, ol { - margin: 0.8em 0 0.8em 2em; -} - -dl { - margin: 0.8em 0; -} - -dt { - font-weight: bold; -} -dd { - margin-left: 2em; -} - -a { text-decoration: none; } -a[href]:link { color: #9E358F; } -a[href]:visited {color: #6F5F9C; } -a[href]:hover { text-decoration:underline; } - -a[href].def:link, a[href].def:visited { color: rgba(69, 59, 97, 0.8); } -a[href].def:hover { color: rgb(78, 98, 114); } - -/* @end */ - -/* @group Show and hide with JS */ - -body.js-enabled .hide-when-js-enabled { - display: none; -} - -/* @end */ - - -/* @group responsive */ - -#package-header .caption { - margin: 0px 1em 0 2em; -} - -@media only screen and (min-width: 1280px) { - #content { - width: 63vw; - max-width: 1450px; - } - - #table-of-contents { - position: fixed; - max-width: 10vw; - top: 10.2em; - left: 2em; - bottom: 1em; - overflow-y: auto; - } - - #synopsis { - display: block; - position: fixed; - float: left; - top: 5em; - bottom: 1em; - right: 0; - max-width: 65vw; - overflow-y: auto; - /* Ensure that synopsis covers everything (including MathJAX markup) */ - z-index: 1; - } - - #synopsis .show { - border: 1px solid #5E5184; - padding: 0.7em; - max-height: 65vh; - } - -} - -@media only screen and (max-width: 1279px) { - #content { - width: 80vw; - } - - #synopsis { - display: block; - padding: 0; - position: relative; - margin: 0; - width: 100%; - } -} - -@media only screen and (max-width: 999px) { - #content { - width: 93vw; - } -} - - -/* menu for wider screens - - Display the package name at the left and the menu links at the right, - inline with each other: - The package name Source . Contents . Index -*/ -@media only screen and (min-width: 1000px) { - #package-header { - text-align: left; - white-space: nowrap; - height: 40px; - padding: 4px 1.5em 0px 1.5em; - overflow: visible; - - display: flex; - justify-content: space-between; - align-items: center; - } - - #package-header .caption { - display: inline-block; - margin: 0; - } - - #package-header ul.links { - margin: 0; - display: inline-table; - } - - #package-header .caption + ul.links { - margin-left: 1em; - } -} - -/* menu for smaller screens - -Display the package name on top of the menu links and center both elements: - The package name - Source . Contents . Index -*/ -@media only screen and (max-width: 999px) { - #package-header { - text-align: center; - padding: 6px 0 4px 0; - overflow: hidden; - } - - #package-header ul.links { - display: block; - text-align: center; - margin: 0; - - /* Hide scrollbar but allow scrolling menu links horizontally */ - white-space: nowrap; - overflow-x: auto; - overflow-y: hidden; - margin-bottom: -17px; - height: 50px; - } - - #package-header .caption { - display: block; - margin: 4px 0; - text-align: center; - } - - #package-header ul.links::-webkit-scrollbar { - display: none; - } - - #package-header ul.links li:first-of-type { - padding-left: 1em; - } - - #package-header ul.links li:last-of-type { - /* - The last link of the menu should offer the same distance to the right - as the #package-header enforces at the left. - */ - padding-right: 1em; - } - - #package-header .caption + ul.links { - padding-top: 9px; - } - - #module-header table.info { - float: none; - top: 0; - margin: 0 auto; - overflow: hidden; - max-width: 80vw; - } -} - -/* @end */ - - -/* @group Fonts & Sizes */ - -/* Basic technique & IE workarounds from YUI 3 - For reasons, see: - http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css - */ - - body, button { - font: 400 15px/1.4 'PT Sans', - /* Fallback Font Stack */ - -apple-system, - BlinkMacSystemFont, - 'Segoe UI', - Roboto, - Oxygen-Sans, - Cantarell, - 'Helvetica Neue', - sans-serif; - *font-size: medium; /* for IE */ - *font:x-small; /* for IE in quirks mode */ - } - -h1 { font-size: 146.5%; /* 19pt */ } -h2 { font-size: 131%; /* 17pt */ } -h3 { font-size: 116%; /* 15pt */ } -h4 { font-size: 100%; /* 13pt */ } -h5 { font-size: 100%; /* 13pt */ } - -table { - font-size:inherit; - font:100%; -} - -pre, code, kbd, samp, tt, .src { - font-family:monospace; -} - -.links, .link { - font-size: 85%; /* 11pt */ -} - -#module-header .caption { - font-size: 182%; /* 24pt */ -} - -#module-header .caption sup { - font-size: 80%; - font-weight: normal; -} - -#package-header #page-menu a:link, #package-header #page-menu a:visited { color: white; } - - -.info { - font-size: 90%; -} - - -/* @end */ - -/* @group Common */ - -.caption, h1, h2, h3, h4, h5, h6, summary { - font-weight: bold; - color: #5E5184; - margin: 1.5em 0 1em 0; -} - - -* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { - margin-top: 2em; -} - -h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { - margin-top: inherit; -} - -ul li + li { - margin-top: 0.2rem; -} - -ul + p { - margin-top: 0.93em; -} - -p + ul { - margin-top: 0.5em; -} - -p { - margin-top: 0.7rem; -} - -ul, ol { - margin: 0.8em 0 0.8em 2em; -} - -ul.links { - list-style: none; - text-align: left; - font-size: 0.95em; -} - -#package-header ul.links, #package-header ul.links button { - font-size: 1rem; -} - -ul.links li { - display: inline; - white-space: nowrap; - padding: 0; -} - -ul.links > li + li:before { - content: '\00B7'; -} - -ul.links li a { - padding: 0.2em 0.5em; -} - -.hide { display: none; } -.show { display: inherit; } -.clear { clear: both; } - -.collapser:before, .expander:before, .noexpander:before { - font-size: 1.2em; - color: #9C5791; - display: inline-block; - padding-right: 7px; -} - -.collapser:before { - content: '▿'; -} -.expander:before { - content: '▹'; -} -.noexpander:before { - content: '▿'; - visibility: hidden; -} - -.collapser, .expander { - cursor: pointer; -} - -.instance.collapser, .instance.expander { - margin-left: 0px; - background-position: left center; - min-width: 9px; - min-height: 9px; -} - -summary { - cursor: pointer; - outline: none; -} - -pre { - padding: 0.5rem 1rem; - margin: 1em 0 0 0; - background-color: #f7f7f7; - overflow: auto; -} - -pre + p { - margin-top: 1em; -} - -pre + pre { - margin-top: 0.5em; -} - -.src { - background: #f4f4f4; - padding: 0.2em 0.5em; -} - -.keyword { font-weight: normal; } -.def { font-weight: bold; } - -@media print { - #footer { display: none; } -} - -/* @end */ - -/* @group Page Structure */ - -#content { - margin: 3em auto 6em auto; - padding: 0; -} - -#package-header { - background: #5E5184; - border-bottom: 5px solid rgba(69, 59, 97, 0.5); - color: #ddd; - position: relative; - font-size: 1.2em; - text-align: left; - margin: 0 auto; -} - -#package-header .caption { - color: white; - font-style: normal; - font-size: 1rem; - font-weight: bold; -} - -#module-header .caption { - font-weight: bold; - border-bottom: 1px solid #ddd; -} - -table.info { - float: right; - padding: 0.5em 1em; - border: 1px solid #ddd; - color: rgb(78,98,114); - background-color: #fff; - max-width: 60%; - border-spacing: 0; - position: relative; - top: -0.78em; - margin: 0 0 0 2em; -} - -.info th { - padding: 0 1em 0 0; - text-align: right; -} - -div#style-menu-holder { - position: relative; - z-index: 2; - display: inline; -} - -#style-menu { - position: absolute; - z-index: 1; - overflow: visible; - background: #374c5e; - margin: 0; - text-align: center; - right: 0; - padding: 0; - top: 1.25em; -} - -#style-menu li { - display: inline-block; - border-style: none; - margin: 0; - padding: 0; - color: #000; - list-style-type: none; - border-top: 1px solid #919191 -} - -#style-menu li + li { - border-left: 1px solid #919191; -} - -#style-menu a { - width: 6em; - padding: 3px; - display: block; -} - -#footer { - background: #ededed; - border-top: 1px solid #aaa; - padding: 0.5em 0; - color: #222; - text-align: center; - width: 100%; - height: 3em; - margin-top: 3em; - position: relative; - clear: both; -} - -/* @end */ - -/* @group Front Matter */ - -#synopsis .caption, -#contents-list .caption { - font-size: 1rem; -} - -#synopsis, #table-of-contents { - font-size: 16px; -} - -#contents-list { - background: #f7f7f7; - padding: 1em; - margin: 0; -} - -#contents-list .caption { - text-align: left; - margin: 0; -} - -#contents-list ul { - list-style: none; - margin: 0; - margin-top: 10px; - font-size: 14px; -} - -#contents-list ul ul { - margin-left: 1.5em; -} - -#description .caption { - display: none; -} - -#synopsis summary { - display: block; - float: right; - width: 29px; - color: rgba(255,255,255,0); - height: 110px; - margin: 0; - font-size: 1px; - padding: 0; - background: url(synopsis.png) no-repeat 0px -8px; -} - -#synopsis details[open] > summary { - background: url(synopsis.png) no-repeat -75px -8px; -} - -#synopsis ul { - height: 100%; - overflow: auto; - padding: 0.5em; - margin: 0; -} - -#synopsis ul ul { - overflow: hidden; -} - -#synopsis ul, -#synopsis ul li.src { - background-color: rgb(250,247,224); - white-space: nowrap; - list-style: none; - margin-left: 0; -} - -#interface td.src { - white-space: nowrap; -} - -/* @end */ - -/* @group Main Content */ - -#interface div.top + div.top { - margin-top: 1.5em; -} - -#interface p + div.top, -#interface h1 + div.top, -#interface h2 + div.top, -#interface h3 + div.top, -#interface h4 + div.top, -#interface h5 + div.top { - margin-top: 1em; -} -#interface .src .selflink, -#interface .src .link { - float: right; - color: #888; - padding: 0 7px; - -moz-user-select: none; - font-weight: bold; - line-height: 30px; -} -#interface .src .selflink { - margin: 0 -0.5em 0 0.5em; -} - -#interface span.fixity { - color: #919191; - border-left: 1px solid #919191; - padding: 0.2em 0.5em 0.2em 0.5em; - margin: 0 -1em 0 1em; -} - -#interface span.rightedge { - border-left: 1px solid #919191; - padding: 0.2em 0 0.2em 0; - margin: 0 0 0 1em; -} - -#interface table { border-spacing: 2px; } -#interface td { - vertical-align: top; - padding-left: 0.5em; -} - -#interface td.doc p { - margin: 0; -} -#interface td.doc p + p { - margin-top: 0.8em; -} - -.doc table { - border-collapse: collapse; - border-spacing: 0px; -} - -.doc th, -.doc td { - padding: 5px; - border: 1px solid #ddd; -} - -.doc th { - background-color: #f0f0f0; -} - -.clearfix:after { - clear: both; - content: " "; - display: block; - height: 0; - visibility: hidden; -} - -.subs, .top > .doc, .subs > .doc { - padding-left: 1em; - border-left: 1px solid gainsboro; - margin-bottom: 1em; -} - -.top .subs { - margin-bottom: 0.6em; -} - -.subs.fields ul { - list-style: none; - display: table; - margin: 0; -} - -.subs.fields ul li { - display: table-row; -} - -.subs ul li dfn { - display: table-cell; - font-style: normal; - font-weight: bold; - margin: 1px 0; - white-space: nowrap; -} - -.subs ul li > .doc { - display: table-cell; - padding-left: 0.5em; - margin-bottom: 0.5em; -} - -.subs ul li > .doc p { - margin: 0; -} - -.subs .subs p.src { - border: none; - background-color: #f8f8f8; -} - -.subs .subs .caption { - margin-top: 1em ; - margin-bottom: 0px; -} - -.subs p.caption { - margin-top: 0; -} - -.subs .subs .caption + .src { - margin: 0px; - margin-top: 8px; -} - -.subs .subs .src + .src { - margin: 7px 0 0 0; -} - -/* Render short-style data instances */ -.inst ul { - height: 100%; - padding: 0.5em; - margin: 0; -} - -.inst, .inst li { - list-style: none; - margin-left: 1em; -} - -/* Workaround for bug in Firefox (issue #384) */ -.inst-left { - float: left; -} - -.top p.src { - border-bottom: 3px solid #e5e5e5; - line-height: 2rem; - margin-bottom: 1em; -} - -.warning { - color: red; -} - -.arguments { - margin-top: -0.4em; -} -.arguments .caption { - display: none; -} - -.fields { padding-left: 1em; } - -.fields .caption { display: none; } - -.fields p { margin: 0 0; } - -/* this seems bulky to me -.methods, .constructors { - background: #f8f8f8; - border: 1px solid #eee; -} -*/ - -/* @end */ - -/* @group Auxillary Pages */ - - -.extension-list { - list-style-type: none; - margin-left: 0; -} - -#mini { - margin: 0 auto; - padding: 0 1em 1em; -} - -#mini > * { - font-size: 93%; /* 12pt */ -} - -#mini #module-list .caption, -#mini #module-header .caption { - font-size: 125%; /* 15pt */ -} - -#mini #interface h1, -#mini #interface h2, -#mini #interface h3, -#mini #interface h4 { - font-size: 109%; /* 13pt */ - margin: 1em 0 0; -} - -#mini #interface .top, -#mini #interface .src { - margin: 0; -} - -#mini #module-list ul { - list-style: none; - margin: 0; -} - -#alphabet ul { - list-style: none; - padding: 0; - margin: 0.5em 0 0; - text-align: center; -} - -#alphabet li { - display: inline; - margin: 0 0.25em; -} - -#alphabet a { - font-weight: bold; -} - -#index .caption, -#module-list .caption { font-size: 131%; /* 17pt */ } - -#index table { - margin-left: 2em; -} - -#index .src { - font-weight: bold; -} -#index .alt { - font-size: 77%; /* 10pt */ - font-style: italic; - padding-left: 2em; -} - -#index td + td { - padding-left: 1em; -} - -#module-list ul { - list-style: none; - margin: 0 0 0 2em; -} - -#module-list li { - clear: right; -} - -#module-list span.collapser, -#module-list span.expander { - background-position: 0 0.3em; -} - -#module-list .package { - float: right; -} - -:target { - background: -webkit-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); - background: -moz-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); - background: -o-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); - background: -ms-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); - background: linear-gradient(to bottom, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); -} - -:target:hover { - background: -webkit-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); - background: -moz-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); - background: -o-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); - background: -ms-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); - background: linear-gradient(to bottom, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); -} - -/* @end */ diff --git a/haddock-api/resources/html/NewOcean.std-theme/synopsis.png b/haddock-api/resources/html/NewOcean.std-theme/synopsis.png deleted file mode 100644 index 85fb86ec..00000000 Binary files a/haddock-api/resources/html/NewOcean.std-theme/synopsis.png and /dev/null differ diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs index 10d6ab10..b1d64acd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -58,7 +58,7 @@ standardTheme :: FilePath -> IO PossibleThemes standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) --- | Default themes that are part of Haddock; added with --default-themes +-- | Default themes that are part of Haddock; added with @--built-in-themes@ -- The first theme in this list is considered the standard theme. -- Themes are "discovered" by scanning the html sub-dir of the libDir, -- and looking for directories with the extension .theme or .std-theme. diff --git a/html-test/ref/A.html b/html-test/ref/A.html index 567e23f2..53a26042 100644 --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -4,7 +4,7 @@ />A
Safe HaskellSafe

Bug973

Synopsis

Documentation

showRead #

Arguments

:: forall a b. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

showRead' #

Arguments

:: forall b a. (Show a, Read b)
=> a

this gets turned into a string...

-> b

...from which this is read

Same as showRead, but with type variable order flipped

\ No newline at end of file diff --git a/html-test/ref/FunArgs.html b/html-test/ref/FunArgs.html index bb54fa27..b40aa97c 100644 --- a/html-test/ref/FunArgs.html +++ b/html-test/ref/FunArgs.html @@ -58,7 +58,9 @@ >Header row, column 1 +(header rows optional)Header 2 +Header 3 +Header 4 +body row 1, column 1column 2column 3column 4Cells may span columns.body row 3Cells may +span rows. +\[ +f(n) = \sum_{i=1} +\]body row 4
:: :: forall a. Ord a:: forall a b c. a-> forall d. d=> forall c. a b c d proxy (a :: ()) b. proxy a200operation successful204operation successful, no body returned404resource not found
:: a

First argument

-> d

Result

:: forall (b :: ()). d ~ a (b :: ()) d. d ~ ()
=> a b c d

abcd

:: forall (a :: ()). proxy a

First argument

BlubType = Show x => x => BlubCtor x
  		• Show x => x => BlubCtor x
  • = C b => b => Ex1 b
  • | C a => a => Ex3 b
  		• C b => b => Ex1 bC a => a => Ex3 b a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead = read . show + +-- | Same as 'showRead', but with type variable order flipped +showRead' + :: forall b a. (Show a, Read b) + => a -- ^ this gets turned into a string... + -> b -- ^ ...from which this is read +showRead' = read . show -- cgit v1.2.3 From 39251d3aa339958aafd8b955f41323a8b0b60012 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 20 Dec 2018 16:16:30 -0500 Subject: Load plugins when compiling each module (#983) * WIP: Load (typechecker) plugins from language pragmas * Revert "Load plugins when starting a GHC session (#905)" This reverts commit 72d82e52f2a6225686d9668790ac33c1d1743193. * Simplify plugin initialization code --- haddock-api/src/Haddock.hs | 6 +----- haddock-api/src/Haddock/Interface.hs | 9 ++++++++- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 7a2df3a2..43f600b4 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -76,7 +76,6 @@ import Packages import Panic (handleGhcException) import Module import FastString -import qualified DynamicLoading -------------------------------------------------------------------------------- -- * Exception handling @@ -450,10 +449,7 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' - hscenv <- GHC.getSession - dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'') - _ <- setSessionDynFlags dynflags''' - ghcActs dynflags''' + ghcActs dynflags'' where -- ignore sublists of flags that start with "+RTS" and end in "-RTS" diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 759d5d03..3d54970b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -64,6 +64,7 @@ import Name (nameIsFromExternalPackage, nameOccName) import OccName (isTcOcc) import RdrName (unQualOK, gre_name, globalRdrEnvElts) import ErrUtils (withTiming) +import DynamicLoading (initializePlugins) #if defined(mingw32_HOST_OS) import System.IO @@ -177,7 +178,13 @@ createIfaces verbosity flags instIfaceMap mods = do processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum + + -- Since GHC 8.6, plugins are initialized on a per module basis + hsc_env' <- getSession + dynflags' <- liftIO (initializePlugins hsc_env' (GHC.ms_hspp_opts modsum)) + let modsum' = modsum { ms_hspp_opts = dynflags' } + + tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum' if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." -- cgit v1.2.3 From a6504507cb7f575dad63aa9f992cfc8d4f70c582 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Jan 2019 13:55:22 -0800 Subject: Print kinded tyvars in constructors for Hoogle (#993) Fixes #992 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 10 ++++++++-- hoogle-test/ref/Bug992/test.txt | 9 +++++++++ hoogle-test/src/Bug992/Bug992.hs | 5 +++++ 3 files changed, 22 insertions(+), 2 deletions(-) create mode 100644 hoogle-test/ref/Bug992/test.txt create mode 100644 hoogle-test/src/Bug992/Bug992.hs diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 5f77c38c..7e2ce2f2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -266,8 +266,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = let c = HsTyVar NoExt NotPromoted (noLoc (tcdName dat)) + as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) + in apps (map noLoc (c : as)) + + tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn + tyVarBndr2Type (UserTyVar _ n) = HsTyVar NoExt NotPromoted n + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig NoExt (noLoc (HsTyVar NoExt NotPromoted n)) k + tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/hoogle-test/ref/Bug992/test.txt b/hoogle-test/ref/Bug992/test.txt new file mode 100644 index 00000000..8ae145c3 --- /dev/null +++ b/hoogle-test/ref/Bug992/test.txt @@ -0,0 +1,9 @@ +-- Hoogle documentation, generated by Haddock +-- See Hoogle, http://www.haskell.org/hoogle/ + +@package test +@version 0.0.0 + +module Bug992 +data K (m :: * -> *) +K :: K (m :: * -> *) diff --git a/hoogle-test/src/Bug992/Bug992.hs b/hoogle-test/src/Bug992/Bug992.hs new file mode 100644 index 00000000..bd772427 --- /dev/null +++ b/hoogle-test/src/Bug992/Bug992.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE KindSignatures #-} + +module Bug992 where + +data K (m :: * -> *) = K -- cgit v1.2.3 From 53997f3db71d113bdad59548e3f16adfe90c112b Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 23 Jan 2019 11:46:46 -0800 Subject: Keep forall on H98 existential data constructors (#1003) The information about whether or not there is a source-level `forall` is already available on a `ConDecl` (as `con_forall`), so we should use it instead of always assuming `False`! Fixes #1002. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- html-test/ref/PatternSyns.html | 8 ++++++-- html-test/ref/Test.html | 24 ++++++++++++++++++------ 4 files changed, 27 insertions(+), 11 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 40ea916f..a84e7e45 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -758,9 +758,9 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode in case det of -- Prefix constructor, e.g. 'Just a' diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 775e0c41..bc6e2c2b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -800,9 +800,9 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of @@ -873,9 +873,9 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) decl = case con of ConDeclH98{ con_args = det , con_ex_tvs = tyVars + , con_forall = L _ forall_ , con_mb_cxt = cxt } -> let context = unLoc (fromMaybe (noLoc []) cxt) - forall_ = False header_ = ppConstrHdr forall_ tyVars context unicode qual in case det of -- Prefix constructor, e.g. 'Just a' diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index bae4b0bd..7e10b755 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -104,7 +104,9 @@ >data BlubType = = forall x.Show x => BlubCtorcodemessagedescription200operation successful204operation successful, no body returned
    forall x.Show x => BlubCtorEx a
    • = = forall b.C b => Ex1 b
    • | | forall b. Ex2 b
    • | | forall b.C a => Ex3 \ No newline at end of file +> -- cgit v1.2.3 From 384577e862171bdedc9311c9d17f7ad3a4a33456 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 17 May 2019 11:23:40 -0400 Subject: Fix #1063 with better parenthesization logic for contexts The only other change in html/hoogle/hyperlinker output for the boot libraries that this caused is a fix to some Hoogle output for implicit params. ``` $ diff -r _build/docs/ old_docs diff -r _build/docs/html/libraries/base/base.txt old_docs/html/libraries/base/base.txt 13296c13296 < assertError :: (?callStack :: CallStack) => Bool -> a -> a --- > assertError :: ?callStack :: CallStack => Bool -> a -> a ``` --- haddock-api/src/Haddock/GhcUtils.hs | 6 ++- html-test/ref/Bug1063.html | 100 ++++++++++++++++++++++++++++++++++++ html-test/src/Bug1063.hs | 9 ++++ 3 files changed, 113 insertions(+), 2 deletions(-) create mode 100644 html-test/ref/Bug1063.html create mode 100644 html-test/src/Bug1063.hs diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 29a52faf..5cc005cc 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -275,11 +275,13 @@ reparenTypePrec = go go p (HsKindSig x ty kind) = paren p PREC_SIG $ HsKindSig x (goL PREC_SIG ty) (goL PREC_SIG kind) go p (HsIParamTy x n ty) - = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) + = paren p PREC_SIG $ HsIParamTy x n (reparenLType ty) go p (HsForAllTy x tvs ty) = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) go p (HsQualTy x ctxt ty) - = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + = let p' [_] = PREC_CTX + p' _ = PREC_TOP -- parens will get added anyways later... + in paren p PREC_CTX $ HsQualTy x (fmap (\xs -> map (goL (p' xs)) xs) ctxt) (goL PREC_TOP ty) go p (HsFunTy x ty1 ty2) = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) go p (HsAppTy x fun_ty arg_ty) diff --git a/html-test/ref/Bug1063.html b/html-test/ref/Bug1063.html new file mode 100644 index 00000000..a7555971 --- /dev/null +++ b/html-test/ref/Bug1063.html @@ -0,0 +1,100 @@ +Bug1063
      forall b.C b => Ex1
      forall b. Ex2 b
      forall b.C a => Ex3 Date: Fri, 25 Jan 2019 10:26:16 -0500 Subject: Fix #1004 with a pinch of dropForAlls --- haddock-api/src/Haddock/Convert.hs | 2 +- html-test/ref/Bug1004.html | 2072 ++++++++++++++++++++++++++++++++++++ html-test/src/Bug1004.hs | 3 + 3 files changed, 2076 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/Bug1004.html create mode 100644 html-test/src/Bug1004.hs diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6eee353b..7735ed0d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -274,7 +274,7 @@ synifyTyCon coax tc -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of + = case splitFunTys (dropForAlls (tyConKind tc)) of (_, ret_kind) | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * | otherwise -> Just (synifyKindSig ret_kind) diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html new file mode 100644 index 00000000..9179e252 --- /dev/null +++ b/html-test/ref/Bug1004.html @@ -0,0 +1,2072 @@ +Bug1004
      Safe HaskellSafe

      Bug1004

      Synopsis

      Documentation

      data Product (f :: k -> Type) (g :: k -> Type) (a :: k) #

      Lifted product of functors.

      Constructors

      Pair (f a) (g a)

      Instances

      Instances details
      Generic1 (Product f g :: k -> Type)
      Instance details

      Defined in Data.Functor.Product

      Associated Types

      type Rep1 (Product f g) :: k -> Type #

      Methods

      from1 :: Product f g a -> Rep1 (Product f g) a #

      to1 :: Rep1 (Product f g) a -> Product f g a #

      (Monad f, Monad g) => Monad (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      (>>=) :: Product f g a -> (a -> Product f g b) -> Product f g b #

      (>>) :: Product f g a -> Product f g b -> Product f g b #

      return :: a -> Product f g a #

      fail :: String -> Product f g a #

      (Functor f, Functor g) => Functor (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      fmap :: (a -> b) -> Product f g a -> Product f g b #

      (<$) :: a -> Product f g b -> Product f g a #

      (MonadFix f, MonadFix g) => MonadFix (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mfix :: (a -> Product f g a) -> Product f g a #

      (Applicative f, Applicative g) => Applicative (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      pure :: a -> Product f g a #

      (<*>) :: Product f g (a -> b) -> Product f g a -> Product f g b #

      liftA2 :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

      (*>) :: Product f g a -> Product f g b -> Product f g b #

      (<*) :: Product f g a -> Product f g b -> Product f g a #

      (Foldable f, Foldable g) => Foldable (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      fold :: Monoid m => Product f g m -> m #

      foldMap :: Monoid m => (a -> m) -> Product f g a -> m #

      foldr :: (a -> b -> b) -> b -> Product f g a -> b #

      foldr' :: (a -> b -> b) -> b -> Product f g a -> b #

      foldl :: (b -> a -> b) -> b -> Product f g a -> b #

      foldl' :: (b -> a -> b) -> b -> Product f g a -> b #

      foldr1 :: (a -> a -> a) -> Product f g a -> a #

      foldl1 :: (a -> a -> a) -> Product f g a -> a #

      toList :: Product f g a -> [a] #

      null :: Product f g a -> Bool #

      length :: Product f g a -> Int #

      elem :: Eq a => a -> Product f g a -> Bool #

      maximum :: Ord a => Product f g a -> a #

      minimum :: Ord a => Product f g a -> a #

      sum :: Num a => Product f g a -> a #

      product :: Num a => Product f g a -> a #

      (Traversable f, Traversable g) => Traversable (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      traverse :: Applicative f0 => (a -> f0 b) -> Product f g a -> f0 (Product f g b) #

      sequenceA :: Applicative f0 => Product f g (f0 a) -> f0 (Product f g a) #

      mapM :: Monad m => (a -> m b) -> Product f g a -> m (Product f g b) #

      sequence :: Monad m => Product f g (m a) -> m (Product f g a) #

      (Eq1 f, Eq1 g) => Eq1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftEq :: (a -> b -> Bool) -> Product f g a -> Product f g b -> Bool #

      (Ord1 f, Ord1 g) => Ord1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftCompare :: (a -> b -> Ordering) -> Product f g a -> Product f g b -> Ordering #

      (Read1 f, Read1 g) => Read1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Product f g a) #

      liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [Product f g a] #

      liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Product f g a) #

      liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [Product f g a] #

      (Show1 f, Show1 g) => Show1 (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Product f g a -> ShowS #

      liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [Product f g a] -> ShowS #

      (MonadZip f, MonadZip g) => MonadZip (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mzip :: Product f g a -> Product f g b -> Product f g (a, b) #

      mzipWith :: (a -> b -> c) -> Product f g a -> Product f g b -> Product f g c #

      munzip :: Product f g (a, b) -> (Product f g a, Product f g b) #

      (Alternative f, Alternative g) => Alternative (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      empty :: Product f g a #

      (<|>) :: Product f g a -> Product f g a -> Product f g a #

      some :: Product f g a -> Product f g [a] #

      many :: Product f g a -> Product f g [a] #

      (MonadPlus f, MonadPlus g) => MonadPlus (Product f g)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      mzero :: Product f g a #

      mplus :: Product f g a -> Product f g a -> Product f g a #

      (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      (==) :: Product f g a -> Product f g a -> Bool #

      (/=) :: Product f g a -> Product f g a -> Bool #

      (Typeable a, Typeable f, Typeable g, Typeable k, Data (f a), Data (g a)) => Data (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g0. g0 -> c g0) -> Product f g a -> c (Product f g a) #

      gunfold :: (forall b r. Data b => c (b -> r) -> c r) -> (forall r. r -> c r) -> Constr -> c (Product f g a) #

      toConstr :: Product f g a -> Constr #

      dataTypeOf :: Product f g a -> DataType #

      dataCast1 :: Typeable t => (forall d. Data d => c (t d)) -> Maybe (c (Product f g a)) #

      dataCast2 :: Typeable t => (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Product f g a)) #

      gmapT :: (forall b. Data b => b -> b) -> Product f g a -> Product f g a #

      gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

      gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Product f g a -> r #

      gmapQ :: (forall d. Data d => d -> u) -> Product f g a -> [u] #

      gmapQi :: Int -> (forall d. Data d => d -> u) -> Product f g a -> u #

      gmapM :: Monad m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> Product f g a -> m (Product f g a) #

      (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      compare :: Product f g a -> Product f g a -> Ordering #

      (<) :: Product f g a -> Product f g a -> Bool #

      (<=) :: Product f g a -> Product f g a -> Bool #

      (>) :: Product f g a -> Product f g a -> Bool #

      (>=) :: Product f g a -> Product f g a -> Bool #

      max :: Product f g a -> Product f g a -> Product f g a #

      min :: Product f g a -> Product f g a -> Product f g a #

      (Read1 f, Read1 g, Read a) => Read (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      readsPrec :: Int -> ReadS (Product f g a) #

      readList :: ReadS [Product f g a] #

      readPrec :: ReadPrec (Product f g a) #

      readListPrec :: ReadPrec [Product f g a] #

      (Show1 f, Show1 g, Show a) => Show (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      Methods

      showsPrec :: Int -> Product f g a -> ShowS #

      show :: Product f g a -> String #

      showList :: [Product f g a] -> ShowS #

      Generic (Product f g a)
      Instance details

      Defined in Data.Functor.Product

      Associated Types

      type Rep (Product f g a) :: Type -> Type #

      Methods

      from :: Product f g a -> Rep (Product f g a) x #

      to :: Rep (Product f g a) x -> Product f g a #

      type Rep1 (Product f g :: k -> Type)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      type Rep1 (Product f g :: k -> Type) = D1 (MetaData "Product" "Data.Functor.Product" "base" False) (C1 (MetaCons "Pair" PrefixI False) (S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 f) :*: S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec1 g)))
      type Rep (Product f g a)

      Since: base-4.9.0.0

      Instance details

      Defined in Data.Functor.Product

      type Rep (Product f g a) = D1 (MetaData "Product" "Data.Functor.Product" "base" False) (C1 (MetaCons "Pair" PrefixI False) (S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (f a)) :*: S1 (MetaSel (Nothing :: Maybe Symbol) NoSourceUnpackedness NoSourceStrictness DecidedLazy) (Rec0 (g a))))
      \ No newline at end of file diff --git a/html-test/src/Bug1004.hs b/html-test/src/Bug1004.hs new file mode 100644 index 00000000..d789e77f --- /dev/null +++ b/html-test/src/Bug1004.hs @@ -0,0 +1,3 @@ +module Bug1004 (Product(..)) where + +import Data.Functor.Product -- cgit v1.2.3 From 7abad07c183af9710e14a96ce3a5ab982c2bbd50 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 28 Jan 2019 16:23:28 -0800 Subject: Loosen 'QuickCheck' and 'hspec' bounds It looks like the new versions don't cause any breakage and loosening the bounds helps deps fit in one stack resolver. --- haddock-api/haddock-api.cabal | 6 +++--- haddock-library/haddock-library.cabal | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 68653c84..b4193456 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -173,8 +173,8 @@ test-suite spec , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 - , hspec >= 2.4.4 && < 2.6 - , QuickCheck ^>= 2.11 + , hspec >= 2.4.4 && < 2.7 + , QuickCheck >= 2.11 && < 2.13 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version @@ -190,7 +190,7 @@ test-suite spec , transformers build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.6 + hspec-discover:hspec-discover >= 2.4.4 && < 2.7 source-repository head type: git diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 0b4405b9..17f556aa 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -76,8 +76,8 @@ test-suite spec , bytestring >= 0.9.2.1 && < 0.11 , containers >= 0.4.2.1 && < 0.7 , transformers >= 0.3.0 && < 0.6 - , hspec >= 2.4.4 && < 2.6 - , QuickCheck ^>= 2.11 + , hspec >= 2.4.4 && < 2.7 + , QuickCheck >= 2.11 && < 2.13 , text >= 1.2.3.0 && < 1.3 , parsec >= 3.1.13.0 && < 3.2 , deepseq >= 1.3 && < 1.5 -- cgit v1.2.3 From 032ff0dd3411f66131854c4314b9f00c8540fd10 Mon Sep 17 00:00:00 2001 From: Nathan Collins Date: Sat, 2 Feb 2019 15:41:33 -0800 Subject: Update README instructions for Stack No need to `stack install` Haddock to test it. Indeed, `stack install` changes the `haddock` on user's `PATH` if `~/.local/bin` is on user's `PATH` which may not be desirable when hacking on Haddock. --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 38354996..69f88087 100644 --- a/README.md +++ b/README.md @@ -82,9 +82,9 @@ cabal test ```bash stack init -stack install +stack build # run the test suite -export HADDOCK_PATH="$HOME/.local/bin/haddock" +export HADDOCK_PATH="$(stack exec which haddock)" stack test ``` -- cgit v1.2.3 From cacd245a5e0a0f2e14d4ed34e877835fdef3367f Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 4 Feb 2019 18:44:25 +0200 Subject: Make a fixture of weird parsing of lists (#997) The second example is interesting. If there's a list directly after the header, and that list has deeper structure, the parser is confused: It finds two lists: - One with the first nested element, - everything after it I'm not trying to fix this, as I'm not even sure this is a bug, and not a feature. --- haddock-library/fixtures/examples/list-blocks1.input | 15 +++++++++++++++ haddock-library/fixtures/examples/list-blocks1.parsed | 12 ++++++++++++ haddock-library/fixtures/examples/list-blocks2.input | 10 ++++++++++ haddock-library/fixtures/examples/list-blocks2.parsed | 10 ++++++++++ haddock-library/haddock-library.cabal | 1 - 5 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 haddock-library/fixtures/examples/list-blocks1.input create mode 100644 haddock-library/fixtures/examples/list-blocks1.parsed create mode 100644 haddock-library/fixtures/examples/list-blocks2.input create mode 100644 haddock-library/fixtures/examples/list-blocks2.parsed diff --git a/haddock-library/fixtures/examples/list-blocks1.input b/haddock-library/fixtures/examples/list-blocks1.input new file mode 100644 index 00000000..72a0640b --- /dev/null +++ b/haddock-library/fixtures/examples/list-blocks1.input @@ -0,0 +1,15 @@ +* Something about foo + + @ + foo :: a -> b -> c + foo a b = bar c b + @ + +* Something about bar + + @ + bar :: a -> b -> c + bar a b = foo b a + @ + +* And then we continue diff --git a/haddock-library/fixtures/examples/list-blocks1.parsed b/haddock-library/fixtures/examples/list-blocks1.parsed new file mode 100644 index 00000000..9fc4f0ba --- /dev/null +++ b/haddock-library/fixtures/examples/list-blocks1.parsed @@ -0,0 +1,12 @@ +DocUnorderedList + [DocAppend + (DocParagraph (DocString "Something about foo")) + (DocCodeBlock + (DocString + (concat ["foo :: a -> b -> c\n", "foo a b = bar c b\n"]))), + DocAppend + (DocParagraph (DocString "Something about bar")) + (DocCodeBlock + (DocString + (concat ["bar :: a -> b -> c\n", "bar a b = foo b a\n"]))), + DocParagraph (DocString "And then we continue")] diff --git a/haddock-library/fixtures/examples/list-blocks2.input b/haddock-library/fixtures/examples/list-blocks2.input new file mode 100644 index 00000000..91492adb --- /dev/null +++ b/haddock-library/fixtures/examples/list-blocks2.input @@ -0,0 +1,10 @@ +=== Title + +* List directly +* after the title + + @ + with some inline things + @ + +* is parsed weirdly diff --git a/haddock-library/fixtures/examples/list-blocks2.parsed b/haddock-library/fixtures/examples/list-blocks2.parsed new file mode 100644 index 00000000..169677b7 --- /dev/null +++ b/haddock-library/fixtures/examples/list-blocks2.parsed @@ -0,0 +1,10 @@ +DocAppend + (DocAppend + (DocHeader + Header {headerLevel = 3, headerTitle = DocString "Title"}) + (DocUnorderedList + [DocParagraph (DocString "List directly"), + DocAppend + (DocParagraph (DocString "after the title")) + (DocCodeBlock (DocString "with some inline things\n"))])) + (DocUnorderedList [DocParagraph (DocString "is parsed weirdly")]) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 17f556aa..32ffc110 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -91,7 +91,6 @@ test-suite fixtures main-is: Fixtures.hs ghc-options: -Wall -O0 hs-source-dirs: fixtures - buildable: False build-depends: base >= 4.5 && < 4.13 , base-compat >= 0.9.3 && < 0.11 -- cgit v1.2.3 From dd47029cb29c80b1ab4db520c9c2ce4dca37f833 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 19 Jul 2018 11:42:26 -0700 Subject: Support value/type namespaces on identifier links Identifier links can be prefixed with a 'v' or 't' to indicate the value or type namespace of the desired identifier. For example: -- | Some link to a value: v'Data.Functor.Identity' -- -- Some link to a type: t'Data.Functor.Identity' The default is still the type (with a warning about the ambiguity) --- doc/markup.rst | 10 ++ haddock-api/src/Haddock.hs | 3 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 55 ++++++-- .../src/Haddock/Interface/ParseModuleHeader.hs | 3 +- haddock-api/src/Haddock/Parser.hs | 13 +- haddock-api/src/Haddock/Types.hs | 6 + .../src/Documentation/Haddock/Parser.hs | 22 ++-- haddock-library/src/Documentation/Haddock/Types.hs | 10 ++ .../test/Documentation/Haddock/ParserSpec.hs | 6 + html-test/Main.hs | 2 +- html-test/ref/Bug253.html | 16 +-- html-test/ref/NamespacedIdentifiers.html | 146 +++++++++++++++++++++ html-test/src/NamespacedIdentifiers.hs | 13 ++ .../NamespacedIdentifier/NamespacedIdentifiers.tex | 41 ++++++ latex-test/ref/NamespacedIdentifier/haddock.sty | 57 ++++++++ latex-test/ref/NamespacedIdentifier/main.tex | 11 ++ .../NamespacedIdentifier/NamespacedIdentifier.hs | 13 ++ 17 files changed, 388 insertions(+), 39 deletions(-) create mode 100644 html-test/ref/NamespacedIdentifiers.html create mode 100644 html-test/src/NamespacedIdentifiers.hs create mode 100644 latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex create mode 100644 latex-test/ref/NamespacedIdentifier/haddock.sty create mode 100644 latex-test/ref/NamespacedIdentifier/main.tex create mode 100644 latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs diff --git a/doc/markup.rst b/doc/markup.rst index 9fb0209a..48a6f4ad 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -913,6 +913,16 @@ If ``M.T`` is not otherwise in scope, then Haddock will simply emit a link pointing to the entity ``T`` exported from module ``M`` (without checking to see whether either ``M`` or ``M.T`` exist). +Since values and types live in different namespaces in Haskell, it is +possible for a reference such as ``'X'`` to be ambiguous. In such a case, +Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t`` +(for type) immediately before the link: :: + + -- | An implicit reference to 'X', the type constructor + -- An explicit reference to v'X', the data constructor + -- An explicit reference to t'X', the type constructor + data X = X + To make life easier for documentation writers, a quoted identifier is only interpreted as such if the quotes surround a lexically valid Haskell identifier. This means, for example, that it normally isn't diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 358e5c3a..1378c173 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -42,6 +42,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) import Data.List (isPrefixOf) @@ -662,7 +663,7 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! parseParas dflags Nothing str + return . Just $! second rdrName $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 59ad4fdf..66083cf5 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -34,8 +34,8 @@ import Haddock.Types import Name import Outputable ( showPpr, showSDoc ) import RdrName +import RdrHsSyn (setRdrNameSpace) import EnumSet -import RnEnv (dataTcOccs) processDocStrings :: DynFlags -> Maybe Package -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (MDoc Name)) @@ -89,24 +89,37 @@ processModuleHeader dflags pkgName gre safety mayStr = do -- fallbacks in case we can't locate the identifiers. -- -- See the comments in the source for implementation commentary. -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> ErrMsgM (Doc Name) +rename :: DynFlags -> GlobalRdrEnv -> Doc NsRdrName -> ErrMsgM (Doc Name) rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier x -> do + DocIdentifier (NsRdrName ns x) -> do + let occ = rdrNameOcc x + isValueName = isDataOcc occ || isVarOcc occ + + let valueNsChoices | isValueName = [x] + | otherwise = [] -- is this ever possible? + typeNsChoices | isValueName = [setRdrNameSpace x tcName] + | otherwise = [x] + -- Generate the choices for the possible kind of thing this - -- is. - let choices = dataTcOccs x + -- is. We narrow down the possibilities with the namespace (if + -- there is one). + let choices = case ns of + Value -> valueNsChoices + Type -> typeNsChoices + None -> valueNsChoices ++ typeNsChoices -- Lookup any GlobalRdrElts that match the choices. case concatMap (\c -> lookupGRE_RdrName c gre) choices of -- We found no names in the env so we start guessing. [] -> case choices of - -- This shouldn't happen as 'dataTcOccs' always returns at least its input. - [] -> pure (DocMonospaced (DocString (showPpr dflags x))) + -- The only way this can happen is if a value namespace was + -- specified on something that cannot be a value. + [] -> invalidValue dflags x -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -116,7 +129,7 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags a + a:_ -> outOfScope dflags ns a -- There is only one name in the environment that matches so -- use it. @@ -155,17 +168,23 @@ rename dflags gre = rn -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> RdrName -> ErrMsgM (Doc a) -outOfScope dflags x = +outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a) +outOfScope dflags ns x = case x of Unqual occ -> warnAndMonospace occ Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) Orig _ occ -> warnAndMonospace occ Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope where + prefix = case ns of + Value -> "the value " + Type -> "the type " + None -> "" + warnAndMonospace a = do - tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it anyway."] + tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it\n" ++ + " it anyway."] pure (monospaced a) monospaced a = DocMonospaced (DocString (showPpr dflags a)) @@ -184,7 +203,7 @@ ambiguous dflags x gres = do msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by hiding some imports.\n" ++ + " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type @@ -198,3 +217,13 @@ ambiguous dflags x gres = do isLocalName _ = False x_str = '\'' : showPpr dflags x ++ "'" defnLoc = showSDoc dflags . pprNameDefnLoc + +-- | Handle value-namespaced names that cannot be for values. +-- +-- Emits a warning that the value-namespace is invalid on a non-value identifier. +invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a) +invalidValue dflags x = do + tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++ + " namespaced as such. Did you mean to specify a type namespace\n" ++ + " instead?"] + pure (DocMonospaced (DocString (showPpr dflags x))) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 050901b6..802ea773 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -16,7 +16,6 @@ import Data.Char import DynFlags import Haddock.Parser import Haddock.Types -import RdrName -- ----------------------------------------------------------------------------- -- Parsing module headers @@ -24,7 +23,7 @@ import RdrName -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted. -parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) +parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) parseModuleHeader dflags pkgName str0 = let getKey :: String -> String -> (Maybe String,String) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index e31ea6a8..8b7dda7c 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -15,26 +15,27 @@ module Haddock.Parser ( parseParas import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types +import Haddock.Types (NsRdrName(..)) import DynFlags ( DynFlags ) import FastString ( fsLit ) import Lexer ( mkPState, unP, ParseResult(POk) ) import Parser ( parseIdentifier ) import RdrName ( RdrName ) -import SrcLoc ( mkRealSrcLoc, unLoc ) +import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod RdrName +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod RdrName +parseString :: DynFlags -> String -> DocH mod NsRdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> String -> Maybe RdrName -parseIdent dflags str0 = +parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName +parseIdent dflags ns str0 = let buffer = stringToStringBuffer str0 realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) + POk _ (L _ name) -> Just (NsRdrName ns name) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index a4ef5f82..e8da4120 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -284,6 +284,12 @@ noDocForDecl = (Documentation Nothing Nothing, mempty) -- | Type of environment used to cross-reference identifiers in the syntax. type LinkEnv = Map Name Module +-- | An 'RdrName' tagged with some type/value namespace information. +data NsRdrName = NsRdrName + { namespace :: !Namespace + , rdrName :: !RdrName + } + -- | Extends 'Name' with cross-reference information. data DocName = Documented Name Module diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 82d65a0a..e9b1c496 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -28,6 +28,7 @@ import Control.Applicative import Control.Arrow (first) import Control.Monad import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) +import Data.Foldable (asum) import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -75,24 +76,24 @@ isSymbolChar c = not (isPuncChar c) && case generalCategory c of #endif -- | Identifier string surrounded with opening and closing quotes/backticks. -type Identifier = (Char, String, Char) +data Identifier = Identifier !Namespace !Char String !Char -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String -toRegular = fmap (\(_, x, _) -> x) +toRegular = fmap (\(Identifier _ _ x _) -> x) -- | Maps over 'DocIdentifier's over 'String' with potentially failing -- conversion using user-supplied function. If the conversion fails, -- the identifier is deemed to not be valid and is treated as a -- regular string. -overIdentifier :: (String -> Maybe a) +overIdentifier :: (Namespace -> String -> Maybe a) -> DocH mod Identifier -> DocH mod a overIdentifier f d = g d where - g (DocIdentifier (o, x, e)) = case f x of - Nothing -> DocString $ o : x ++ [e] + g (DocIdentifier (Identifier ns o x e)) = case f ns x of + Nothing -> DocString $ renderNs ns ++ [o] ++ x ++ [e] Just x' -> DocIdentifier x' g DocEmpty = DocEmpty g (DocAppend x x') = DocAppend (g x) (g x') @@ -314,7 +315,8 @@ markdownImage :: Parser (DocH mod Identifier) markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) - stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r]) + stringMarkup = plainMarkup (const "") renderIdent + renderIdent (Identifier ns l c r) = renderNs ns <> [l] <> c <> [r] -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) @@ -857,9 +859,13 @@ parseValid = p some -- 'String' from the string it deems valid. identifier :: Parser (DocH mod Identifier) identifier = do + ns <- asum [ Value <$ Parsec.char 'v' + , Type <$ Parsec.char 't' + , pure None + ] o <- idDelim vid <- parseValid e <- idDelim - return $ DocIdentifier (o, vid, e) + return $ DocIdentifier (Identifier ns o vid e) where - idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`') + idDelim = Parsec.oneOf "'`" diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index f8f7d353..ba2f873c 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -203,6 +203,16 @@ instance Bitraversable DocH where bitraverse f g (DocTable (Table header body)) = (\h b -> DocTable (Table h b)) <$> traverse (traverse (bitraverse f g)) header <*> traverse (traverse (bitraverse f g)) body #endif +-- | The namespace qualification for an identifier. +data Namespace = Value | Type | None deriving (Eq, Ord, Enum, Show) + +-- | Render the a namespace into the same format it was initially parsed. +renderNs :: Namespace -> String +renderNs Value = "v" +renderNs Type = "t" +renderNs None = "" + + -- | 'DocMarkupH' is a set of instructions for marking up documentation. -- In fact, it's really just a mapping from 'Doc' to some other -- type [a], where [a] is usually the type of the output (HTML, say). diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 6269184a..e186a5cf 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -132,6 +132,12 @@ spec = do it "can parse an identifier that starts with an underscore" $ do "'_x'" `shouldParseTo` DocIdentifier "_x" + it "can parse value-namespaced identifiers" $ do + "v'foo'" `shouldParseTo` DocIdentifier "foo" + + it "can parse type-namespaced identifiers" $ do + "t'foo'" `shouldParseTo` DocIdentifier "foo" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" diff --git a/html-test/Main.hs b/html-test/Main.hs index d65a5087..26eefe4a 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -45,7 +45,7 @@ stripIfRequired mdl = -- | List of modules in which we don't 'stripLinks' preserveLinksModules :: [String] -preserveLinksModules = ["Bug253"] +preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"] ingoredTests :: [FilePath] ingoredTests = diff --git a/html-test/ref/Bug253.html b/html-test/ref/Bug253.html index a1c0f905..a01c9578 100644 --- a/html-test/ref/Bug253.html +++ b/html-test/ref/Bug253.html @@ -4,9 +4,9 @@ />Bug253
      Safe HaskellSafe

      NamespacedIdentifiers

      Synopsis

      Documentation

      data Foo #

      A link to:

      • the type Bar
      • the constructor Bar
      • the unimported but qualified type A
      • the unimported but qualified value A

      Constructors

      Bar 

      data Bar #

      A link to the value Foo (which shouldn't exist).

      diff --git a/html-test/src/NamespacedIdentifiers.hs b/html-test/src/NamespacedIdentifiers.hs new file mode 100644 index 00000000..6f59d247 --- /dev/null +++ b/html-test/src/NamespacedIdentifiers.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar diff --git a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex new file mode 100644 index 00000000..f39bd0ec --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{NamespacedIdentifiers} +\label{module:NamespacedIdentifiers} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module NamespacedIdentifiers ( + Foo(Bar), Bar + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Foo +\end{tabular}]\haddockbegindoc +A link to:\par +\begin{itemize} +\item +the type \haddockid{Bar}\par + +\item +the constructor \haddockid{Bar}\par + +\item +the unimported but qualified type \haddockid{A}\par + +\item +the unimported but qualified value \haddockid{A}\par + +\end{itemize} + +\enspace \emph{Constructors}\par +\haddockbeginconstrs +\haddockdecltt{=} & \haddockdecltt{Bar} & \\ +\end{tabulary}\par +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Bar +\end{tabular}]\haddockbegindoc +A link to the value \haddocktt{Foo} (which shouldn't exist).\par + +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/haddock.sty b/latex-test/ref/NamespacedIdentifier/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/NamespacedIdentifier/main.tex b/latex-test/ref/NamespacedIdentifier/main.tex new file mode 100644 index 00000000..75493e12 --- /dev/null +++ b/latex-test/ref/NamespacedIdentifier/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{NamespacedIdentifiers} +\end{document} \ No newline at end of file diff --git a/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs new file mode 100644 index 00000000..6f59d247 --- /dev/null +++ b/latex-test/src/NamespacedIdentifier/NamespacedIdentifier.hs @@ -0,0 +1,13 @@ +module NamespacedIdentifiers where + +-- | A link to: +-- +-- * the type t'Bar' +-- * the constructor v'Bar' +-- * the unimported but qualified type t'A.A' +-- * the unimported but qualified value v'A.A' +-- +data Foo = Bar + +-- | A link to the value v'Foo' (which shouldn't exist). +data Bar -- cgit v1.2.3 From a5199600c39d25d7b71dcb2328000c1c49ad95a2 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 6 Feb 2019 01:01:41 -0800 Subject: Better identifier parsing * '(<|>)' and '`elem`' now get parsed and rendered properly as links * 'DbModule'/'DbUnitId' now properly get split apart into two links * tuple names now get parsed properly * some more small niceties... The identifier parsing code is more precise and more efficient (although to be fair: it is also longer and in its own module). On the rendering side, we need to pipe through information about backticks/parens/neither all the way through from renaming to the backends. In terms of impact: a total of 35 modules in the entirety of the bootlib + ghc lib docs change. The only "regression" is things like '\0'. These should be changed to @\\0@ (the path by which this previously worked seems accidental). --- doc/markup.rst | 9 +- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 19 +- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 16 +- haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 28 +- haddock-api/src/Haddock/Interface/Json.hs | 5 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 58 +++-- haddock-api/src/Haddock/Interface/Rename.hs | 4 +- haddock-api/src/Haddock/InterfaceFile.hs | 27 +- haddock-api/src/Haddock/Parser.hs | 19 +- haddock-api/src/Haddock/Types.hs | 28 +- haddock-library/haddock-library.cabal | 2 + .../src/Documentation/Haddock/Parser.hs | 63 +---- .../src/Documentation/Haddock/Parser/Identifier.hs | 186 ++++++++++++++ .../src/Documentation/Haddock/Parser/Monad.hs | 13 +- .../test/Documentation/Haddock/ParserSpec.hs | 9 +- haddock.cabal | 1 + html-test/ref/Identifiers.html | 286 +++++++++++++++++++++ html-test/ref/Test.html | 2 +- html-test/src/Identifiers.hs | 35 +++ 21 files changed, 679 insertions(+), 135 deletions(-) create mode 100644 haddock-library/src/Documentation/Haddock/Parser/Identifier.hs create mode 100644 html-test/ref/Identifiers.html create mode 100644 html-test/src/Identifiers.hs diff --git a/doc/markup.rst b/doc/markup.rst index 48a6f4ad..56238855 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -932,14 +932,9 @@ necessary to escape the single quote when used as an apostrophe: :: Nothing special is needed to hyperlink identifiers which contain apostrophes themselves: to hyperlink ``foo'`` one would simply type -``'foo''``. Hyperlinking operators works in exactly the same way. +``'foo''``. Hyperlinking operators works in exactly the same way. :: -Note that it is not possible to directly hyperlink an identifier in infix -form or an operator in prefix form. The next best thing to do is to wrap -the whole identifier in monospaced text and put the parentheses/backticks -outside of the identifier, but inside the link: :: - - -- | A prefix operator @('++')@ and an infix identifier @\``elem`\`@. + -- | A prefix operator @'(++)'@ and an infix identifier @'`elem`'@. Emphasis, Bold and Monospaced Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 1378c173..3e0332b5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -663,7 +663,7 @@ getPrologue dflags flags = h <- openFile filename ReadMode hSetEncoding h utf8 str <- hGetContents h -- semi-closes the handle - return . Just $! second rdrName $ parseParas dflags Nothing str + return . Just $! second (fmap rdrName) $ parseParas dflags Nothing str _ -> throwE "multiple -p/--prologue options" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9e3186e5..f581c01a 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -334,7 +334,7 @@ markupTag dflags = Markup { markupString = str, markupAppend = (++), markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupIdentifierUnchecked = box (TagInline "a") . str . showWrapped (out dflags . snd), markupModule = box (TagInline "a") . str, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d0752506..85769b13 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1106,8 +1106,8 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString +ppVerbOccName :: Wrap OccName -> LaTeX +ppVerbOccName = text . latexFilter . showWrapped occNameString ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS @@ -1115,13 +1115,12 @@ ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString +ppVerbDocName :: Wrap DocName -> LaTeX +ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName) -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc +ppVerbRdrName :: Wrap RdrName -> LaTeX +ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc) ppDocName :: DocName -> LaTeX @@ -1182,7 +1181,7 @@ parLatexMarkup ppId = Markup { markupString = \s v -> text (fixString v s), markupAppend = \l r v -> l v <> r v, markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), + markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), @@ -1239,11 +1238,11 @@ parLatexMarkup ppId = Markup { where theid = ppId_ id -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX) latexMarkup = parLatexMarkup ppVerbDocName -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX) rdrLatexMarkup = parLatexMarkup ppVerbRdrName diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 09aabc0c..1901cf05 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -171,12 +171,12 @@ flatten x = [x] -- extract/append the underlying 'Doc' and convert it to 'Html'. For -- 'CollapsingHeader', we attach extra info to the generated 'Html' -- that allows us to expand/collapse the content. -hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (ModuleName, OccName) id -> Html +hackMarkup :: DocMarkup id Html -> Maybe Package -> Hack (Wrap (ModuleName, OccName)) id -> Html hackMarkup fmt' currPkg h' = let (html, ms) = hackMarkup' fmt' h' in html +++ renderMeta fmt' currPkg (metaConcat ms) where - hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id + hackMarkup' :: DocMarkup id Html -> Hack (Wrap (ModuleName, OccName)) id -> (Html, [Meta]) hackMarkup' fmt h = case h of UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) @@ -206,7 +206,7 @@ renderMeta _ _ _ = noHtml -- | Goes through 'hackMarkup' to generate the 'Html' rather than -- skipping straight to 'markup': this allows us to employ XHtml -- specific hacks to the tree first. -markupHacked :: DocMarkup id Html +markupHacked :: DocMarkup (Wrap id) Html -> Maybe Package -- this package -> Maybe String -> MDoc id @@ -220,7 +220,7 @@ docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtml n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + where fmt = parHtmlMarkup qual True (ppWrappedDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements. @@ -228,16 +228,16 @@ docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack' -> Maybe Package -- ^ Current package -> Qualification -> MDoc DocName -> Html docToHtmlNoAnchors n pkg qual = markupHacked fmt pkg n . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + where fmt = parHtmlMarkup qual False (ppWrappedDocName qual Raw) origDocToHtml :: Maybe Package -> Qualification -> MDoc Name -> Html origDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) + where fmt = parHtmlMarkup qual True (const (ppWrappedName Raw)) rdrDocToHtml :: Maybe Package -> Qualification -> MDoc RdrName -> Html rdrDocToHtml pkg qual = markupHacked fmt pkg Nothing . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) + where fmt = parHtmlMarkup qual True (const (ppRdrName . unwrap)) docElement :: (Html -> Html) -> Html -> Html @@ -273,7 +273,7 @@ cleanup = overDoc (markup fmtUnParagraphLists) unParagraph (DocParagraph d) = d unParagraph doc = doc - fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph, markupOrderedList = DocOrderedList . map unParagraph diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index 574045e0..6a047747 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -13,7 +13,8 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) + ppModule, ppModuleRef, ppIPName, linkId, Notation(..), + ppWrappedDocName, ppWrappedName, ) where @@ -24,7 +25,7 @@ import Haddock.Utils import Text.XHtml hiding ( name, p, quote ) import qualified Data.Map as M -import qualified Data.List as List +import Data.List ( stripPrefix ) import GHC hiding (LexicalFixity(..)) import Name @@ -49,9 +50,11 @@ ppIPName :: HsIPName -> Html ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - +ppUncheckedLink :: Qualification -> Wrap (ModuleName, OccName) -> Html +ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml + where + (mdl, occ) = unwrap x + occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName -- The Bool indicates if it is to be rendered in infix notation ppLDocName :: Qualification -> Notation -> Located DocName -> Html @@ -68,6 +71,19 @@ ppDocName qual notation insertAnchors docName = ppQualifyName qual notation name (nameModule name) | otherwise -> ppName notation name + +ppWrappedDocName :: Qualification -> Notation -> Bool -> Wrap DocName -> Html +ppWrappedDocName qual notation insertAnchors docName = case docName of + Unadorned n -> ppDocName qual notation insertAnchors n + Parenthesized n -> ppDocName qual Prefix insertAnchors n + Backticked n -> ppDocName qual Infix insertAnchors n + +ppWrappedName :: Notation -> Wrap Name -> Html +ppWrappedName notation docName = case docName of + Unadorned n -> ppName notation n + Parenthesized n -> ppName Prefix n + Backticked n -> ppName Infix n + -- | Render a name depending on the selected qualification mode ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html ppQualifyName qual notation name mdl = @@ -79,7 +95,7 @@ ppQualifyName qual notation name mdl = then ppName notation name else ppFullQualName notation mdl name RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + case stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x Just [] -> ppName notation name -- sub-module, A.B.x -> B.x diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 636d3e19..a9834fa0 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -62,7 +62,10 @@ jsonMDoc MetaDoc{..} = ] jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap (moduleNameString . fst) nameStableString doc)) +jsonDoc doc = jsonString (show (bimap showModName showName doc)) + where + showModName = showWrapped (moduleNameString . fst) + showName = showWrapped nameStableString jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 66083cf5..faf23728 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,6 +22,7 @@ module Haddock.Interface.LexParseRn import Avail import Control.Arrow import Control.Monad +import Data.Functor (($>)) import Data.List import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) @@ -95,8 +96,9 @@ rename dflags gre = rn rn d = case d of DocAppend a b -> DocAppend <$> rn a <*> rn b DocParagraph doc -> DocParagraph <$> rn doc - DocIdentifier (NsRdrName ns x) -> do - let occ = rdrNameOcc x + DocIdentifier i -> do + let NsRdrName ns x = unwrap i + occ = rdrNameOcc x isValueName = isDataOcc occ || isVarOcc occ let valueNsChoices | isValueName = [x] @@ -119,7 +121,7 @@ rename dflags gre = rn case choices of -- The only way this can happen is if a value namespace was -- specified on something that cannot be a value. - [] -> invalidValue dflags x + [] -> invalidValue dflags i -- There was nothing in the environment so we need to -- pick some default from what's available to us. We @@ -129,14 +131,14 @@ rename dflags gre = rn -- type constructor names (such as in #253). So now we -- only get type constructor links if they are actually -- in scope. - a:_ -> outOfScope dflags ns a + a:_ -> outOfScope dflags ns (i $> a) -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier (gre_name a)) + [a] -> pure (DocIdentifier (i $> gre_name a)) -- There are multiple names available. - gres -> ambiguous dflags x gres + gres -> ambiguous dflags i gres DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -168,13 +170,13 @@ rename dflags gre = rn -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'. -outOfScope :: DynFlags -> Namespace -> RdrName -> ErrMsgM (Doc a) +outOfScope :: DynFlags -> Namespace -> Wrap RdrName -> ErrMsgM (Doc a) outOfScope dflags ns x = - case x of - Unqual occ -> warnAndMonospace occ - Qual mdl occ -> pure (DocIdentifierUnchecked (mdl, occ)) - Orig _ occ -> warnAndMonospace occ - Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope + case unwrap x of + Unqual occ -> warnAndMonospace (x $> occ) + Qual mdl occ -> pure (DocIdentifierUnchecked (x $> (mdl, occ))) + Orig _ occ -> warnAndMonospace (x $> occ) + Exact name -> warnAndMonospace (x $> name) -- Shouldn't happen since x is out of scope where prefix = case ns of Value -> "the value " @@ -182,11 +184,11 @@ outOfScope dflags ns x = None -> "" warnAndMonospace a = do - tell ["Warning: " ++ prefix ++ "'" ++ showPpr dflags a ++ "' is out of scope.\n" ++ - " If you qualify the identifier, haddock can try to link it\n" ++ - " it anyway."] - pure (monospaced a) - monospaced a = DocMonospaced (DocString (showPpr dflags a)) + let a' = showWrapped (showPpr dflags) a + tell ["Warning: " ++ prefix ++ "'" ++ a' ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it anyway."] + pure (monospaced a') + monospaced = DocMonospaced . DocString -- | Handle ambiguous identifiers. -- @@ -194,36 +196,42 @@ outOfScope dflags ns x = -- -- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. ambiguous :: DynFlags - -> RdrName + -> Wrap NsRdrName -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do let noChildren = map availName (gresToAvailInfo gres) dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren - msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ + msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ - " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + " Defaulting to the one defined " ++ defnLoc dflt -- TODO: Once we have a syntax for namespace qualification (#667) we may also -- want to emit a warning when an identifier is a data constructor for a type -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier dflt) + pure (DocIdentifier (x $> dflt)) where isLocalName (nameSrcLoc -> RealSrcLoc {}) = True isLocalName _ = False - x_str = '\'' : showPpr dflags x ++ "'" defnLoc = showSDoc dflags . pprNameDefnLoc -- | Handle value-namespaced names that cannot be for values. -- -- Emits a warning that the value-namespace is invalid on a non-value identifier. -invalidValue :: DynFlags -> RdrName -> ErrMsgM (Doc a) +invalidValue :: DynFlags -> Wrap NsRdrName -> ErrMsgM (Doc a) invalidValue dflags x = do - tell ["Warning: '" ++ showPpr dflags x ++ "' cannot be value, yet it is\n" ++ + tell ["Warning: " ++ showNsRdrName dflags x ++ " cannot be value, yet it is\n" ++ " namespaced as such. Did you mean to specify a type namespace\n" ++ " instead?"] - pure (DocMonospaced (DocString (showPpr dflags x))) + pure (DocMonospaced (DocString (showNsRdrName dflags x))) + +-- | Printable representation of a wrapped and namespaced name +showNsRdrName :: DynFlags -> Wrap NsRdrName -> String +showNsRdrName dflags = (\p i -> p ++ "'" ++ i ++ "'") <$> prefix <*> ident + where + ident = showWrapped (showPpr dflags . rdrName) + prefix = renderNs . namespace . unwrap diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 57e6d699..88238f04 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -173,8 +173,8 @@ renameLDocHsSyn :: LHsDocString -> RnM LHsDocString renameLDocHsSyn = return -renameDoc :: Traversable t => t Name -> RnM (t DocName) -renameDoc = traverse rename +renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName)) +renameDoc = traverse (traverse rename) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index e1d8dbe1..7645b1bb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) -binaryInterfaceVersion = 34 +binaryInterfaceVersion = 35 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -701,3 +701,28 @@ instance Binary DocName where name <- get bh return (Undocumented name) _ -> error "get DocName: Bad h" + +instance Binary n => Binary (Wrap n) where + put_ bh (Unadorned n) = do + putByte bh 0 + put_ bh n + put_ bh (Parenthesized n) = do + putByte bh 1 + put_ bh n + put_ bh (Backticked n) = do + putByte bh 2 + put_ bh n + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + return (Unadorned name) + 1 -> do + name <- get bh + return (Parenthesized name) + 2 -> do + name <- get bh + return (Backticked name) + _ -> error "get Wrap: Bad h" diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 8b7dda7c..6d5dc103 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -15,27 +15,32 @@ module Haddock.Parser ( parseParas import qualified Documentation.Haddock.Parser as P import Documentation.Haddock.Types -import Haddock.Types (NsRdrName(..)) +import Haddock.Types import DynFlags ( DynFlags ) import FastString ( fsLit ) import Lexer ( mkPState, unP, ParseResult(POk) ) import Parser ( parseIdentifier ) -import RdrName ( RdrName ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) -parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod NsRdrName + +parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName) parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p -parseString :: DynFlags -> String -> DocH mod NsRdrName +parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName) parseString d = P.overIdentifier (parseIdent d) . P.parseString -parseIdent :: DynFlags -> Namespace -> String -> Maybe NsRdrName +parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns str0 = - let buffer = stringToStringBuffer str0 + let buffer = stringToStringBuffer str1 realSrcLc = mkRealSrcLoc (fsLit "") 0 0 pstate = mkPState dflags buffer realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) in case unP parseIdentifier pstate of - POk _ (L _ name) -> Just (NsRdrName ns name) + POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index e8da4120..cd4ac1a1 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -42,7 +42,7 @@ import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt import OccName -import Outputable +import Outputable hiding ((<>)) ----------------------------------------------------------------------------- -- * Convenient synonyms @@ -334,6 +334,26 @@ instance SetName DocName where setName name' (Documented _ mdl) = Documented name' mdl setName name' (Undocumented _) = Undocumented name' +-- | Adds extra "wrapper" information to a name. +-- +-- This is to work around the fact that most name types in GHC ('Name', 'RdrName', +-- 'OccName', ...) don't include backticks or parens. +data Wrap n + = Unadorned { unwrap :: n } -- ^ don't do anything to the name + | Parenthesized { unwrap :: n } -- ^ add parentheses around the name + | Backticked { unwrap :: n } -- ^ add backticks around the name + deriving (Show, Functor, Foldable, Traversable) + +-- | Useful for debugging +instance Outputable n => Outputable (Wrap n) where + ppr (Unadorned n) = ppr n + ppr (Parenthesized n) = hcat [ char '(', ppr n, char ')' ] + ppr (Backticked n) = hcat [ char '`', ppr n, char '`' ] + +showWrapped :: (a -> String) -> Wrap a -> String +showWrapped f (Unadorned n) = f n +showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" +showWrapped f (Backticked n) = "`" ++ f n ++ "`" ----------------------------------------------------------------------------- @@ -429,10 +449,10 @@ instance NamedThing name => NamedThing (InstOrigin name) where type LDoc id = Located (Doc id) -type Doc id = DocH (ModuleName, OccName) id -type MDoc id = MetaDoc (ModuleName, OccName) id +type Doc id = DocH (Wrap (ModuleName, OccName)) (Wrap id) +type MDoc id = MetaDoc (Wrap (ModuleName, OccName)) (Wrap id) -type DocMarkup id a = DocMarkupH (ModuleName, OccName) id a +type DocMarkup id a = DocMarkupH (Wrap (ModuleName, OccName)) id a instance (NFData a, NFData mod) => NFData (DocH mod a) where diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index b24db5d4..5475d61b 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -49,6 +49,7 @@ library other-modules: Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier test-suite spec import: lib-defaults @@ -70,6 +71,7 @@ test-suite spec Documentation.Haddock.Parser.UtilSpec Documentation.Haddock.ParserSpec Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.10.0 diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index e9b1c496..36c8bb5b 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -27,8 +27,7 @@ module Documentation.Haddock.Parser ( import Control.Applicative import Control.Arrow (first) import Control.Monad -import Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace) -import Data.Foldable (asum) +import Data.Char (chr, isUpper, isAlpha, isSpace) import Data.List (intercalate, unfoldr, elemIndex) import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid @@ -37,6 +36,7 @@ import Documentation.Haddock.Doc import Documentation.Haddock.Markup ( markup, plainMarkup ) import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util +import Documentation.Haddock.Parser.Identifier import Documentation.Haddock.Types import Prelude hiding (takeWhile) import qualified Prelude as P @@ -47,37 +47,10 @@ import Text.Parsec (try) import qualified Data.Text as T import Data.Text (Text) -#if MIN_VERSION_base(4,9,0) -import Text.Read.Lex (isSymbolChar) -#else -import Data.Char (GeneralCategory (..), - generalCategory) -#endif -- $setup -- >>> :set -XOverloadedStrings -#if !MIN_VERSION_base(4,9,0) --- inlined from base-4.10.0.0 -isSymbolChar :: Char -> Bool -isSymbolChar c = not (isPuncChar c) && case generalCategory c of - MathSymbol -> True - CurrencySymbol -> True - ModifierSymbol -> True - OtherSymbol -> True - DashPunctuation -> True - OtherPunctuation -> c `notElem` ("'\"" :: String) - ConnectorPunctuation -> c /= '_' - _ -> False - where - -- | The @special@ character class as defined in the Haskell Report. - isPuncChar :: Char -> Bool - isPuncChar = (`elem` (",;()[]{}`" :: String)) -#endif - --- | Identifier string surrounded with opening and closing quotes/backticks. -data Identifier = Identifier !Namespace !Char String !Char - -- | Drops the quotes/backticks around all identifiers, as if they -- were valid but still 'String's. toRegular :: DocH mod Identifier -> DocH mod String @@ -838,34 +811,6 @@ autoUrl = mkLink <$> url mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing - --- | Parses strings between identifier delimiters. Consumes all input that it --- deems to be valid in an identifier. Note that it simply blindly consumes --- characters and does no actual validation itself. -parseValid :: Parser String -parseValid = p some - where - idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_') - - p p' = do - vs <- p' idChar - c <- peekChar' - case c of - '`' -> return vs - '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ] - _ -> fail "outofvalid" - --- | Parses identifiers with help of 'parseValid'. Asks GHC for --- 'String' from the string it deems valid. +-- | Parses identifiers with help of 'parseValid'. identifier :: Parser (DocH mod Identifier) -identifier = do - ns <- asum [ Value <$ Parsec.char 'v' - , Type <$ Parsec.char 't' - , pure None - ] - o <- idDelim - vid <- parseValid - e <- idDelim - return $ DocIdentifier (Identifier ns o vid e) - where - idDelim = Parsec.oneOf "'`" +identifier = DocIdentifier <$> parseValid diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs new file mode 100644 index 00000000..7bc98b62 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Documentation.Haddock.Parser.Identifier +-- Copyright : (c) Alec Theriault 2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Functionality for parsing identifiers and operators + +module Documentation.Haddock.Parser.Identifier ( + Identifier(..), + parseValid, +) where + +import Documentation.Haddock.Types ( Namespace(..) ) +import Documentation.Haddock.Parser.Monad +import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Char (isAlpha, isAlphaNum) +import Control.Monad (guard) +import Data.Functor (($>)) +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory (..), + generalCategory) +#endif + +import Data.Maybe + +-- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. +data Identifier = Identifier !Namespace !Char String !Char + deriving (Show, Eq) + +parseValid :: Parser Identifier +parseValid = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + + case takeIdentifier inp of + Nothing -> Parsec.parserFail "parseValid: Failed to match a valid identifier" + Just (ns, op, ident, cl, inp') -> + let posOp = updatePosChar pos op + posIdent = T.foldl updatePosChar posOp ident + posCl = updatePosChar posIdent cl + s' = s{ stateInput = inp', statePos = posCl } + in setParserState s' $> Identifier ns op (T.unpack ident) cl + + +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> c `notElem` "'\"" + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif + +-- | Try to parse a delimited identifier off the front of the given input. +-- +-- This tries to match as many valid Haskell identifiers/operators as possible, +-- to the point of sometimes accepting invalid things (ex: keywords). Some +-- considerations: +-- +-- - operators and identifiers can have module qualifications +-- - operators can be wrapped in parens (for prefix) +-- - identifiers can be wrapped in backticks (for infix) +-- - delimiters are backticks or regular ticks +-- - since regular ticks are also valid in identifiers, we opt for the +-- longest successful parse +-- +-- This function should make /O(1)/ allocations +takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text) +takeIdentifier input = listToMaybe $ do + + -- Optional namespace + let (ns, input') = case T.uncons input of + Just ('v', i) -> (Value, i) + Just ('t', i) -> (Type, i) + _ -> (None, input) + + -- Opening tick + (op, input'') <- maybeToList (T.uncons input') + guard (op == '\'' || op == '`') + + -- Identifier/operator + (ident, input''') <- wrapped input'' + + -- Closing tick + (cl, input'''') <- maybeToList (T.uncons input''') + guard (cl == '\'' || cl == '`') + + pure (ns, op, ident, cl, input'''') + + where + + -- | Parse out a wrapped, possibly qualified, operator or identifier + wrapped t = do + (c, t' ) <- maybeToList (T.uncons t) + -- Tuples + case c of + '(' | Just (c', _) <- T.uncons t' + , c' == ',' || c' == ')' + -> do let (commas, t'') = T.span (== ',') t' + (')', t''') <- maybeToList (T.uncons t'') + pure (T.take (T.length commas + 2) t, t''') + + -- Parenthesized + '(' -> do (n, t'' ) <- general False 0 [] t' + (')', t''') <- maybeToList (T.uncons t'') + pure (T.take (n + 2) t, t''') + + -- Backticked + '`' -> do (n, t'' ) <- general False 0 [] t' + ('`', t''') <- maybeToList (T.uncons t'') + pure (T.take (n + 2) t, t''') + + -- Unadorned + _ -> do (n, t'' ) <- general False 0 [] t + pure (T.take n t, t'') + + -- | Parse out a possibly qualified operator or identifier + general :: Bool -- ^ refuse inputs starting with operators + -> Int -- ^ total characters \"consumed\" so far + -> [(Int, Text)] -- ^ accumulated results + -> Text -- ^ current input + -> [(Int, Text)] -- ^ total characters parsed & what remains + general !identOnly !i acc t + -- Starts with an identifier (either just an identifier, or a module qual) + | Just (n, rest) <- identLike t + = if T.null rest + then acc + else case T.head rest of + '`' -> (n + i, rest) : acc + ')' -> (n + i, rest) : acc + '.' -> general False (n + i + 1) acc (T.tail rest) + '\'' -> let (m, rest') = quotes rest + in general True (n + m + 1 + i) ((n + m + i, rest') : acc) (T.tail rest') + _ -> acc + + -- An operator + | Just (n, rest) <- optr t + , not identOnly + = (n + i, rest) : acc + + -- Anything else + | otherwise + = acc + + -- | Parse an identifier off the front of the input + identLike t + | T.null t = Nothing + | isAlpha (T.head t) || '_' == T.head t + = let !(idt, rest) = T.span (\c -> isAlphaNum c || c == '_') t + !(octos, rest') = T.span (== '#') rest + in Just (T.length idt + T.length octos, rest') + | otherwise = Nothing + + -- | Parse all but the last quote off the front of the input + -- PRECONDITION: T.head t == '\'' + quotes :: Text -> (Int, Text) + quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1 + in (n, T.drop n t) + + -- | Parse an operator off the front of the input + optr t = let !(op, rest) = T.span isSymbolChar t + in if T.null op then Nothing else Just (T.length op, rest) diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 8f5bd217..fa46f536 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -4,6 +4,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Documentation.Haddock.Parser.Monad +-- Copyright : (c) Alec Theriault 2018-2019, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Defines the Parsec monad over which all parsing is done and also provides +-- more efficient versions of the usual parsec combinator functions (but +-- specialized to 'Text'). module Documentation.Haddock.Parser.Monad where @@ -96,7 +108,6 @@ takeWhile f = do s' = s{ stateInput = inp', statePos = pos' } setParserState s' $> t - -- | Like 'takeWhile', but fails if no characters matched. -- -- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient. diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index e186a5cf..bc40a0a2 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -112,7 +112,7 @@ spec = do "``" `shouldParseTo` "``" it "can parse an identifier in infix notation enclosed within backticks" $ do - "``infix``" `shouldParseTo` "`" <> DocIdentifier "infix" <> "`" + "``infix``" `shouldParseTo` DocIdentifier "`infix`" it "can parse identifiers containing a single quote" $ do "'don't'" `shouldParseTo` DocIdentifier "don't" @@ -138,6 +138,13 @@ spec = do it "can parse type-namespaced identifiers" $ do "t'foo'" `shouldParseTo` DocIdentifier "foo" + it "can parse parenthesized operators and backticked identifiers" $ do + "'(<|>)'" `shouldParseTo` DocIdentifier "(<|>)" + "'`elem`'" `shouldParseTo` DocIdentifier "`elem`" + + it "can properly figure out the end of identifiers" $ do + "'DbModule'/'DbUnitId'" `shouldParseTo` DocIdentifier "DbModule" <> "/" <> DocIdentifier "DbUnitId" + context "when parsing operators" $ do it "can parse an operator enclosed within single quotes" $ do "'.='" `shouldParseTo` DocIdentifier ".=" diff --git a/haddock.cabal b/haddock.cabal index 2b8ee6ff..91a5ea3d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -89,6 +89,7 @@ executable haddock other-modules: Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Identifier Documentation.Haddock.Types Documentation.Haddock.Doc Documentation.Haddock.Parser.Util diff --git a/html-test/ref/Identifiers.html b/html-test/ref/Identifiers.html new file mode 100644 index 00000000..1a0a18a5 --- /dev/null +++ b/html-test/ref/Identifiers.html @@ -0,0 +1,286 @@ +Identifiers
      Safe HaskellSafe

      Identifiers

      Synopsis

      Documentation

      data Id #

      Constructors

      Id 

      data a :* b #

      Constructors

      a :* b 

      foo :: () #

      diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html index b76622e7..aefc4d14 100644 --- a/html-test/ref/Test.html +++ b/html-test/ref/Test.html @@ -2364,7 +2364,7 @@ is at the beginning of the line).f' - but f' doesn't get link'd 'f\''

      Date: Mon, 25 Feb 2019 21:53:56 -0800 Subject: Fix standalone deriving docs Docs on standalone deriving decls for classes with associated types should be associated with the class instance, not the associated type instance. Fixes #1033 --- haddock-api/src/Haddock/Interface/Create.hs | 4 +- html-test/ref/Bug1033.html | 222 ++++++++++++++++++++++++++++ html-test/src/Bug1033.hs | 11 ++ 3 files changed, 235 insertions(+), 2 deletions(-) create mode 100644 html-test/ref/Bug1033.html create mode 100644 html-test/src/Bug1033.hs diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index a4408434..146c3cc8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -132,8 +132,8 @@ createInterface tm flags modMap instIfaceMap = do fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom sem_mdl) - $ map getName instances - ++ map getName fam_instances + $ map getName fam_instances + ++ map getName instances -- Locations of all TH splices splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] diff --git a/html-test/ref/Bug1033.html b/html-test/ref/Bug1033.html new file mode 100644 index 00000000..32a9f6d3 --- /dev/null +++ b/html-test/ref/Bug1033.html @@ -0,0 +1,222 @@ +Bug1033
      Safe HaskellSafe

      Bug1033

      Documentation

      data Foo #

      Constructors

      Foo

      Instances

      Instances details
      Generic Foo #

      This does some generic foos.

      Instance details

      Defined in Bug1033

      Associated Types

      type Rep Foo :: Type -> Type #

      Methods

      from :: Foo -> Rep Foo x #

      to :: Rep Foo x -> Foo #

      type Rep Foo #
      Instance details

      Defined in Bug1033

      type Rep Foo = D1 (MetaData "Foo" "Bug1033" "main" False) (C1 (MetaCons "Foo" PrefixI False) (U1 :: Type -> Type))
      \ No newline at end of file diff --git a/html-test/src/Bug1033.hs b/html-test/src/Bug1033.hs new file mode 100644 index 00000000..fdf5a57e --- /dev/null +++ b/html-test/src/Bug1033.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Bug1033 where + +import GHC.Generics + +data Foo = Foo + +-- | This does some generic foos. +deriving instance Generic Foo -- cgit v1.2.3 From b682041ed1cbeaf5aa501f85e4e46a6d2e39da3a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 26 Feb 2019 08:46:45 -0800 Subject: Fix bogus identifier defaulting This avoids a situation in which an identifier would get defaulted to a completely different identifier. Prior to this commit, the 'Bug1035' test case would hyperlink 'Foo' into 'Bar'! Fixes #1035. --- haddock-api/src/Haddock/Interface/LexParseRn.hs | 14 +-- html-test/ref/Bug1035.html | 146 ++++++++++++++++++++++++ html-test/src/Bug1035.hs | 9 ++ 3 files changed, 160 insertions(+), 9 deletions(-) create mode 100644 html-test/ref/Bug1035.html create mode 100644 html-test/src/Bug1035.hs diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index faf23728..0b40ed3c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -19,7 +19,6 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where -import Avail import Control.Arrow import Control.Monad import Data.Functor (($>)) @@ -200,10 +199,9 @@ ambiguous :: DynFlags -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. -> ErrMsgM (Doc Name) ambiguous dflags x gres = do - let noChildren = map availName (gresToAvailInfo gres) - dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren + let dflt = maximumBy (comparing (gre_lcl &&& isTyConName . gre_name)) gres msg = "Warning: " ++ showNsRdrName dflags x ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") gres ++ " You may be able to disambiguate the identifier by qualifying it or\n" ++ " by specifying the type/value namespace explicitly.\n" ++ " Defaulting to the one defined " ++ defnLoc dflt @@ -212,12 +210,10 @@ ambiguous dflags x gres = do -- of the same name, but not the only constructor. -- For example, for @data D = C | D@, someone may want to reference the @D@ -- constructor. - when (length noChildren > 1) $ tell [msg] - pure (DocIdentifier (x $> dflt)) + when (length (gresToAvailInfo gres) > 1) $ tell [msg] + pure (DocIdentifier (x $> gre_name dflt)) where - isLocalName (nameSrcLoc -> RealSrcLoc {}) = True - isLocalName _ = False - defnLoc = showSDoc dflags . pprNameDefnLoc + defnLoc = showSDoc dflags . pprNameDefnLoc . gre_name -- | Handle value-namespaced names that cannot be for values. -- diff --git a/html-test/ref/Bug1035.html b/html-test/ref/Bug1035.html new file mode 100644 index 00000000..946fc235 --- /dev/null +++ b/html-test/ref/Bug1035.html @@ -0,0 +1,146 @@ +Bug1035
      Safe HaskellSafe

      Bug1035

      Synopsis

      Documentation

      data Foo #

      Constructors

      Bar

      data Bar #

      Constructors

      Foo

      foo :: () #

      A link to Bar

      \ No newline at end of file diff --git a/html-test/src/Bug1035.hs b/html-test/src/Bug1035.hs new file mode 100644 index 00000000..3516c08f --- /dev/null +++ b/html-test/src/Bug1035.hs @@ -0,0 +1,9 @@ +module Bug1035 where + +data Foo = Bar + +data Bar = Foo + +-- | A link to 'Bar' +foo :: () +foo = () -- cgit v1.2.3 From 59843f9e3d222901421a92fff793a1e031f38f65 Mon Sep 17 00:00:00 2001 From: Xia Li-yao Date: Wed, 27 Feb 2019 21:53:27 -0500 Subject: Menu item controlling which instances are expanded/collapsed (#1007) Adds a menu item (like "Quick Jump") for options related to displaying instances. This provides functionality for: * expanding/collapsing all instances on the currently opened page * controlling whether instances are expanded/collapsed by default * controlling whether the state of instances should be "remembered" This new functionality is implemented in Typescript in `details-helper`. The built-in-themes style switcher also got a revamp so that all three of QuickJump, the style switcher, and instance preferences now have the same style and implementation structure. See also: https://mail.haskell.org/pipermail/haskell-cafe/2019-January/130495.html Fixes #698. Co-authored-by: Lysxia Co-authored-by: Nathan Collins --- .../resources/html/Linuwial.std-theme/linuwial.css | 43 +- haddock-api/resources/html/README.md | 8 +- haddock-api/resources/html/haddock-bundle.min.js | 2 +- .../resources/html/js-src/details-helper.ts | 106 ----- .../resources/html/js-src/details-helper.tsx | 464 +++++++++++++++++++++ haddock-api/resources/html/js-src/init.ts | 4 +- haddock-api/resources/html/js-src/style-menu.tsx | 177 ++++---- haddock-api/resources/html/quick-jump.css | 60 ++- 8 files changed, 635 insertions(+), 229 deletions(-) delete mode 100644 haddock-api/resources/html/js-src/details-helper.ts create mode 100644 haddock-api/resources/html/js-src/details-helper.tsx diff --git a/haddock-api/resources/html/Linuwial.std-theme/linuwial.css b/haddock-api/resources/html/Linuwial.std-theme/linuwial.css index 7ae19a93..330c605a 100644 --- a/haddock-api/resources/html/Linuwial.std-theme/linuwial.css +++ b/haddock-api/resources/html/Linuwial.std-theme/linuwial.css @@ -468,42 +468,10 @@ table.info { text-align: right; } -div#style-menu-holder { - position: relative; - z-index: 2; - display: inline; -} - -#style-menu { - position: absolute; - z-index: 1; - overflow: visible; - background: #374c5e; - margin: 0; - text-align: center; - right: 0; - padding: 0; - top: 1.25em; -} - #style-menu li { - display: inline-block; + display: block; border-style: none; - margin: 0; - padding: 0; - color: #000; list-style-type: none; - border-top: 1px solid #919191 -} - -#style-menu li + li { - border-left: 1px solid #919191; -} - -#style-menu a { - width: 6em; - padding: 3px; - display: block; } #footer { @@ -896,3 +864,12 @@ div#style-menu-holder { } /* @end */ + +/* @group Dropdown menus */ + +#preferences-menu, #style-menu { + width: 25em; + overflow-y: auto; +} + +/* @end */ diff --git a/haddock-api/resources/html/README.md b/haddock-api/resources/html/README.md index 0552f6fd..d555989d 100644 --- a/haddock-api/resources/html/README.md +++ b/haddock-api/resources/html/README.md @@ -13,4 +13,10 @@ After each change to the TypeScript sources, compile and copy the generated file ``` gulp && cp *.min.js path-to/generated-haddock-docs && cp *.js.map path-to/generated-haddock-docs -``` \ No newline at end of file +``` + +If you are editing the CSS, you'll also need to copy the edited CSS files. E.g. if you are editing the global/default quick-jump.css and the Linuwial theme's CSS, then + +``` +cp quick-jump.css Linuwial.std-theme/linuwial.css path-to/generated-haddock-docs +``` diff --git a/haddock-api/resources/html/haddock-bundle.min.js b/haddock-api/resources/html/haddock-bundle.min.js index 7881dc10..45adda98 100644 --- a/haddock-api/resources/html/haddock-bundle.min.js +++ b/haddock-api/resources/html/haddock-bundle.min.js @@ -1,2 +1,2 @@ -!function i(s,a,l){function c(t,e){if(!a[t]){if(!s[t]){var n="function"==typeof require&&require;if(!e&&n)return n(t,!0);if(u)return u(t,!0);var o=new Error("Cannot find module '"+t+"'");throw o.code="MODULE_NOT_FOUND",o}var r=a[t]={exports:{}};s[t][0].call(r.exports,function(e){return c(s[t][1][e]||e)},r,r.exports,i,s,a,l)}return a[t].exports}for(var u="function"==typeof require&&require,e=0;e element with id '"+e+"'");return t}function o(e){for(var t,n=e.target,o=n.id,r=u(o),i=r.element.open,s=0,a=r.toggles;swindow.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return h(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,h=void 0===u?[]:u,d=t.resultMap,p=void 0===d?{}:d,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=h.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var k=i.split(this.options.tokenSeparator),b=[],x=0;x=c.length;if(this._log("\nCheck Matches: "+j),(g||_.isMatch)&&j){var E=p[a];E?E.output.push({key:n,arrayIndex:r,value:i,score:I,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:I,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(U(i))for(var T=0,P=i.length;T element with id '"+e+"'");return t}function x(){return u.defaultInstanceState==i.Open}function w(e){for(var t=S(e.target.id),n=t.element.open,o=0,r=t.toggles;owindow.innerHeight?this.searchResults.scrollTop+=e.bottom-window.innerHeight+80:e.topn)return u(e,this.pattern,o);var r=this.options,i=r.location,s=r.distance,a=r.threshold,l=r.findAllMatches,c=r.minMatchCharLength;return d(e,this.pattern,this.patternAlphabet,{location:i,distance:s,threshold:a,findAllMatches:l,minMatchCharLength:c})}}]),y}();e.exports=r},function(e,t,n){"use strict";var u=n(0);e.exports=function(e,t){return function e(t,n,o){if(n){var r=n.indexOf("."),i=n,s=null;-1!==r&&(i=n.slice(0,r),s=n.slice(r+1));var a=t[i];if(null!=a)if(s||"string"!=typeof a&&"number"!=typeof a)if(u(a))for(var l=0,c=a.length;l 0 and <= 1");p=p.name}else a[p]={weight:1};this._analyze({key:p,value:this.options.getFn(u,p),record:u,index:l},{resultMap:o,results:r,tokenSearchers:e,fullSearcher:t})}return{weights:a,results:r}}},{key:"_analyze",value:function(e,t){var n=e.key,o=e.arrayIndex,r=void 0===o?-1:o,i=e.value,s=e.record,a=e.index,l=t.tokenSearchers,c=void 0===l?[]:l,u=t.fullSearcher,d=void 0===u?[]:u,h=t.resultMap,p=void 0===h?{}:h,f=t.results,v=void 0===f?[]:f;if(null!=i){var g=!1,m=-1,y=0;if("string"==typeof i){this._log("\nKey: "+(""===n?"-":n));var _=d.search(i);if(this._log('Full text: "'+i+'", score: '+_.score),this.options.tokenize){for(var b=i.split(this.options.tokenSeparator),k=[],S=0;S=c.length;if(this._log("\nCheck Matches: "+T),(g||_.isMatch)&&T){var N=p[a];N?N.output.push({key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}):(p[a]={item:s,output:[{key:n,arrayIndex:r,value:i,score:A,matchedIndices:_.matchedIndices}]},v.push(p[a]))}}else if(V(i))for(var P=0,j=i.length;P are not in their default state */ - -function lookupDetailsRegistry(id: string): DetailsInfo { - const info = detailsRegistry[id]; - if (info == undefined) { throw new Error(`could not find
      element with id '${id}'`); } - return info; -} - -function onDetailsToggle(ev: Event) { - const element = ev.target as HTMLDetailsElement; - const id = element.id; - const info = lookupDetailsRegistry(id); - const isOpen = info.element.open; - for (const toggle of info.toggles) { - if (toggle.classList.contains('details-toggle-control')) { - toggle.classList.add(isOpen ? 'collapser' : 'expander'); - toggle.classList.remove(isOpen ? 'expander' : 'collapser'); - } - } - if (element.open == info.openByDefault) { - delete toggled[id]; - } else { - toggled[id] = true; - } - rememberToggled(); -} - -function gatherDetailsElements() { - const els: HTMLDetailsElement[] = Array.prototype.slice.call(document.getElementsByTagName('details')); - for (const el of els) { - if (typeof el.id == "string" && el.id.length > 0) { - detailsRegistry[el.id] = { - element: el, - openByDefault: !!el.open, - toggles: [] // added later - }; - el.addEventListener('toggle', onDetailsToggle); - } - } -} - -function toggleDetails(id: string) { - const {element} = lookupDetailsRegistry(id); - element.open = !element.open; -} - -function rememberToggled() { - const sections: string[] = Object.keys(toggled); - // cookie specific to this page; don't use setCookie which sets path=/ - document.cookie = "toggled=" + encodeURIComponent(sections.join('+')); -} - -function restoreToggled() { - const cookie = getCookie("toggled"); - if (!cookie) { return; } - const ids = cookie.split('+'); - for (const id of ids) { - const info = detailsRegistry[id]; - toggled[id] = true; - if (info) { - info.element.open = !info.element.open; - } - } -} - -function onToggleClick(ev: MouseEvent) { - ev.preventDefault(); - const toggle = ev.currentTarget as HTMLElement; - const id = toggle.getAttribute('data-details-id'); - if (!id) { throw new Error("element with class 'details-toggle' has no 'data-details-id' attribute!"); } - toggleDetails(id); -} - -function initCollapseToggles() { - const toggles: HTMLElement[] = Array.prototype.slice.call(document.getElementsByClassName('details-toggle')); - toggles.forEach(toggle => { - const id = toggle.getAttribute('data-details-id'); - if (!id) { throw new Error("element with class 'details-toggle' has no 'data-details-id' attribute!"); } - const info = lookupDetailsRegistry(id); - info.toggles.push(toggle); - toggle.addEventListener('click', onToggleClick); - if (toggle.classList.contains('details-toggle-control')) { - toggle.classList.add(info.element.open ? 'collapser' : 'expander'); - } - }); -} - -export function init() { - gatherDetailsElements(); - restoreToggled(); - initCollapseToggles(); -} \ No newline at end of file diff --git a/haddock-api/resources/html/js-src/details-helper.tsx b/haddock-api/resources/html/js-src/details-helper.tsx new file mode 100644 index 00000000..871b5417 --- /dev/null +++ b/haddock-api/resources/html/js-src/details-helper.tsx @@ -0,0 +1,464 @@ +// This file implements the UI and logic for collapsing and expanding +// instance lists ("details"). +// +// A configuration ('GlobalConfig') controlled by the UI is persisted +// in local storage in the user's browser. The configuration includes: +// +// * a global default state ('defaultInstanceState') for all instance +// lists. The possible values for the global default are "collapsed" +// and "expanded". +// +// * a global boolean option ('rememberToggles') to remember which +// specific instance lists are not in the default state (e.g. which +// instance lists are expanded when the default is "collapsed"). +// +// * a local / per-page record of which specific instance lists are +// not in the default state, when the global option +// ('rememberToggles') to remember this info is enabled. +// +// The UI consists of an Instances menu with buttons for expanding and +// collapsing all instance lists in the current module, a checkbox for +// setting the global default state, and a checkbox to enable +// remembering which instance lists are not in the global default +// state. Also, each instance list on each module page has buttons for +// collapsing and expanding. +// +// The logic of the UI is as follows: +// +// * setting the global default state erases any record of which +// specific instances are in the non-default state, and collapses or +// expands all instance lists on the current page to be in the +// global default state. +// +// * changing boolean option for remembering which specific instance +// lists are not in the default state erases any existing record of +// which instances are not in the default state across all pages, +// and updates the record for the current page when the option is +// set to true. No collapsing or expanding is done. +// +// * toggling the collapse/expand state of a specific instance list +// causes the state of that specific instance list to be recorded in +// the persisted configuration iff the new state of that specific +// instance list is different from the global default state, and the +// option to remember instance list states is enabled. There are two +// ways to toggle the collapse/expand state of a specific instance, +// by clicking its collapse/expand button, and by clicking the +// "collapse all" or "expand all" button in the Instances menu. +// +// This file also implements an association between elements (with +// class "details-toggle" and "details-toggle-control") that can be +// clicked to expand/collapse
      elements, and the details +// elements themselves. Note that this covers both
      elements +// that list instances -- what the above explained UI and logic is +// concerned with -- and details about individual instances themselves +// -- which the above is not concerend with. The association includes +// adding event listeners that change CSS classes back and forth +// between "expander" and "collapser"; these classes determine whether +// an element is adorned with a right arrow ("expander") or a down +// arrow ("collapser"). I don't understand why we don't directly use +// the the HTML element type to allow the
      elements +// to be directly clickable. +import preact = require("preact"); + +const { h, Component } = preact; + +enum DefaultState { Closed, Open } + +interface GlobalConfig { + defaultInstanceState: DefaultState + rememberToggles: boolean +} + +// Hackage domain-wide config +const globalConfig: GlobalConfig = { + defaultInstanceState: DefaultState.Open, + rememberToggles: true, +}; + +class PreferencesButton extends Component { + render(props: { title: string, onClick: () => void }) { + function onClick(e: Event) { + e.preventDefault(); + props.onClick(); + } + return
    • {props.title}
      • ; + } +} + +function addPreferencesButton(action: () => void) { + const pageMenu = document.querySelector('#page-menu') as HTMLUListElement; + const dummy = document.createElement('li'); + pageMenu.insertBefore(dummy, pageMenu.firstChild); + preact.render(, pageMenu, dummy); +} + +type PreferencesProps = { + showHideTrigger: (action: () => void) => void +} + +type PreferencesState = { + isVisible: boolean +} + +class Preferences extends Component { + componentWillMount() { + document.addEventListener('mousedown', this.hide.bind(this)); + + document.addEventListener('keydown', (e) => { + if (this.state.isVisible) { + if (e.key === 'Escape') { + this.hide(); + } + } + }) + } + + hide() { + this.setState({ isVisible: false }); + } + + show() { + if (!this.state.isVisible) { + this.setState({ isVisible: true }); + } + } + + toggleVisibility() { + if (this.state.isVisible) { + this.hide(); + } else { + this.show(); + } + } + + componentDidMount() { + this.props.showHideTrigger(this.toggleVisibility.bind(this)); + } + + render(props: PreferencesProps, state: PreferencesState) { + const stopPropagation = (e: Event) => { e.stopPropagation(); }; + + return
      + +
      ; + } +} + +function storeGlobalConfig() { + const json = JSON.stringify(globalConfig); + try { + // https://developer.mozilla.org/en-US/docs/Web/API/Storage/setItem#Exceptions. + localStorage.setItem('global', json); + } catch (e) {} +} + +var globalConfigLoaded: boolean = false; + +function loadGlobalConfig() { + if (globalConfigLoaded) { return; } + globalConfigLoaded = true; + const global = localStorage.getItem('global'); + if (!global) { return; } + try { + const globalConfig_ = JSON.parse(global); + globalConfig.defaultInstanceState = globalConfig_.defaultInstanceState; + globalConfig.rememberToggles = globalConfig_.rememberToggles; + } catch(e) { + // Gracefully handle errors related to changed config format. + if (e instanceof SyntaxError || e instanceof TypeError) { + localStorage.removeItem('global'); + } else { + throw e; + } + } +} + +function setDefaultInstanceState(s: DefaultState) { + return (e: Event) => { + globalConfig.defaultInstanceState = s; + putInstanceListsInDefaultState(); + storeGlobalConfig(); + clearLocalStorage(); + storeLocalConfig(); + } +} + +function setRememberToggles(e: Event) { + const checked: boolean = (e as any).target.checked; + globalConfig.rememberToggles = checked; + storeGlobalConfig(); + clearLocalStorage(); + storeLocalConfig(); +} + +// Click event consumer for "default collapse" instance menu check box. +function defaultCollapseOnClick(e: Event) { + const us = document.getElementById('default-collapse-instances') as HTMLInputElement; + if (us !== null) { + if (us.checked) { + setDefaultInstanceState(DefaultState.Closed)(e); + } else { + setDefaultInstanceState(DefaultState.Open)(e); + } + } +} + +// Instances menu. +function PreferencesMenu() { + loadGlobalConfig(); + return
      +
      + + +
      +
      + + + Collapse All Instances By Default +
      +
      + + +
      +
      ; +} + +interface HTMLDetailsElement extends HTMLElement { + open: boolean +} + +interface DetailsInfo { + element: HTMLDetailsElement + // Here 'toggles' is the list of all elements of class + // 'details-toggle-control' that control toggling 'element'. I + // believe this list is always length zero or one. + toggles: HTMLElement[] +} + +// Mapping from
      elements to their info. +const detailsRegistry: { [id: string]: DetailsInfo } = {}; + +function lookupDetailsRegistry(id: string): DetailsInfo { + const info = detailsRegistry[id]; + if (info == undefined) { throw new Error(`could not find
      element with id '${id}'`); } + return info; +} + +// Return true iff instance lists are open by default. +function getDefaultOpenSetting(): boolean { + return globalConfig.defaultInstanceState == DefaultState.Open; +} + +// Event handler for "toggle" events, which are triggered when a +//
      element's "open" property changes. We don't deal with +// any config stuff here, because we only change configs in response +// to mouse clicks. In contrast, for example, this event is triggred +// automatically once for every
      element when the user clicks +// the "collapse all elements" button. +function onToggleEvent(ev: Event) { + const element = ev.target as HTMLDetailsElement; + const id = element.id; + const info = lookupDetailsRegistry(id); + const isOpen = info.element.open; + // Update the CSS of the toggle element users can click on to toggle + // 'element'. The "collapser" and "expander" classes control what + // kind of arrow appears next to the 'toggle' element. + for (const toggle of info.toggles) { + if (toggle.classList.contains('details-toggle-control')) { + toggle.classList.add(isOpen ? 'collapser' : 'expander'); + toggle.classList.remove(isOpen ? 'expander' : 'collapser'); + } + } +} + +function gatherDetailsElements() { + const els: HTMLDetailsElement[] = Array.prototype.slice.call(document.getElementsByTagName('details')); + for (const el of els) { + if (typeof el.id == "string" && el.id.length > 0) { + detailsRegistry[el.id] = { + element: el, + toggles: [] // Populated later by 'initCollapseToggles'. + }; + el.addEventListener('toggle', onToggleEvent); + } + } +} + +// Return the id of the
      element that the given 'toggle' +// element toggles. +function getDataDetailsId(toggle: Element): string { + const id = toggle.getAttribute('data-details-id'); + if (!id) { throw new Error("element with class " + toggle + " has no 'data-details-id' attribute!"); } + return id; +} + +// Toggle the "open" state of a
      element when that element's +// toggle element is clicked. +function toggleDetails(toggle: Element) { + const id = getDataDetailsId(toggle); + const {element} = lookupDetailsRegistry(id); + element.open = !element.open; +} + +// Prefix for local keys used with local storage. Idea is that other +// modules could also use local storage with a different prefix and we +// wouldn't step on each other's toes. +// +// NOTE: we're using the browser's "local storage" API via the +// 'localStorage' object to store both "local" (to the current Haddock +// page) and "global" (across all Haddock pages) configuration. Be +// aware of these two different uses of the term "local". +const localStoragePrefix: string = "local-details-config:"; + +// Local storage key for the current page. +function localStorageKey(): string { + return localStoragePrefix + document.location.pathname; +} + +// Clear all local storage related to instance list configs. +function clearLocalStorage() { + const keysToDelete: string[] = []; + for (var i = 0; i < localStorage.length; ++i) { + const key = localStorage.key(i); + if (key !== null && key.startsWith(localStoragePrefix)) { + keysToDelete.push(key); + } + } + keysToDelete.forEach(key => { + localStorage.removeItem(key); + }); +} + +// Compute and save the set of instance list ids that aren't in the +// default state. +function storeLocalConfig() { + if (!globalConfig.rememberToggles) return; + const instanceListToggles: HTMLElement[] = + // Restrict to 'details-toggle' elements for "instances" + // *plural*. These are the toggles that control instance lists and + // not the list of methods for individual instances. + Array.prototype.slice.call(document.getElementsByClassName( + 'instances details-toggle details-toggle-control')); + const nonDefaultInstanceListIds: string[] = []; + instanceListToggles.forEach(toggle => { + const id = getDataDetailsId(toggle); + const details = document.getElementById(id) as HTMLDetailsElement; + if (details.open != getDefaultOpenSetting()) { + nonDefaultInstanceListIds.push(id); + } + }); + + const json = JSON.stringify(nonDefaultInstanceListIds); + try { + // https://developer.mozilla.org/en-US/docs/Web/API/Storage/setItem#Exceptions. + localStorage.setItem(localStorageKey(), json); + } catch (e) {} +} + +function putInstanceListsInDefaultState() { + switch (globalConfig.defaultInstanceState) { + case DefaultState.Closed: _collapseAllInstances(true); break; + case DefaultState.Open: _collapseAllInstances(false); break; + default: break; + } +} + +// Expand and collapse instance lists according to global and local +// config. +function restoreToggled() { + loadGlobalConfig(); + putInstanceListsInDefaultState(); + if (!globalConfig.rememberToggles) { return; } + const local = localStorage.getItem(localStorageKey()); + if (!local) { return; } + try { + const nonDefaultInstanceListIds: string[] = JSON.parse(local); + nonDefaultInstanceListIds.forEach(id => { + const info = lookupDetailsRegistry(id); + info.element.open = ! getDefaultOpenSetting(); + }); + } catch(e) { + // Gracefully handle errors related to changed config format. + if (e instanceof SyntaxError || e instanceof TypeError) { + localStorage.removeItem(localStorageKey()); + } else { + throw e; + } + } +} + +// Handler for clicking on the "toggle" element that toggles the +//
      element with id given by the 'data-details-id' property +// of the "toggle" element. +function onToggleClick(ev: MouseEvent) { + ev.preventDefault(); + const toggle = ev.currentTarget as HTMLElement; + toggleDetails(toggle); + storeLocalConfig(); +} + +// Set event handlers on elements responsible for expanding and +// collapsing
      elements. +// +// This applies to all 'details-toggle's, not just to to top-level +// 'details-toggle's that control instance lists. +function initCollapseToggles() { + const toggles: HTMLElement[] = Array.prototype.slice.call(document.getElementsByClassName('details-toggle')); + toggles.forEach(toggle => { + const id = getDataDetailsId(toggle); + const info = lookupDetailsRegistry(id); + info.toggles.push(toggle); + toggle.addEventListener('click', onToggleClick); + if (toggle.classList.contains('details-toggle-control')) { + toggle.classList.add(info.element.open ? 'collapser' : 'expander'); + } + }); +} + +// Collapse or expand all instances. +function _collapseAllInstances(collapse: boolean) { + const ilists = document.getElementsByClassName('subs instances'); + [].forEach.call(ilists, function (ilist : Element) { + const toggleType = collapse ? 'collapser' : 'expander'; + const toggle = ilist.getElementsByClassName('instances ' + toggleType)[0]; + if (toggle) { + toggleDetails(toggle); + } + }); +} + +function collapseAllInstances() { + _collapseAllInstances(true); + storeLocalConfig(); +} + +function expandAllInstances() { + _collapseAllInstances(false); + storeLocalConfig(); +} + +export function init(showHide?: (action: () => void) => void) { + gatherDetailsElements(); + initCollapseToggles(); + restoreToggled(); + preact.render( + , + document.body + ); +} diff --git a/haddock-api/resources/html/js-src/init.ts b/haddock-api/resources/html/js-src/init.ts index 877874ae..1bfa8b3c 100644 --- a/haddock-api/resources/html/js-src/init.ts +++ b/haddock-api/resources/html/js-src/init.ts @@ -17,6 +17,6 @@ function onDomReady(callback: () => void) { onDomReady(() => { document.body.classList.add('js-enabled'); styleMenu.init(); - detailsHelper.init(); quickJump.init(); -}); \ No newline at end of file + detailsHelper.init(); +}); diff --git a/haddock-api/resources/html/js-src/style-menu.tsx b/haddock-api/resources/html/js-src/style-menu.tsx index bab840ca..2eb8344e 100644 --- a/haddock-api/resources/html/js-src/style-menu.tsx +++ b/haddock-api/resources/html/js-src/style-menu.tsx @@ -4,91 +4,14 @@ import {getCookie, setCookie, clearCookie} from "./cookies"; import preact = require("preact"); const { h, Component } = preact; -const rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; - -function spaced(s: string) { return (" " + s + " ").replace(rspace, " "); } -function trim(s: string) { return s.replace(rtrim, ""); } - -function hasClass(elem: Element, value: string) { - const className = spaced(elem.className || ""); - return className.indexOf( " " + value + " " ) >= 0; -} - -function addClass(elem: Element, value: string) { - const className = spaced(elem.className || ""); - if ( className.indexOf( " " + value + " " ) < 0 ) { - elem.className = trim(className + " " + value); - } -} - -function removeClass(elem: Element, value: string) { - let className = spaced(elem.className || ""); - className = className.replace(" " + value + " ", " "); - elem.className = trim(className); -} - -function toggleClass(elem: Element, valueOn: string, valueOff: string, bool?: boolean): boolean { - 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: string, valueOff: string): (elem: Element, bool?: boolean) => boolean { - return function(elem, bool) { - return toggleClass(elem, valueOn, valueOff, bool); - } -} - -const toggleShow = makeClassToggle("show", "hide"); +// Get all of the styles that are available function styles(): HTMLLinkElement[] { const es = Array.prototype.slice.call(document.getElementsByTagName("link")); return es.filter((a: HTMLLinkElement) => a.rel.indexOf("style") != -1 && a.title); } -class StyleMenuButton extends Component { - - render(props: { stys: string[] }) { - function action() { - styleMenu(); - return false; - }; - - return
    • - Style ▾ -
        - {props.stys.map((sty) => { - function action() { - setActiveStyleSheet(sty); - return false; - }; - - return
      • {sty}
        • ; - })} -
      -
      • ; - } - -} - -function addStyleMenu() { - const stys = styles().map((s) => s.title); - if (stys.length > 1) { - const pageMenu = document.querySelector('#page-menu') as HTMLUListElement; - const dummy = document.createElement('li'); - pageMenu.appendChild(dummy); - preact.render(, pageMenu, dummy); - } -} - +// Set a style (including setting the cookie) function setActiveStyleSheet(title: string) { const as = styles(); let found: null | HTMLLinkElement = null; @@ -110,17 +33,103 @@ function setActiveStyleSheet(title: string) { } } +// Reset the style based on the cookie function resetStyle() { const s = getCookie("haddock-style"); if (s) setActiveStyleSheet(s); } -function styleMenu(show?: boolean) { - const m = document.getElementById('style-menu'); - if (m) toggleShow(m, show); +class StylesButton extends Component { + render(props: { title: string, onClick: () => void }) { + function onClick(e: Event) { + e.preventDefault(); + props.onClick(); + } + return
    • {props.title}
      • ; + } } -export function init() { - addStyleMenu(); +// Add the style menu button +function addStyleMenu(stys: string[], action: () => void) { + if (stys.length > 1) { + const pageMenu = document.querySelector('#page-menu') as HTMLUListElement; + const dummy = document.createElement('li'); + pageMenu.appendChild(dummy); + preact.render(, pageMenu, dummy); + } +} + +type StyleProps = { + styles: string[] + showHideTrigger: (action: () => void) => void +} + +type StyleState = { + isVisible: boolean +} + +// Represents the full style dropdown +class Styles extends Component { + + componentWillMount() { + document.addEventListener('mousedown', this.hide.bind(this)); + + document.addEventListener('keydown', (e) => { + if (this.state.isVisible) { + if (e.key === 'Escape') { + this.hide(); + } + } + }) + } + + hide() { + this.setState({ isVisible: false }); + } + + show() { + if (!this.state.isVisible) { + this.setState({ isVisible: true }); + } + } + + toggleVisibility() { + if (this.state.isVisible) { + this.hide(); + } else { + this.show(); + } + } + + componentDidMount() { + this.props.showHideTrigger(this.toggleVisibility.bind(this)); + } + + render(props: StyleProps, state: StyleState) { + const stopPropagation = (e: Event) => { e.stopPropagation(); }; + + return
      + +
      ; + } +} + + +export function init(showHide?: (action: () => void) => void) { + const stys = styles().map((s) => s.title); + const addStylesButton = (action: () => void) => addStyleMenu(stys, action) resetStyle(); + preact.render( + , + document.body + ); } diff --git a/haddock-api/resources/html/quick-jump.css b/haddock-api/resources/html/quick-jump.css index 468d8036..8772809c 100644 --- a/haddock-api/resources/html/quick-jump.css +++ b/haddock-api/resources/html/quick-jump.css @@ -1,3 +1,11 @@ +/* @group Fundamentals */ + +.hidden { + display: none; +} + +/* @end */ + /* @group Search box layout */ #search { @@ -11,8 +19,10 @@ overflow-y: auto; } -#search.hidden { - display: none; +@media only screen and (max-width: 999px) { + #search { + top: 5.7em; + } } #search-form, #search-results { @@ -162,3 +172,49 @@ } /* @end */ + +/* @group Dropdown menus */ + +/* Based on #search styling above. */ + +.dropdown-menu { + position: fixed; + /* Not robust to window size changes. */ + top: 3.2em; + right: 0; + /* To display on top of synopsis menu on right side. */ + z-index: 1000; + border: 0.05em solid #b2d5fb; + background: #e8f3ff; +} + +@media only screen and (max-width: 999px) { + .dropdown-menu { + top: 5.7em; + } +} + +.dropdown-menu * { + margin: 0.1em; +} + +.dropdown-menu button { + border: 1px #5E5184 solid; + border-radius: 3px; + background: #5E5184; + padding: 3px; + color: #f4f4f4; + min-width: 6em; +} + +.dropdown-menu button:hover { + color: #5E5184; + background: #f4f4f4; +} + +.dropdown-menu button:active { + color: #f4f4f4; + background: #5E5184; +} + +/* @end */ -- cgit v1.2.3 From df4a5bce84505772bb8d611472c57c0c6310107f Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 28 Feb 2019 12:42:49 -0500 Subject: `--show-interface` should output to stdout. (#1040) Fixes #864. --- haddock-api/src/Haddock.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 43f600b4..4ebdbfb4 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -76,6 +76,7 @@ import Packages import Panic (handleGhcException) import Module import FastString +import Outputable (defaultUserStyle) -------------------------------------------------------------------------------- -- * Exception handling @@ -171,7 +172,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] forM_ mIfaceFile $ \(_, ifaceFile) -> do - putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) + logOutput dflags (defaultUserStyle dflags) (renderJson (jsonInterfaceFile ifaceFile)) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files -- cgit v1.2.3 From 8964666efc4d4ab9756a83d16a02115a38744408 Mon Sep 17 00:00:00 2001 From: gbaz Date: Fri, 1 Mar 2019 10:43:16 -0500 Subject: Increase contrast of Linuwal theme (#1037) This is to address the concern that, on less nice and older screens, some of the shades of grey blend in too easily with the white background. * darken the font slightly * darken slightly the grey behind type signatures and such * add a border and round the corners on code blocks * knock the font down by one point --- haddock-api/resources/html/Linuwial.std-theme/linuwial.css | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/haddock-api/resources/html/Linuwial.std-theme/linuwial.css b/haddock-api/resources/html/Linuwial.std-theme/linuwial.css index 330c605a..cbb58a03 100644 --- a/haddock-api/resources/html/Linuwial.std-theme/linuwial.css +++ b/haddock-api/resources/html/Linuwial.std-theme/linuwial.css @@ -11,7 +11,7 @@ html { body { background: #fefefe; - color: #333; + color: #111; text-align: left; min-height: 100vh; position: relative; @@ -234,7 +234,7 @@ Display the package name on top of the menu links and center both elements: */ body, button { - font: 400 15px/1.4 'PT Sans', + font: 400 14px/1.4 'PT Sans', /* Fallback Font Stack */ -apple-system, BlinkMacSystemFont, @@ -390,6 +390,8 @@ pre { margin: 1em 0 0 0; background-color: #f7f7f7; overflow: auto; + border: 1px solid #ddd; + border-radius: 0.3em; } pre + p { @@ -408,7 +410,7 @@ blockquote { } .src { - background: #f4f4f4; + background: #f2f2f2; padding: 0.2em 0.5em; } @@ -501,7 +503,7 @@ table.info { } #contents-list { - background: #f7f7f7; + background: #f4f4f4; padding: 1em; margin: 0; } -- cgit v1.2.3 From 50cf001765123a6c787795dda50aaefa5f2beed7 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 8 Mar 2019 08:04:50 -0800 Subject: Add .hi, .dyn_hi, etc files to .gitignore Fixes #1030. --- .gitignore | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.gitignore b/.gitignore index d65138d1..a6e1099c 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,12 @@ /latex-test/out/ /hoogle-test/out/ +*.o +*.hi +*.dyn_o +*.dyn_hi +*.hp + /doc/haddock /doc/haddock.ps /doc/haddock.pdf -- cgit v1.2.3 From abb448ff120d6f09b6d070806de1d0eb334bc23b Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 8 Mar 2019 13:23:37 -0800 Subject: Better support for default methods in classes * default methods now get rendered differently * default associated types get rendered * fix a forgotten `s/TypeSig/ClassOpSig/` refactor in LaTeX backend * LaTeX backend now renders default method signatures NB: there is still no way to document default class members and the NB: LaTeX backend still crashes on associated types --- CHANGES.md | 3 + haddock-api/src/Haddock/Backends/LaTeX.hs | 47 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 99 +++++++---- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 4 + haddock-api/src/Haddock/Types.hs | 3 + html-test/ref/DefaultAssociatedTypes.html | 158 ++++++++++++++++++ html-test/ref/DefaultSignatures.html | 182 +++++++++++++++++++++ html-test/src/DefaultAssociatedTypes.hs | 14 ++ html-test/src/DefaultSignatures.hs | 19 +++ .../ref/DefaultSignatures/DefaultSignatures.tex | 41 +++++ latex-test/ref/DefaultSignatures/haddock.sty | 57 +++++++ latex-test/ref/DefaultSignatures/main.tex | 11 ++ .../src/DefaultSignatures/DefaultSignatures.hs | 19 +++ 13 files changed, 606 insertions(+), 51 deletions(-) create mode 100644 html-test/ref/DefaultAssociatedTypes.html create mode 100644 html-test/ref/DefaultSignatures.html create mode 100644 html-test/src/DefaultAssociatedTypes.hs create mode 100644 html-test/src/DefaultSignatures.hs create mode 100644 latex-test/ref/DefaultSignatures/DefaultSignatures.tex create mode 100644 latex-test/ref/DefaultSignatures/haddock.sty create mode 100644 latex-test/ref/DefaultSignatures/main.tex create mode 100644 latex-test/src/DefaultSignatures/DefaultSignatures.hs diff --git a/CHANGES.md b/CHANGES.md index 15a88221..bd4317bf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -23,6 +23,9 @@ * `--show-interface` now outputs to stdout (instead of stderr) + * Render associated type defaults and also improve rendering of + default method signatures + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 119bbc01..d2baefac 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -295,7 +295,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig Nothing (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode ForD _ d -> ppFor (doc, fnArgsDoc) d unicode InstD _ _ -> empty @@ -307,7 +307,7 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX ppFor doc (ForeignImport _ (L _ name) typ _) unicode = - ppFunSig doc [name] (hsSigType typ) unicode + ppFunSig Nothing doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -414,17 +414,23 @@ ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI - -> Bool -> LaTeX -ppFunSig doc docnames (L _ typ) unicode = +ppFunSig + :: Maybe LaTeX -- ^ a prefix to put right before the signature + -> DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppFunSig leader doc docnames (L _ typ) unicode = ppTypeOrFunSig typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names + ( lead $ ppTypeSig names typ False + , lead $ hsep . punctuate comma $ map ppSymName names , dcolon unicode ) unicode where names = map getName docnames + lead = maybe id (<+>) leader -- | Pretty-print a pattern synonym ppLPatSig :: DocForDecl DocName -- ^ documentation @@ -433,15 +439,7 @@ ppLPatSig :: DocForDecl DocName -- ^ documentation -> Bool -- ^ unicode -> LaTeX ppLPatSig doc docnames ty unicode - = ppTypeOrFunSig typ doc - ( keyword "pattern" <+> ppTypeSig names typ False - , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) - , dcolon unicode - ) - unicode - where - typ = unLoc (hsSigType ty) - names = map getName docnames + = ppFunSig (Just (keyword "pattern")) doc docnames (hsSigType ty) unicode -- | Pretty-print a type, adding documentation to the whole type and its -- arguments as needed. @@ -585,6 +583,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) +-- TODO: associated types, associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -610,13 +609,15 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ - vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig _ lnames typ) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? + vcat [ ppFunSig leader doc names (hsSigType typ) unicode + | L _ (ClassOpSig _ is_def lnames typ) <- lsigs + , let doc | is_def = noDocForDecl + | otherwise = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames + leader = if is_def then Just (keyword "default") else Nothing + ] + -- N.B. taking just the first name is ok. Signatures with multiple + -- names are expanded so that each name gets its own signature. instancesBit = ppDocInstances unicode instances diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index f2cab635..56a79d57 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,6 +36,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) +import qualified GHC import GHC.Exts import Name import BooleanFormula @@ -75,14 +76,14 @@ ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> [Located DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual = - ppFunSig summary links loc doc (map unLoc lnames) lty fixities + ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities splice unicode pkg qual -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> LHsType DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = - ppSigLike summary links loc mempty doc docnames fixities (unLoc typ, pp_typ) +ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc leader doc docnames fixities (unLoc typ, pp_typ) splice unicode pkg qual HideEmptyContexts where pp_typ = ppLType unicode qual HideEmptyContexts typ @@ -218,7 +219,7 @@ ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual - = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual + = ppFunSig summary links loc noHtml doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -496,7 +497,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t -- ToDo: add associated type defaults - [ ppFunSig summary links loc doc names (hsSigType typ) + [ ppFunSig summary links loc noHtml doc names (hsSigType typ) [] splice unicode pkg qual | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -517,8 +518,9 @@ ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity) -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname@(L _ nm) + , tcdTyVars = ltyvars, tcdFDs = lfds, tcdSigs = lsigs + , tcdATs = ats, tcdATDefs = atsDefs }) splice unicode pkg qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode pkg qual | otherwise = classheader +++ docSection curname pkg qual d @@ -535,28 +537,68 @@ ppClassDecl summary links instances fixities loc d subdocs -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - nm = tcdName decl - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode pkg qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - - methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) - subfixs splice unicode pkg qual - | L _ (ClassOpSig _ _ lnames typ) <- lsigs - , name <- map unLoc lnames - , let doc = lookupAnySubdoc name subdocs - subfixs = [ f | f@(n',_) <- fixities - , name == n' ] - ] - -- N.B. taking just the first name is ok. Signatures with multiple names - -- are expanded so that each name gets its own signature. + -- Associated types + atBit = subAssociatedTypes + [ ppAssocType summary links doc at subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defTys) + | at <- ats + , let name = unL . fdLName $ unL at + doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defTys = ppDefaultAssocTy name <$> lookupDAT name + ] + + -- Default associated types + ppDefaultAssocTy n (vs,t,d') = ppTySyn summary links [] loc d' synDecl + splice unicode pkg qual + where + synDecl = SynDecl { tcdSExt = noExt + , tcdLName = noLoc n + , tcdTyVars = vs + , tcdFixity = GHC.Prefix + , tcdRhs = t } + + lookupDAT name = Map.lookup (getName name) defaultAssocTys + defaultAssocTys = Map.fromList + [ (getName name, (vs, typ, doc)) + | L _ (FamEqn { feqn_rhs = typ + , feqn_tycon = L _ name + , feqn_pats = vs }) <- atsDefs + , let doc = noDocForDecl -- TODO: get docs for associated type defaults + ] + + -- Methods + methodBit = subMethods + [ ppFunSig summary links loc noHtml doc [name] (hsSigType typ) + subfixs splice unicode pkg qual + <+> + subDefaults (maybeToList defSigs) + | ClassOpSig _ False lnames typ <- sigs + , name <- map unLoc lnames + , let doc = lookupAnySubdoc name subdocs + subfixs = filter ((== name) . fst) fixities + defSigs = ppDefaultFunSig name <$> lookupDM name + ] + -- N.B. taking just the first name is ok. Signatures with multiple names + -- are expanded so that each name gets its own signature. + + -- Default methods + ppDefaultFunSig n (t, d') = ppFunSig summary links loc (keyword "default") + d' [n] (hsSigType t) [] splice unicode pkg qual + + lookupDM name = Map.lookup (getOccString name) defaultMethods + defaultMethods = Map.fromList + [ (nameStr, (typ, doc)) + | ClassOpSig _ True lnames typ <- sigs + , name <- map unLoc lnames + , let doc = noDocForDecl -- TODO: get docs for method defaults + nameStr = getOccString name + ] + -- Minimal complete definition minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == @@ -565,7 +607,7 @@ ppClassDecl summary links instances fixities loc d subdocs -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -580,6 +622,7 @@ ppClassDecl summary links instances fixities loc d subdocs where wrap | p = parens | otherwise = id ppMinimal p (Parens x) = ppMinimal p (unLoc x) + -- Instances instancesBit = ppInstances links (OriginClass nm) instances splice unicode pkg qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 25d8b07a..4535b897 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -35,6 +35,7 @@ module Haddock.Backends.Xhtml.Layout ( subInstances, subOrphanInstances, subInstHead, subInstDetails, subFamInstDetails, subMethods, + subDefaults, subMinimal, topDeclElem, declElem, @@ -259,6 +260,9 @@ instAnchorId iid = makeAnchorId $ "i:" ++ iid subMethods :: [Html] -> Html subMethods = divSubDecls "methods" "Methods" . subBlock +subDefaults :: [Html] -> Html +subDefaults = divSubDecls "default" "" . subBlock + subMinimal :: Html -> Html subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index cd4ac1a1..a72247e6 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -355,6 +355,9 @@ showWrapped f (Unadorned n) = f n showWrapped f (Parenthesized n) = "(" ++ f n ++ ")" showWrapped f (Backticked n) = "`" ++ f n ++ "`" +instance HasOccName DocName where + + occName = occName . getName ----------------------------------------------------------------------------- -- * Instances diff --git a/html-test/ref/DefaultAssociatedTypes.html b/html-test/ref/DefaultAssociatedTypes.html new file mode 100644 index 00000000..d456815f --- /dev/null +++ b/html-test/ref/DefaultAssociatedTypes.html @@ -0,0 +1,158 @@ +DefaultAssociatedTypes
      Safe HaskellSafe

      DefaultAssociatedTypes

      Synopsis

      Documentation

      class Foo a where #

      Documentation for Foo.

      Associated Types

      type Qux a :: * #

      Doc for Qux

      type Qux a = [a] #

      Methods

      bar :: a -> String #

      Documentation for bar and baz.

      baz :: a -> String #

      Documentation for bar and baz.

      \ No newline at end of file diff --git a/html-test/ref/DefaultSignatures.html b/html-test/ref/DefaultSignatures.html new file mode 100644 index 00000000..4bf261f7 --- /dev/null +++ b/html-test/ref/DefaultSignatures.html @@ -0,0 +1,182 @@ +DefaultSignatures
      Safe HaskellSafe

      DefaultSignatures

      Synopsis

      Documentation

      class Foo a where #

      Documentation for Foo.

      Minimal complete definition

      baz

      Methods

      bar :: a -> String #

      Documentation for bar and baz.

      default bar :: Show a => a -> String #

      baz :: a -> String #

      Documentation for bar and baz.

      baz' :: String -> a #

      Documentation for baz'.

      default baz' :: Read a => String -> a #

      \ No newline at end of file diff --git a/html-test/src/DefaultAssociatedTypes.hs b/html-test/src/DefaultAssociatedTypes.hs new file mode 100644 index 00000000..6ad197d3 --- /dev/null +++ b/html-test/src/DefaultAssociatedTypes.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DefaultSignatures, TypeFamilies #-} + +module DefaultAssociatedTypes where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Doc for Qux + type Qux a :: * + + -- | Doc for default Qux + type Qux a = [a] diff --git a/html-test/src/DefaultSignatures.hs b/html-test/src/DefaultSignatures.hs new file mode 100644 index 00000000..52d68a96 --- /dev/null +++ b/html-test/src/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex new file mode 100644 index 00000000..4dbcda49 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -0,0 +1,41 @@ +\haddockmoduleheading{DefaultSignatures} +\label{module:DefaultSignatures} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module DefaultSignatures ( + Foo(baz', baz, bar) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +class\ Foo\ a\ where +\end{tabular}]\haddockbegindoc +Documentation for Foo.\par + +\haddockpremethods{}\emph{Methods} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +bar,\ baz\ ::\ a\ ->\ String +\end{tabular}]\haddockbegindoc +Documentation for bar and baz.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +baz'\ ::\ String\ ->\ a +\end{tabular}]\haddockbegindoc +Documentation for baz'.\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a +\end{tabular}] +\end{haddockdesc} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex new file mode 100644 index 00000000..d30eb008 --- /dev/null +++ b/latex-test/ref/DefaultSignatures/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{DefaultSignatures} +\end{document} \ No newline at end of file diff --git a/latex-test/src/DefaultSignatures/DefaultSignatures.hs b/latex-test/src/DefaultSignatures/DefaultSignatures.hs new file mode 100644 index 00000000..52d68a96 --- /dev/null +++ b/latex-test/src/DefaultSignatures/DefaultSignatures.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DefaultSignatures #-} + +module DefaultSignatures where + +-- | Documentation for Foo. +class Foo a where + -- | Documentation for bar and baz. + bar, baz :: a -> String + + -- | Documentation for the default signature of bar. + default bar :: Show a => a -> String + bar = show + + -- | Documentation for baz'. + baz' :: String -> a + + -- | Documentation for the default signature of baz'. + default baz' :: Read a => String -> a + baz' = read -- cgit v1.2.3 From 747dfc712bd516b76342f2e17dada7a64d43c778 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 9 Sep 2018 13:53:32 -0700 Subject: Avoid multi-line `emph` in LaTeX backend `markupWarning` often processes inputs which span across paragraphs. Unfortunately, LaTeX's `emph` is not made to handle this (and will crash). Fixes #936. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- latex-test/ref/Deprecated/Deprecated.tex | 17 +++++++++ latex-test/ref/Deprecated/haddock.sty | 57 +++++++++++++++++++++++++++++++ latex-test/ref/Deprecated/main.tex | 11 ++++++ latex-test/src/Deprecated/Deprecated.hs | 7 ++++ 5 files changed, 93 insertions(+), 1 deletion(-) create mode 100644 latex-test/ref/Deprecated/Deprecated.tex create mode 100644 latex-test/ref/Deprecated/haddock.sty create mode 100644 latex-test/ref/Deprecated/main.tex create mode 100644 latex-test/src/Deprecated/Deprecated.hs diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d2baefac..1cc17dab 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1191,7 +1191,7 @@ parLatexMarkup ppId = Markup { markupIdentifier = markupId ppId, markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> emph (p v), + markupWarning = \p v -> p v, markupEmphasis = \p v -> emph (p v), markupBold = \p v -> bold (p v), markupMonospaced = \p _ -> tt (p Mono), diff --git a/latex-test/ref/Deprecated/Deprecated.tex b/latex-test/ref/Deprecated/Deprecated.tex new file mode 100644 index 00000000..fa8fc20a --- /dev/null +++ b/latex-test/ref/Deprecated/Deprecated.tex @@ -0,0 +1,17 @@ +\haddockmoduleheading{Deprecated} +\label{module:Deprecated} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module Deprecated ( + deprecated + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +deprecated\ ::\ Int +\end{tabular}]\haddockbegindoc +Deprecated: Don't use this\par +Docs for something deprecated\par + +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/Deprecated/haddock.sty b/latex-test/ref/Deprecated/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/Deprecated/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/Deprecated/main.tex b/latex-test/ref/Deprecated/main.tex new file mode 100644 index 00000000..76def1cd --- /dev/null +++ b/latex-test/ref/Deprecated/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{Deprecated} +\end{document} \ No newline at end of file diff --git a/latex-test/src/Deprecated/Deprecated.hs b/latex-test/src/Deprecated/Deprecated.hs new file mode 100644 index 00000000..aecec94e --- /dev/null +++ b/latex-test/src/Deprecated/Deprecated.hs @@ -0,0 +1,7 @@ +module Deprecated where + +-- | Docs for something deprecated +deprecated :: Int +deprecated = 1 + +{-# DEPRECATED deprecated "Don't use this" #-} -- cgit v1.2.3 From ae23b4f25a972620686617b5aab5375d5046b1c9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 9 Sep 2018 14:25:57 -0700 Subject: Many LaTeX backend fixes After this commit, we can run with `--latex` on all boot libraries without crashing (although the generated LaTeX still fails to compile in a handful of larger packages like `ghc` and `base`). * Add newlines after all block elements in LaTeX. This is important to prevent the final output from being more an more indented. See the `latext-test/src/Example` test case for a sample of this. * Support associated types in class declarations (but not yet defaults) * Several small issues for producing compiling LaTeX; - avoid empy `\haddockbeginargs` lists (ex: `type family Any`) - properly escape identifiers depending on context (ex: `Int#`) - add `vbox` around `itemize`/`enumerate` (so they can be in tables) * Several spacing fixes: - limit the width of `Pretty`-arranged monospaced code - cut out extra space characters in export lists - only escape spaces if there are _multiple_ spaces - allow type signatures to be multiline (even without docs) * Remove uninteresting and repetitive `main.tex`/`haddock.sty` files from `latex-test` test reference output. Fixes #935, #929 (LaTeX docs for `text` build & compile) Fixes #727, #930 (I think both are really about type families...) --- CHANGES.md | 3 + haddock-api/src/Haddock/Backends/LaTeX.hs | 216 +++++++++++---------- latex-test/Main.hs | 4 +- latex-test/ref/ConstructorArgs/ConstructorArgs.tex | 34 ++-- latex-test/ref/ConstructorArgs/haddock.sty | 57 ------ latex-test/ref/ConstructorArgs/main.tex | 11 -- .../ref/DefaultSignatures/DefaultSignatures.tex | 28 +-- latex-test/ref/DefaultSignatures/haddock.sty | 57 ------ latex-test/ref/DefaultSignatures/main.tex | 11 -- latex-test/ref/Deprecated/Deprecated.tex | 8 +- latex-test/ref/Deprecated/haddock.sty | 57 ------ latex-test/ref/Deprecated/main.tex | 11 -- latex-test/ref/Example/Example.tex | 30 +++ .../GadtConstructorArgs/GadtConstructorArgs.tex | 15 +- latex-test/ref/GadtConstructorArgs/haddock.sty | 57 ------ latex-test/ref/GadtConstructorArgs/main.tex | 11 -- .../NamespacedIdentifier/NamespacedIdentifiers.tex | 26 ++- latex-test/ref/NamespacedIdentifier/haddock.sty | 57 ------ latex-test/ref/NamespacedIdentifier/main.tex | 11 -- latex-test/ref/Simple/Simple.tex | 8 +- latex-test/ref/Simple/haddock.sty | 57 ------ latex-test/ref/Simple/main.tex | 11 -- latex-test/ref/TypeFamilies3/TypeFamilies3.tex | 32 +-- latex-test/ref/TypeFamilies3/haddock.sty | 57 ------ latex-test/ref/TypeFamilies3/main.tex | 11 -- latex-test/ref/UnboxedStuff/UnboxedStuff.tex | 26 +-- latex-test/ref/UnboxedStuff/haddock.sty | 57 ------ latex-test/ref/UnboxedStuff/main.tex | 11 -- latex-test/src/Example/Example.hs | 11 ++ 29 files changed, 253 insertions(+), 732 deletions(-) delete mode 100644 latex-test/ref/ConstructorArgs/haddock.sty delete mode 100644 latex-test/ref/ConstructorArgs/main.tex delete mode 100644 latex-test/ref/DefaultSignatures/haddock.sty delete mode 100644 latex-test/ref/DefaultSignatures/main.tex delete mode 100644 latex-test/ref/Deprecated/haddock.sty delete mode 100644 latex-test/ref/Deprecated/main.tex create mode 100644 latex-test/ref/Example/Example.tex delete mode 100644 latex-test/ref/GadtConstructorArgs/haddock.sty delete mode 100644 latex-test/ref/GadtConstructorArgs/main.tex delete mode 100644 latex-test/ref/NamespacedIdentifier/haddock.sty delete mode 100644 latex-test/ref/NamespacedIdentifier/main.tex delete mode 100644 latex-test/ref/Simple/haddock.sty delete mode 100644 latex-test/ref/Simple/main.tex delete mode 100644 latex-test/ref/TypeFamilies3/haddock.sty delete mode 100644 latex-test/ref/TypeFamilies3/main.tex delete mode 100644 latex-test/ref/UnboxedStuff/haddock.sty delete mode 100644 latex-test/ref/UnboxedStuff/main.tex create mode 100644 latex-test/src/Example/Example.hs diff --git a/CHANGES.md b/CHANGES.md index bd4317bf..a6d96fed 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -26,6 +26,9 @@ * Render associated type defaults and also improve rendering of default method signatures + * Many fixes to the LaTeX backend, mostly focused on not crashing + as well as generating LaTeX source that compiles + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1cc17dab..cc096a7a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -103,6 +103,10 @@ haddockSty = "haddock.sty" type LaTeX = Pretty.Doc +-- | Default way of rendering a 'LaTeX'. The width is 90 by default (since 100 +-- often overflows the line). +latex2String :: LaTeX -> String +latex2String = fullRender PageMode 90 1 txtPrinter "" ppLaTeXTop :: String @@ -156,7 +160,7 @@ ppLaTeXModule _title odir iface = do text "\\haddockbeginheader", verb $ vcat [ text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ + text " " <> fsep (punctuate (char ',') $ map exportListItem $ filter forSummary exports), text " ) where" @@ -171,7 +175,7 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeUtf8File (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) + writeUtf8File (odir moduleLaTeXFile mdl) (show tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -287,7 +291,7 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD _ d@FamDecl {} -> ppFamDecl doc instances d unicode + TyClD _ d@FamDecl {} -> ppFamDecl False doc instances d unicode TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now @@ -317,13 +321,14 @@ ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" ------------------------------------------------------------------------------- -- | Pretty-print a data\/type family declaration -ppFamDecl :: Documentation DocName -- ^ this decl's docs +ppFamDecl :: Bool -- ^ is the family associated? + -> Documentation DocName -- ^ this decl's docs -> [DocInstance DocNameI] -- ^ relevant instances -> TyClDecl DocNameI -- ^ family to print -> Bool -- ^ unicode -> LaTeX -ppFamDecl doc instances decl unicode = - declWithDoc (ppFamHeader (tcdFam decl) unicode <+> whereBit) +ppFamDecl associated doc instances decl unicode = + declWithDoc (ppFamHeader (tcdFam decl) unicode associated <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -335,6 +340,7 @@ ppFamDecl doc instances decl unicode = familyEqns | FamilyDecl { fdInfo = ClosedTypeFamily (Just eqns) } <- tcdFam decl + , not (null eqns) = Just (text "\\haddockbeginargs" $$ vcat [ decltt (ppFamDeclEqn eqn) <+> nl | L _ eqn <- eqns ] $$ text "\\end{tabulary}\\par") @@ -356,22 +362,26 @@ ppFamDecl doc instances decl unicode = -- | Print the LHS of a type\/data family declaration. ppFamHeader :: FamilyDecl DocNameI -- ^ family header to print - -> Bool -- ^ unicode - -> LaTeX -ppFamHeader (XFamilyDecl _) _ = panic "haddock;ppFamHeader" + -> Bool -- ^ unicode + -> Bool -- ^ is the family associated? + -> LaTeX +ppFamHeader (XFamilyDecl _) _ _ = panic "haddock;ppFamHeader" ppFamHeader (FamilyDecl { fdLName = L _ name , fdTyVars = tvs , fdInfo = info , fdResultSig = L _ result , fdInjectivityAnn = injectivity }) - unicode = - leader <+> keyword "family" <+> famName <+> famSig <+> injAnn + unicode associated = + famly leader <+> famName <+> famSig <+> injAnn where leader = case info of OpenTypeFamily -> keyword "type" ClosedTypeFamily _ -> keyword "type" DataFamily -> keyword "data" + famly | associated = id + | otherwise = (<+> keyword "family") + famName = ppAppDocNameTyVarBndrs unicode name (hsq_explicit tvs) famSig = case result of @@ -475,11 +485,15 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args n leader (HsForAllTy _ tvs ltype) - = do_largs n (leader <+> decltt (ppForAllPart unicode tvs)) ltype + do_args _n leader (HsForAllTy _ tvs ltype) + = [ ( decltt leader + , decltt (ppForAllPart unicode tvs) + <+> ppLType unicode ltype + ) ] do_args n leader (HsQualTy _ lctxt ltype) - = (decltt leader, decltt (ppLContextNoArrow lctxt unicode) <+> nl) - : do_largs n (darrow unicode) ltype + = ( decltt leader + , decltt (ppLContextNoArrow lctxt unicode) <+> nl + ) : do_largs n (darrow unicode) ltype do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) @@ -498,9 +512,9 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode -- mode since `->` and `::` are rendered as single characters. - gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," - gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" - gadtOpen = text "\\{" + gadtComma = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char ',' + gadtEnd = hcat (replicate (if unicode then 3 else 4) (char ' ')) <> char '}' + gadtOpen = char '{' ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -512,7 +526,7 @@ ppTypeSig nms ty unicode = -- | Pretty-print type variables. ppTyVars :: Bool -> [LHsTyVarBndr DocNameI] -> [LaTeX] -ppTyVars unicode tvs = map (ppHsTyVarBndr unicode . unLoc) tvs +ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] @@ -523,10 +537,9 @@ declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX declWithDoc decl doc = text "\\begin{haddockdesc}" $$ text "\\item[\\begin{tabular}{@{}l}" $$ - text (latexMonoFilter (show decl)) $$ - text "\\end{tabular}]" <> - (if isNothing doc then empty else text "\\haddockbegindoc") $$ - maybe empty id doc $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" $$ + maybe empty (\x -> text "{\\haddockbegindoc" $$ x <> text "}") doc $$ text "\\end{haddockdesc}" @@ -537,9 +550,9 @@ multiDecl :: [LaTeX] -> LaTeX multiDecl decls = text "\\begin{haddockdesc}" $$ vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (latex2String decl)) $$ + text "\\end{tabular}]" | decl <- decls ] $$ text "\\end{haddockdesc}" @@ -583,7 +596,7 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) --- TODO: associated types, associated type defaults, docs on default methods +-- TODO: associated type defaults, docs on default methods ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX @@ -604,8 +617,16 @@ ppClassDecl instances doc subdocs body_ | null lsigs, null ats, null at_defs = Nothing | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" + | otherwise = Just (atTable $$ methodTable) + + atTable = + text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ + vcat [ ppFamDecl True (fst doc) [] (FamDecl noExt decl) True + | L _ decl <- ats + , let name = unL . fdLName $ decl + doc = lookupAnySubdoc name subdocs + ] + methodTable = text "\\haddockpremethods{}" <> emph (text "Methods") $$ @@ -636,6 +657,7 @@ ppDocInstances unicode (i : rest) isUndocdInstance :: DocInstance a -> Maybe (InstHead a) isUndocdInstance (i,Nothing,_,_) = Just i +isUndocdInstance (i,Just (MetaDoc _ DocEmpty),_,_) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside @@ -1001,7 +1023,7 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppType, ppParendType, ppFunLhType, ppCtxType :: Bool -> HsType DocNameI -> LaTeX ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode -ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode @@ -1014,7 +1036,7 @@ ppLHsTypeArg _ (HsArgPar _) = text "" ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name ppHsTyVarBndr unicode (KindedTyVar _ (L _ name) kind) = - parens (ppDocName name) <+> dcolon unicode <+> ppLKind unicode kind + parens (ppDocName name <+> dcolon unicode <+> ppLKind unicode kind) ppHsTyVarBndr _ (XTyVarBndr _) = panic "haddock:ppHsTyVarBndr" ppLKind :: Bool -> LHsKind DocNameI -> LaTeX @@ -1080,7 +1102,7 @@ ppr_mono_ty (HsParTy _ ty) unicode ppr_mono_ty (HsDocTy _ ty _) unicode = ppr_mono_lty ty unicode -ppr_mono_ty (HsWildCardTy _) _ = text "\\_" +ppr_mono_ty (HsWildCardTy _) _ = char '_' ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) @@ -1114,27 +1136,16 @@ ppSymName name | otherwise = ppName name -ppVerbOccName :: Wrap OccName -> LaTeX -ppVerbOccName = text . latexFilter . showWrapped occNameString - ppIPName :: HsIPName -> LaTeX ppIPName = text . ('?':) . unpackFS . hsIPNameFS ppOccName :: OccName -> LaTeX ppOccName = text . occNameString -ppVerbDocName :: Wrap DocName -> LaTeX -ppVerbDocName = text . latexFilter . showWrapped (occNameString . nameOccName . getName) - - -ppVerbRdrName :: Wrap RdrName -> LaTeX -ppVerbRdrName = text . latexFilter . showWrapped (occNameString . rdrNameOcc) - ppDocName :: DocName -> LaTeX ppDocName = ppOccName . nameOccName . getName - ppLDocName :: Located DocName -> LaTeX ppLDocName (L _ d) = ppDocName d @@ -1172,9 +1183,10 @@ latexMunge c s = c : s latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge ' ' (' ':s) = "\\ \\ " ++ s +latexMonoMunge ' ' ('\\':' ':s) = "\\ \\ " ++ s latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s +latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- @@ -1182,34 +1194,40 @@ latexMonoMunge c s = latexMunge c s ------------------------------------------------------------------------------- -parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) -parLatexMarkup ppId = Markup { - markupParagraph = \p v -> p v <> text "\\par" $$ text "", - markupEmpty = \_ -> empty, - markupString = \s v -> text (fixString v s), - markupAppend = \l r v -> l v <> r v, - markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . fmap snd), - markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> p v, - markupEmphasis = \p v -> emph (p v), - markupBold = \p v -> bold (p v), - markupMonospaced = \p _ -> tt (p Mono), - markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \p _ -> markupPic p, - markupMathInline = \p _ -> markupMathInline p, - markupMathDisplay = \p _ -> markupMathDisplay p, - markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", - markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), - markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l), - markupAName = \_ _ -> empty, - markupProperty = \p _ -> quote $ verb $ text p, - markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p), - markupTable = \(Table h b) p -> table h b p +latexMarkup :: HasOccName a => DocMarkup (Wrap a) (StringContext -> LaTeX -> LaTeX) +latexMarkup = Markup + { markupParagraph = \p v -> blockElem (p v (text "\\par")) + , markupEmpty = \_ -> id + , markupString = \s v -> inlineElem (text (fixString v s)) + , markupAppend = \l r v -> l v . r v + , markupIdentifier = \i v -> inlineElem (markupId v (fmap occName i)) + , markupIdentifierUnchecked = \i v -> inlineElem (markupId v (fmap snd i)) + , markupModule = \m _ -> inlineElem (let (mdl,_ref) = break (=='#') m in (tt (text mdl))) + , markupWarning = \p v -> p v + , markupEmphasis = \p v -> inlineElem (emph (p v empty)) + , markupBold = \p v -> inlineElem (bold (p v empty)) + , markupMonospaced = \p v -> inlineElem (markupMonospace p v) + , markupUnorderedList = \p v -> blockElem (itemizedList (map (\p' -> p' v empty) p)) + , markupPic = \p _ -> inlineElem (markupPic p) + , markupMathInline = \p _ -> inlineElem (markupMathInline p) + , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p) + , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p)) + , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) + , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) + , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l)) + , markupAName = \_ _ -> id -- TODO + , markupProperty = \p _ -> blockElem (quote (verb (text p))) + , markupExample = \e _ -> blockElem (quote (verb (text $ unlines $ map exampleToString e))) + , markupHeader = \(Header l h) p -> blockElem (header l (h p empty)) + , markupTable = \(Table h b) p -> blockElem (table h b p) } where + blockElem :: LaTeX -> LaTeX -> LaTeX + blockElem = ($$) + + inlineElem :: LaTeX -> LaTeX -> LaTeX + inlineElem = (<>) + header 1 d = text "\\section*" <> braces d header 2 d = text "\\subsection*" <> braces d header l d @@ -1222,6 +1240,9 @@ parLatexMarkup ppId = Markup { fixString Verb s = s fixString Mono s = latexMonoFilter s + markupMonospace p Verb = p Verb empty + markupMonospace p _ = tt (p Mono empty) + markupLink url mLabel = case mLabel of Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) @@ -1238,35 +1259,28 @@ parLatexMarkup ppId = Markup { markupMathDisplay mathjax = text "\\[" <> text mathjax <> text "\\]" - markupId ppId_ id v = + markupId v wrappedOcc = case v of - Verb -> theid - Mono -> theid - Plain -> text "\\haddockid" <> braces theid - where theid = ppId_ id - - -latexMarkup :: DocMarkup (Wrap DocName) (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName - - -rdrLatexMarkup :: DocMarkup (Wrap RdrName) (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName - + Verb -> text i + Mono -> text "\\haddockid" <> braces (text . latexMonoFilter $ i) + Plain -> text "\\haddockid" <> braces (text . latexFilter $ i) + where i = showWrapped occNameString wrappedOcc docToLaTeX :: Doc DocName -> LaTeX -docToLaTeX doc = markup latexMarkup doc Plain - +docToLaTeX doc = markup latexMarkup doc Plain empty documentationToLaTeX :: Documentation DocName -> Maybe LaTeX documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX -rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain +rdrDocToLaTeX doc = markup latexMarkup doc Plain empty -data StringContext = Plain | Verb | Mono +data StringContext + = Plain -- ^ all special characters have to be escape + | Mono -- ^ on top of special characters, escape space chraacters + | Verb -- ^ don't escape anything latexStripTrailingWhitespace :: Doc a -> Doc a @@ -1291,23 +1305,23 @@ latexStripTrailingWhitespace other = other itemizedList :: [LaTeX] -> LaTeX itemizedList items = - text "\\begin{itemize}" $$ + text "\\vbox{\\begin{itemize}" $$ vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" + text "\\end{itemize}}" enumeratedList :: [LaTeX] -> LaTeX enumeratedList items = - text "\\begin{enumerate}" $$ + text "\\vbox{\\begin{enumerate}" $$ vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" + text "\\end{enumerate}}" descriptionList :: [(LaTeX,LaTeX)] -> LaTeX descriptionList items = - text "\\begin{description}" $$ - vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ - text "\\end{description}" + text "\\vbox{\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <> text "\\hfill \\par" $$ b) items) $$ + text "\\end{description}}" tt :: LaTeX -> LaTeX @@ -1315,8 +1329,8 @@ tt ltx = text "\\haddocktt" <> braces ltx decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - +decltt ltx = text "\\haddockdecltt" <> braces (text filtered) + where filtered = latexMonoFilter (latex2String ltx) emph :: LaTeX -> LaTeX emph ltx = text "\\emph" <> braces ltx @@ -1324,6 +1338,12 @@ emph ltx = text "\\emph" <> braces ltx bold :: LaTeX -> LaTeX bold ltx = text "\\textbf" <> braces ltx +-- TODO: @verbatim@ is too much since +-- +-- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX +-- representing that markup gets printed verbatim +-- * Verbatim environments are not supported everywhere (example: not nested +-- inside a @tabulary@ environment) verb :: LaTeX -> LaTeX verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" -- NB. swallow a trailing \n in the verbatim text by appending the diff --git a/latex-test/Main.hs b/latex-test/Main.hs index 8d2a4922..17ae8ae8 100755 --- a/latex-test/Main.hs +++ b/latex-test/Main.hs @@ -19,7 +19,9 @@ checkConfig = CheckConfig dirConfig :: DirConfig -dirConfig = defaultDirConfig $ takeDirectory __FILE__ +dirConfig = (defaultDirConfig $ takeDirectory __FILE__) + { dcfgCheckIgnore = (`elem` ["haddock.sty", "main.tex"]) . takeFileName + } main :: IO () diff --git a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex index 44304f47..053d2e41 100644 --- a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex +++ b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex @@ -3,15 +3,16 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module ConstructorArgs ( - Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), pattern Bo, - pattern Bo' + Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), + pattern Bo, pattern Bo' ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Foo -\end{tabular}]\haddockbegindoc +data Foo +\end{tabular}] +{\haddockbegindoc \enspace \emph{Constructors}\par \haddockbeginconstrs \haddockdecltt{=} & \haddockdecltt{Rec} & doc on a record \\ @@ -25,12 +26,13 @@ data\ Foo \haddockdecltt{|} & \haddockdecltt{(:*)} & doc on the \haddockid{:*} constructor \\ & \qquad \haddockdecltt{Int} & doc on the \haddockid{Int} field of the \haddockid{:*} constructor \\ & \qquad \haddockdecltt{String} & doc on the \haddockid{String} field of the \haddockid{:*} constructor \\ -\end{tabulary}\par +\end{tabulary}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Boo\ where -\end{tabular}]\haddockbegindoc +data Boo where +\end{tabular}] +{\haddockbegindoc \enspace \emph{Constructors}\par \haddockbeginconstrs & \haddockdecltt{Foo} & Info about a \haddockid{Foo} \\ @@ -46,24 +48,24 @@ data\ Boo\ where & \qquad \haddockdecltt{->} \enspace \haddockdecltt{String} & a \haddockid{String} \\ & \qquad \haddockdecltt{->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ & \haddockdecltt{pattern Fo' :: Boo} & Bundled and no argument docs \\ -\end{tabulary}\par +\end{tabulary}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -pattern\ Bo -\end{tabular}]\haddockbegindoc +pattern Bo +\end{tabular}] +{\haddockbegindoc \haddockbeginargs \haddockdecltt{::} & \haddockdecltt{Int} & an \haddockid{Int} \\ \haddockdecltt{->} & \haddockdecltt{String} & a \haddockid{String} \\ \haddockdecltt{->} & \haddockdecltt{Boo} & a \haddockid{Boo} pattern \\ \end{tabulary}\par -Info about not-bundled \haddockid{Bo}\par - +Info about not-bundled \haddockid{Bo}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -pattern\ Bo'\ ::\ Int\ ->\ String\ ->\ Boo -\end{tabular}]\haddockbegindoc -Not bunded and no argument docs\par - +pattern Bo' :: Int -> String -> Boo +\end{tabular}] +{\haddockbegindoc +Not bunded and no argument docs\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/ConstructorArgs/haddock.sty b/latex-test/ref/ConstructorArgs/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/ConstructorArgs/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/ConstructorArgs/main.tex b/latex-test/ref/ConstructorArgs/main.tex deleted file mode 100644 index 80f639c5..00000000 --- a/latex-test/ref/ConstructorArgs/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{ConstructorArgs} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex index 4dbcda49..162f5014 100644 --- a/latex-test/ref/DefaultSignatures/DefaultSignatures.tex +++ b/latex-test/ref/DefaultSignatures/DefaultSignatures.tex @@ -9,33 +9,33 @@ module DefaultSignatures ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -class\ Foo\ a\ where -\end{tabular}]\haddockbegindoc +class Foo a where +\end{tabular}] +{\haddockbegindoc Documentation for Foo.\par - \haddockpremethods{}\emph{Methods} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -bar,\ baz\ ::\ a\ ->\ String -\end{tabular}]\haddockbegindoc -Documentation for bar and baz.\par - +bar, baz :: a -> String +\end{tabular}] +{\haddockbegindoc +Documentation for bar and baz.\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -default\ bar\ ::\ Show\ a\ =>\ a\ ->\ String +default bar :: Show a => a -> String \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -baz'\ ::\ String\ ->\ a -\end{tabular}]\haddockbegindoc -Documentation for baz'.\par - +baz' :: String -> a +\end{tabular}] +{\haddockbegindoc +Documentation for baz'.\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -default\ baz'\ ::\ Read\ a\ =>\ String\ ->\ a +default baz' :: Read a => String -> a \end{tabular}] -\end{haddockdesc} +\end{haddockdesc}} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/DefaultSignatures/haddock.sty b/latex-test/ref/DefaultSignatures/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/DefaultSignatures/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/DefaultSignatures/main.tex b/latex-test/ref/DefaultSignatures/main.tex deleted file mode 100644 index d30eb008..00000000 --- a/latex-test/ref/DefaultSignatures/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{DefaultSignatures} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/Deprecated/Deprecated.tex b/latex-test/ref/Deprecated/Deprecated.tex index fa8fc20a..0ae2410b 100644 --- a/latex-test/ref/Deprecated/Deprecated.tex +++ b/latex-test/ref/Deprecated/Deprecated.tex @@ -9,9 +9,9 @@ module Deprecated ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -deprecated\ ::\ Int -\end{tabular}]\haddockbegindoc +deprecated :: Int +\end{tabular}] +{\haddockbegindoc Deprecated: Don't use this\par -Docs for something deprecated\par - +Docs for something deprecated\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/Deprecated/haddock.sty b/latex-test/ref/Deprecated/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/Deprecated/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/Deprecated/main.tex b/latex-test/ref/Deprecated/main.tex deleted file mode 100644 index 76def1cd..00000000 --- a/latex-test/ref/Deprecated/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{Deprecated} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/Example/Example.tex b/latex-test/ref/Example/Example.tex new file mode 100644 index 00000000..11f7e734 --- /dev/null +++ b/latex-test/ref/Example/Example.tex @@ -0,0 +1,30 @@ +\haddockmoduleheading{Example} +\label{module:Example} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module Example ( + split + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +split :: Int -> () +\end{tabular}] +{\haddockbegindoc +Example use.\par +\begin{quote} +{\haddockverb\begin{verbatim} +>>> split 1 +() + +\end{verbatim}} +\end{quote} +\begin{quote} +{\haddockverb\begin{verbatim} +>>> split 2 +() + +\end{verbatim}} +\end{quote}} +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex index 7aaf5512..9953ce55 100644 --- a/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex +++ b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex @@ -9,17 +9,18 @@ module GadtConstructorArgs ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Boo\ where -\end{tabular}]\haddockbegindoc +data Boo where +\end{tabular}] +{\haddockbegindoc \enspace \emph{Constructors}\par \haddockbeginconstrs & \haddockdecltt{Fot} & \\ - & \qquad \haddockdecltt{:: \{} \enspace \haddockdecltt{x :: Int} & an \haddockid{x} \\ + & \qquad \haddockdecltt{:: {\char '173}} \enspace \haddockdecltt{x :: Int} & an \haddockid{x} \\ & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{y :: Int} & a \haddockid{y} \\ - & \qquad \haddockdecltt{\ \ \ \ \} ->} \enspace \haddockdecltt{Boo} & \\ + & \qquad \haddockdecltt{\ \ \ \ {\char '175} ->} \enspace \haddockdecltt{Boo} & \\ & \haddockdecltt{Fob} & Record GADT with docs \\ - & \qquad \haddockdecltt{:: \{} \enspace \haddockdecltt{w :: Int} & a \haddockid{w} \\ + & \qquad \haddockdecltt{:: {\char '173}} \enspace \haddockdecltt{w :: Int} & a \haddockid{w} \\ & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{z :: Int} & a \haddockid{z} \\ - & \qquad \haddockdecltt{\ \ \ \ \} ->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ -\end{tabulary}\par + & \qquad \haddockdecltt{\ \ \ \ {\char '175} ->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ +\end{tabulary}\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/GadtConstructorArgs/haddock.sty b/latex-test/ref/GadtConstructorArgs/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/GadtConstructorArgs/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/GadtConstructorArgs/main.tex b/latex-test/ref/GadtConstructorArgs/main.tex deleted file mode 100644 index dc1a1aa3..00000000 --- a/latex-test/ref/GadtConstructorArgs/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{GadtConstructorArgs} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex index f39bd0ec..44c052c6 100644 --- a/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex +++ b/latex-test/ref/NamespacedIdentifier/NamespacedIdentifiers.tex @@ -3,39 +3,35 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module NamespacedIdentifiers ( - Foo(Bar), Bar + Foo(Bar), Bar ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Foo -\end{tabular}]\haddockbegindoc +data Foo +\end{tabular}] +{\haddockbegindoc A link to:\par -\begin{itemize} +\vbox{\begin{itemize} \item the type \haddockid{Bar}\par - \item the constructor \haddockid{Bar}\par - \item the unimported but qualified type \haddockid{A}\par - \item the unimported but qualified value \haddockid{A}\par - -\end{itemize} - +\end{itemize}} \enspace \emph{Constructors}\par \haddockbeginconstrs \haddockdecltt{=} & \haddockdecltt{Bar} & \\ -\end{tabulary}\par +\end{tabulary}\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Bar -\end{tabular}]\haddockbegindoc -A link to the value \haddocktt{Foo} (which shouldn't exist).\par - +data Bar +\end{tabular}] +{\haddockbegindoc +A link to the value \haddocktt{Foo} (which shouldn't exist).\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/NamespacedIdentifier/haddock.sty b/latex-test/ref/NamespacedIdentifier/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/NamespacedIdentifier/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/NamespacedIdentifier/main.tex b/latex-test/ref/NamespacedIdentifier/main.tex deleted file mode 100644 index 75493e12..00000000 --- a/latex-test/ref/NamespacedIdentifier/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{NamespacedIdentifiers} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/Simple/Simple.tex b/latex-test/ref/Simple/Simple.tex index 5ba4712c..96e9338a 100644 --- a/latex-test/ref/Simple/Simple.tex +++ b/latex-test/ref/Simple/Simple.tex @@ -9,8 +9,8 @@ module Simple ( \begin{haddockdesc} \item[\begin{tabular}{@{}l} -foo\ ::\ t -\end{tabular}]\haddockbegindoc -This is foo.\par - +foo :: t +\end{tabular}] +{\haddockbegindoc +This is foo.\par} \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/Simple/haddock.sty b/latex-test/ref/Simple/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/Simple/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/Simple/main.tex b/latex-test/ref/Simple/main.tex deleted file mode 100644 index 36536981..00000000 --- a/latex-test/ref/Simple/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{Simple} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex index 2a8ad297..d8787704 100644 --- a/latex-test/ref/TypeFamilies3/TypeFamilies3.tex +++ b/latex-test/ref/TypeFamilies3/TypeFamilies3.tex @@ -3,42 +3,42 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module TypeFamilies3 ( - Foo, Bar, Baz(Baz3, Baz2, Baz1) + Foo, Bar, Baz(Baz3, Baz2, Baz1) ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -type\ family\ Foo\ a\ where -\end{tabular}]\haddockbegindoc +type family Foo a where +\end{tabular}] +{\haddockbegindoc \haddockbeginargs \haddockdecltt{Foo () = Int} \\ -\haddockdecltt{Foo \_ = ()} \\ +\haddockdecltt{Foo {\char '137} = ()} \\ \end{tabulary}\par -A closed type family\par - +A closed type family\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -type\ family\ Bar\ a -\end{tabular}]\haddockbegindoc -An open family\par - +type family Bar a +\end{tabular}] +{\haddockbegindoc +An open family\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -type\ instance\ Bar\ Int\ =\ ()\\type\ instance\ Bar\ ()\ =\ Int +type instance Bar Int = ()\\type instance Bar () = Int \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ family\ Baz\ a -\end{tabular}]\haddockbegindoc -A data family\par - +data family Baz a +\end{tabular}] +{\haddockbegindoc +A data family\par} \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -newtype\ instance\ Baz\ Double\\data\ instance\ Baz\ Int\\data\ instance\ Baz\ () +newtype instance Baz Double\\data instance Baz Int\\data instance Baz () \end{tabular}] \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/TypeFamilies3/haddock.sty b/latex-test/ref/TypeFamilies3/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/TypeFamilies3/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/TypeFamilies3/main.tex b/latex-test/ref/TypeFamilies3/main.tex deleted file mode 100644 index 2c98043c..00000000 --- a/latex-test/ref/TypeFamilies3/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{TypeFamilies3} -\end{document} \ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex index 36d5c12b..990d2a5b 100644 --- a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex +++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex @@ -3,34 +3,34 @@ \haddockbeginheader {\haddockverb\begin{verbatim} module UnboxedStuff ( - X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum + X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum ) where\end{verbatim}} \haddockendheader \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ X +data X \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Y +data Y \end{tabular}] \end{haddockdesc} \begin{haddockdesc} \item[\begin{tabular}{@{}l} -data\ Z +data Z \end{tabular}] \end{haddockdesc} \section{Unboxed type constructors} \begin{haddockdesc} -\item[ -unboxedUnit\ ::\ ({\char '43}\ {\char '43})\ ->\ ({\char '43}\ {\char '43}) -] -\item[ -unboxedTuple\ ::\ ({\char '43}\ X,\ Y\ {\char '43})\ ->\ ({\char '43}\ X,\ Y,\ Z\ {\char '43}) -] -\item[ -unboxedSum\ ::\ ({\char '43}\ X\ |\ Y\ {\char '43})\ ->\ ({\char '43}\ X\ |\ Y\ |\ Z\ {\char '43}) -] +\item[\begin{tabular}{@{}l} +unboxedUnit :: ({\char '43} {\char '43}) -> ({\char '43} {\char '43}) +\end{tabular}] +\item[\begin{tabular}{@{}l} +unboxedTuple :: ({\char '43} X, Y {\char '43}) -> ({\char '43} X, Y, Z {\char '43}) +\end{tabular}] +\item[\begin{tabular}{@{}l} +unboxedSum :: ({\char '43} X | Y {\char '43}) -> ({\char '43} X | Y | Z {\char '43}) +\end{tabular}] \end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/haddock.sty b/latex-test/ref/UnboxedStuff/haddock.sty deleted file mode 100644 index 6e031a98..00000000 --- a/latex-test/ref/UnboxedStuff/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/latex-test/ref/UnboxedStuff/main.tex b/latex-test/ref/UnboxedStuff/main.tex deleted file mode 100644 index e34c5f14..00000000 --- a/latex-test/ref/UnboxedStuff/main.tex +++ /dev/null @@ -1,11 +0,0 @@ -\documentclass{book} -\usepackage{haddock} -\begin{document} -\begin{titlepage} -\begin{haddocktitle} - -\end{haddocktitle} -\end{titlepage} -\tableofcontents -\input{UnboxedStuff} -\end{document} \ No newline at end of file diff --git a/latex-test/src/Example/Example.hs b/latex-test/src/Example/Example.hs new file mode 100644 index 00000000..42ff1646 --- /dev/null +++ b/latex-test/src/Example/Example.hs @@ -0,0 +1,11 @@ +module Example where + +-- | Example use. +-- +-- >>> split 1 +-- () +-- +-- >>> split 2 +-- () +split :: Int -> () +split _ = () -- cgit v1.2.3 From 3efdc3a8da642d5d76b2c3f10a22f0503f65456a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 11 Feb 2019 12:27:41 -0500 Subject: Remove workaround for now-fixed Clang CPP bug (#1028) Before LLVM 6.0.1 (or 10.0 on Apple LLVM), there was a bug where lines that started with an octothorpe but turned out not to lex like pragmas would have an extra line added after them. Since this bug has been fixed upstream and that it doesn't have dire consequences anyways, the workaround is not really worth it anymore - we can just tell people to update their clang version (or re-structure their pragma code). --- haddock-api/haddock-api.cabal | 2 - haddock-api/src/Haddock/Backends/Hyperlinker.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Parser.hs | 47 +-------------------- .../Haddock/Backends/Hyperlinker/ParserSpec.hs | 49 ++++++++-------------- hypsrc-test/Main.hs | 9 +--- hypsrc-test/src/ClangCppBug.hs | 21 ---------- 6 files changed, 22 insertions(+), 110 deletions(-) delete mode 100644 hypsrc-test/src/ClangCppBug.hs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index a58b092a..5e8b37d8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -59,7 +59,6 @@ library , directory , filepath , ghc-boot - , ghc-boot-th , transformers hs-source-dirs: src @@ -186,7 +185,6 @@ test-suite spec , directory , filepath , ghc-boot - , ghc-boot-th , transformers build-tool-depends: diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 5ef7d9bb..251c886b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -25,7 +25,6 @@ import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache ) import UniqSupply ( mkSplitUniqSupply ) -import SysTools.Info ( getCompilerInfo' ) -- | Generate hyperlinked source for given interfaces. @@ -62,12 +61,11 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of , hie_types = types , hie_hs_src = rawSrc } <- fmap fst (readHieFile (initNameCache u []) hfp) - comp <- getCompilerInfo' df -- Get the AST and tokens corresponding to the source file we want let mast | M.size asts == 1 = snd <$> M.lookupMin asts | otherwise = M.lookup (mkFastString file) asts - tokens = parse comp df file rawSrc + tokens = parse df file rawSrc -- Produce and write out the hyperlinked sources case mast of diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 1d5576cc..0bd467e1 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -6,13 +6,9 @@ import Control.Applicative ( Alternative(..) ) import Data.List ( isPrefixOf, isSuffixOf ) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC - -import GHC.LanguageExtensions.Type import BasicTypes ( IntegralLit(..) ) import DynFlags -import qualified EnumSet as E import ErrUtils ( emptyMessages ) import FastString ( mkFastString ) import Lexer ( P(..), ParseResult(..), PState(..), Token(..) @@ -29,12 +25,11 @@ import Haddock.GhcUtils -- Result should retain original file layout (including comments, -- whitespace, and CPP). parse - :: CompilerInfo -- ^ Underlying CC compiler (whatever expanded CPP) - -> DynFlags -- ^ Flags for this module + :: DynFlags -- ^ Flags for this module -> FilePath -- ^ Path to the source of this module -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module -> [T.Token] -parse comp dflags fpath bs = case unP (go False []) initState of +parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed _ ss errMsg -> panic $ "Hyperlinker parse error at " ++ show ss ++ ": " ++ showSDoc dflags errMsg @@ -43,7 +38,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of initState = mkPStatePure pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1 - needPragHack' = needPragHack comp dflags pflags = mkParserFlags' (warningFlags dflags) (extensionFlags dflags) (thisPackage dflags) @@ -125,12 +119,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of pure (bEnd'', False) - -- See 'needPragHack' - ITclose_prag{} - | needPragHack' - , '\n' `BSC.elem` spaceBStr - -> getInput >>= \(b,p) -> setInput (b,advanceSrcLoc p '\n') >> pure (bEnd, False) - _ -> pure (bEnd, inPragDef) let tokBStr = splitStringBuffer bStart bEnd' @@ -155,37 +143,6 @@ parse comp dflags fpath bs = case unP (go False []) initState of pure ([unkTok], False) --- | This is really, really, /really/ gross. Problem: consider a Haskell --- file that looks like: --- --- @ --- {-# LANGUAGE CPP #-} --- module SomeMod where --- --- #define SIX 6 --- --- {-# INLINE foo --- #-} --- foo = 1 --- @ --- --- Clang's CPP replaces the @#define SIX 6@ line with an empty line (as it --- should), but get confused about @#-}@. I'm guessing it /starts/ by --- parsing that as a pre-processor directive and, when it fails to, it just --- leaves the line alone. HOWEVER, it still adds an extra newline. =.= --- --- This function makes sure that the Hyperlinker backend also adds that --- extra newline (or else our spans won't line up with GHC's anymore). -needPragHack :: CompilerInfo -> DynFlags -> Bool -needPragHack comp dflags = isCcClang && E.member Cpp (extensionFlags dflags) - where - isCcClang = case comp of - GCC -> False - Clang -> True - AppleClang -> True - AppleClang51 -> True - UnknownCC -> False - -- | Get the input getInput :: P (StringBuffer, RealSrcLoc) getInput = P $ \p @ PState { buffer = buf, loc = srcLoc } -> POk p (buf, srcLoc) diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs index ff18cb40..1273a45a 100644 --- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs +++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs @@ -5,8 +5,7 @@ import Test.Hspec import Test.QuickCheck import GHC ( runGhc, getSessionDynFlags ) -import DynFlags ( CompilerInfo, DynFlags ) -import SysTools.Info ( getCompilerInfo' ) +import DynFlags ( DynFlags ) import Control.Monad.IO.Class import Data.String ( fromString ) @@ -17,13 +16,12 @@ import Haddock (getGhcDirs) import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types -withDynFlags :: ((DynFlags, CompilerInfo) -> IO ()) -> IO () +withDynFlags :: (DynFlags -> IO ()) -> IO () withDynFlags cont = do libDir <- fmap snd (getGhcDirs []) runGhc (Just libDir) $ do dflags <- getSessionDynFlags - cinfo <- liftIO $ getCompilerInfo' dflags - liftIO $ cont (dflags, cinfo) + liftIO $ cont dflags main :: IO () @@ -60,60 +58,54 @@ instance Arbitrary NoGhcRewrite where parseSpec :: Spec parseSpec = around withDynFlags $ do - it "is total" $ \(dflags, cinfo) -> - property $ \src -> length (parse cinfo dflags "" (fromString src)) `shouldSatisfy` (>= 0) + it "is total" $ \dflags -> + property $ \src -> length (parse dflags "" (fromString src)) `shouldSatisfy` (>= 0) - it "retains file layout" $ \(dflags, cinfo) -> + it "retains file layout" $ \dflags -> property $ \(NoGhcRewrite src) -> let orig = fromString src - lexed = BS.concat (map tkValue (parse cinfo dflags "" orig)) + lexed = BS.concat (map tkValue (parse dflags "" orig)) in lexed == orig context "when parsing single-line comments" $ do - it "should ignore content until the end of line" $ \(dflags, cinfo) -> + it "should ignore content until the end of line" $ \dflags -> shouldParseTo "-- some very simple comment\nidentifier" [TkComment, TkSpace, TkIdentifier] - cinfo dflags - it "should allow endline escaping" $ \(dflags, cinfo) -> + it "should allow endline escaping" $ \dflags -> shouldParseTo "#define first line\\\nsecond line\\\nand another one" [TkCpp] - cinfo dflags context "when parsing multi-line comments" $ do - it "should support nested comments" $ \(dflags, cinfo) -> + it "should support nested comments" $ \dflags -> shouldParseTo "{- comment {- nested -} still comment -} {- next comment -}" [TkComment, TkSpace, TkComment] - cinfo dflags - it "should distinguish compiler pragma" $ \(dflags, cinfo) -> + it "should distinguish compiler pragma" $ \dflags -> shouldParseTo "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}" [TkComment, TkPragma, TkComment] - cinfo dflags - it "should recognize preprocessor directives" $ \(dflags, cinfo) -> do + it "should recognize preprocessor directives" $ \dflags -> do shouldParseTo "\n#define foo bar" [TkCpp] - cinfo dflags shouldParseTo "x # y" [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier] - cinfo dflags - it "should distinguish basic language constructs" $ \(dflags, cinfo) -> do + it "should distinguish basic language constructs" $ \dflags -> do shouldParseTo "(* 2) <$> (\"abc\", foo)" @@ -121,7 +113,6 @@ parseSpec = around withDynFlags $ do , TkSpace, TkOperator, TkSpace , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial ] - cinfo dflags shouldParseTo @@ -131,7 +122,6 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier ] - cinfo dflags shouldParseTo @@ -142,10 +132,9 @@ parseSpec = around withDynFlags $ do , TkSpace, TkKeyword, TkSpace , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier ] - cinfo dflags - it "should parse do-notation syntax" $ \(dflags, cinfo) -> do + it "should parse do-notation syntax" $ \dflags -> do shouldParseTo "do { foo <- getLine; putStrLn foo }" [ TkKeyword, TkSpace, TkSpecial, TkSpace @@ -153,7 +142,6 @@ parseSpec = around withDynFlags $ do , TkIdentifier, TkSpecial, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial ] - cinfo dflags shouldParseTo @@ -166,10 +154,9 @@ parseSpec = around withDynFlags $ do , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace , TkIdentifier, TkSpace, TkIdentifier, TkSpace ] - cinfo dflags where - shouldParseTo :: ByteString -> [TokenType] -> CompilerInfo -> DynFlags -> Expectation - shouldParseTo str tokens cinfo dflags = [ tkType tok - | tok <- parse cinfo dflags "" str - , not (BS.null (tkValue tok)) ] `shouldBe` tokens + shouldParseTo :: ByteString -> [TokenType] -> DynFlags -> Expectation + shouldParseTo str tokens dflags = [ tkType tok + | tok <- parse dflags "" str + , not (BS.null (tkValue tok)) ] `shouldBe` tokens diff --git a/hypsrc-test/Main.hs b/hypsrc-test/Main.hs index 1963753d..f7614927 100644 --- a/hypsrc-test/Main.hs +++ b/hypsrc-test/Main.hs @@ -20,18 +20,11 @@ checkConfig = CheckConfig , ccfgEqual = (==) `on` dumpXml } where - -- The whole point of the ClangCppBug is to demonstrate a situation where - -- line numbers may vary (and test that links still work). Consequently, we - -- strip out line numbers for this test case. - strip f | takeBaseName f == "ClangCppBug" - = stripAnchors' . stripLinks' . stripIds' . stripIds'' . stripFooter - | otherwise - = stripAnchors' . stripLinks' . stripIds' . stripFooter + strip _ = stripAnchors' . stripLinks' . stripIds' . stripFooter stripLinks' = stripLinksWhen $ \href -> "#local-" `isPrefixOf` href stripAnchors' = stripAnchorsWhen $ \name -> "local-" `isPrefixOf` name stripIds' = stripIdsWhen $ \name -> "local-" `isPrefixOf` name - stripIds'' = stripIdsWhen $ \name -> "line-" `isPrefixOf` name dirConfig :: DirConfig diff --git a/hypsrc-test/src/ClangCppBug.hs b/hypsrc-test/src/ClangCppBug.hs deleted file mode 100644 index 4b0bc35f..00000000 --- a/hypsrc-test/src/ClangCppBug.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE CPP #-} -module ClangCppBug where - -foo :: Int -foo = 1 - --- Clang doesn't mind these: -#define BAX 2 -{-# INLINE bar #-} - -bar :: Int -bar = 3 - --- But it doesn't like this: -{-# RULES -"bar/qux" bar = qux -"qux/foo" qux = foo - #-} - -qux :: Int -qux = 88 -- cgit v1.2.3 From dc78937c638d9e1e4f4cfd18f90ecf79d8649c06 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 26 Jan 2019 21:45:59 +0200 Subject: Matching changes in GHC for #16236 (cherry picked from commit 3ee6526d4ae7bf4deb7cd1caf24b3d7355573576) --- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 ++-- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index cc096a7a..c62a9311 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1029,9 +1029,9 @@ ppCtxType unicode ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode ppLHsTypeArg :: Bool -> LHsTypeArg DocNameI -> LaTeX ppLHsTypeArg unicode (HsValArg ty) = ppLParendType unicode ty -ppLHsTypeArg unicode (HsTypeArg ki) = atSign unicode <> - ppLParendType unicode ki -ppLHsTypeArg _ (HsArgPar _) = text "" +ppLHsTypeArg unicode (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode ki +ppLHsTypeArg _ (HsArgPar _) = text "" ppHsTyVarBndr :: Bool -> HsTyVarBndr DocNameI -> LaTeX ppHsTyVarBndr _ (UserTyVar _ (L _ name)) = ppDocName name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 56a79d57..40d630b0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1135,8 +1135,8 @@ ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty -ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg ki) = atSign unicode <> - ppLParendType unicode qual emptyCtxts ki +ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg _ ki) = atSign unicode <> + ppLParendType unicode qual emptyCtxts ki ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml "" ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d89efb5a..463411b4 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1140,7 +1140,7 @@ extractPatternSyn nm t tvs cons = | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty - mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki mkAppTyArg f (HsArgPar _) = HsParTy noExt f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] @@ -1162,8 +1162,8 @@ extractRecSel nm t tvs (L _ con : rest) = | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn mkAppTyArg f (HsValArg ty) = HsAppTy noExt f ty - mkAppTyArg f (HsTypeArg ki) = HsAppKindTy noExt f ki - mkAppTyArg f (HsArgPar _) = HsParTy noExt f + mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki + mkAppTyArg f (HsArgPar _) = HsParTy noExt f -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 88238f04..ceea2444 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -186,8 +186,8 @@ renameLType = mapM renameType renameLTypeArg :: LHsTypeArg GhcRn -> RnM (LHsTypeArg DocNameI) renameLTypeArg (HsValArg ty) = do { ty' <- renameLType ty ; return $ HsValArg ty' } -renameLTypeArg (HsTypeArg ki) = do { ki' <- renameLKind ki - ; return $ HsTypeArg ki' } +renameLTypeArg (HsTypeArg l ki) = do { ki' <- renameLKind ki + ; return $ HsTypeArg l ki' } renameLTypeArg (HsArgPar sp) = return $ HsArgPar sp renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) -- cgit v1.2.3 From 1126fe196fd0d5a2ad73e965982d6c75a2df0279 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 13 Mar 2019 16:34:05 -0400 Subject: Bump GHC to 8.8 --- haddock-api/haddock-api.cabal | 4 ++-- haddock.cabal | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 5e8b37d8..34d0bc30 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -44,7 +44,7 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.12.0 , Cabal ^>= 2.4.0 - , ghc ^>= 8.7 + , ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 @@ -167,7 +167,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Types build-depends: Cabal ^>= 2.4 - , ghc ^>= 8.7 + , ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 diff --git a/haddock.cabal b/haddock.cabal index 91a5ea3d..603a6a9b 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -79,8 +79,7 @@ executable haddock xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, ghc-boot, - ghc-boot-th, - ghc == 8.7.*, + ghc == 8.8.*, bytestring, parsec, text, -- cgit v1.2.3 From 622ea3f4088039d7c1cca84f11954fc82288a3c6 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 2 May 2019 21:40:15 +0300 Subject: Redo ParseModuleHeader --- .../src/Haddock/Interface/ParseModuleHeader.hs | 218 ++++++++++++--------- 1 file changed, 125 insertions(+), 93 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 050901b6..e4528522 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -11,7 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus) +import Control.Applicative (Alternative (..)) +import Control.Monad (ap) import Data.Char import DynFlags import Haddock.Parser @@ -27,34 +29,44 @@ import RdrName parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo RdrName, MDoc RdrName) parseModuleHeader dflags pkgName str0 = let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) - - (_moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 - (maintainerOpt,str7) = getKey "Maintainer" str6 - (stabilityOpt,str8) = getKey "Stability" str7 - (portabilityOpt,str9) = getKey "Portability" str8 + kvs :: [(String, String)] + str1 :: String + + (kvs, str1) = maybe ([], str0) id $ runP fields str0 + + -- trim whitespaces + trim :: String -> String + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + getKey :: String -> Maybe String + getKey key = fmap trim (lookup key kvs) + + descriptionOpt = getKey "Description" + copyrightOpt = getKey "Copyright" + licenseOpt = getKey "License" + licenceOpt = getKey "Licence" + spdxLicenceOpt = getKey "SPDX-License-Identifier" + maintainerOpt = getKey "Maintainer" + stabilityOpt = getKey "Stability" + portabilityOpt = getKey "Portability" in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags pkgName str9) + }, parseParas dflags pkgName str1) + +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- --- | This function is how we read keys. +-- | The below is a small parser framework how we read keys. -- -- all fields in the header are optional and have the form -- @@ -73,78 +85,98 @@ parseModuleHeader dflags pkgName str0 = -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) - - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 - - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey _ _ [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str - - accept = isFirst || sufficientIndentation || allSpaces - - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False - - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 - - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) - - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | otherwise = ([],s) - - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | otherwise = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) - - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix _ [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | otherwise = Nothing + +data C = C {-# UNPACK #-} !Int Char + +newtype P a = P { unP :: [C] -> Maybe ([C], a) } + deriving Functor + +instance Applicative P where + pure x = P $ \s -> Just (s, x) + (<*>) = ap + +instance Monad P where + return = pure + m >>= k = P $ \s0 -> do + (s1, x) <- unP m s0 + unP (k x) s1 + +instance Alternative P where + empty = P $ \_ -> Nothing + a <|> b = P $ \s -> unP a s <|> unP b s + +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') + where + input' = concat + [ zipWith C [0..] l ++ [C (length l) '\n'] + | l <- lines input + ] + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of + [] -> 0 + C i _ : _ -> i + +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> + let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs) + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \s -> case s of + [] -> Nothing + (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) + | otherwise -> Nothing + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \s -> case s of + [] -> Nothing + (C _ c' : cs) | c == c' -> Just (cs, c) + | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where + go xs0@[] = ([], xs0) + go xs0@(x:xs) = case f x of + Just y -> let (ys, zs) = go xs in (y : ys, zs) + Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do + fn <- munch1 $ \_ c -> isAlpha c || c == '-' + skipSpaces + _ <- char ':' + skipSpaces + val <- munch $ \j c -> isSpace c || j > i + return (fn, val) + +fields :: P ([(String, String)], String) +fields = do + skipSpaces + i <- curInd + fs <- many (field i) + r <- rest + return (fs, r) + -- cgit v1.2.3 From 96d094403e343ecf28c1898c9792e4bb1699b58a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 2 May 2019 23:39:41 +0300 Subject: Comment C, which clarifies why e.g. ReadP is not enough --- haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index e4528522..6ac2f186 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -86,6 +86,13 @@ parseModuleHeader dflags pkgName str0 = -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". +-- | 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- data C = C {-# UNPACK #-} !Int Char newtype P a = P { unP :: [C] -> Maybe ([C], a) } -- cgit v1.2.3 From 7068bb1054cd52604da4d3c9b02f20662a8344d2 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 16 Apr 2019 08:03:27 -0700 Subject: Remove outdated `.ghci` files and `scripts` The `.ghci` files are actively annoying when trying to `cabal v2-repl`. As for the `scripts`, the distribution workflow is completely different. --- .ghci | 1 - haddock-api/.ghci | 1 - haddock-library/.ghci | 1 - scripts/build-windows-dist.sh | 18 ------------------ scripts/make-sdist.sh | 36 ------------------------------------ 5 files changed, 57 deletions(-) delete mode 100644 .ghci delete mode 100644 haddock-api/.ghci delete mode 100644 haddock-library/.ghci delete mode 100644 scripts/build-windows-dist.sh delete mode 100644 scripts/make-sdist.sh diff --git a/.ghci b/.ghci deleted file mode 100644 index 8166be36..00000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set --itest -idist/build -idist/build/autogen -packageghc -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/haddock-api/.ghci b/haddock-api/.ghci deleted file mode 100644 index 62e7c5d2..00000000 --- a/haddock-api/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -isrc -idist/build -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/haddock-library/.ghci b/haddock-library/.ghci deleted file mode 100644 index 78950a5b..00000000 --- a/haddock-library/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -isrc -ivendor/attoparsec-0.12.1.1 -itest -idist/build -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/scripts/build-windows-dist.sh b/scripts/build-windows-dist.sh deleted file mode 100644 index 2ae7dd2a..00000000 --- a/scripts/build-windows-dist.sh +++ /dev/null @@ -1,18 +0,0 @@ -# mini script for building the relocatable Windows binary distribution. -# -# sh build-windows-dist.sh -# -# NB. the Cabal that shipped with GHC 6.6 isn't enough for this, because it -# is missing this patch: -# -# Fri Oct 13 11:09:41 BST 2006 Simon Marlow -# * Fix getDataDir etc. when bindir=$prefix -# -# So you need to use a more recent Cabal. GHC 6.6 is fine for building the -# package, though. - -ghc --make Setup -./Setup configure --prefix=`pwd`/install --bindir='$prefix' --libdir='$prefix' --datadir='$prefix' -./Setup build -./Setup install -echo Now zip up `pwd`/install as "haddock--Win32.zip" diff --git a/scripts/make-sdist.sh b/scripts/make-sdist.sh deleted file mode 100644 index 914bf909..00000000 --- a/scripts/make-sdist.sh +++ /dev/null @@ -1,36 +0,0 @@ -# Put the Happy-generated .hs files in the right place in the source dist. -set -e -rm -f dist/haddock-*.tar.gz -rm -rf dist/haddock-*/ -./Setup sdist -cd dist -tar xvzf haddock-*.tar.gz -cd haddock-*/ -mkdir dist -mkdir dist/build -mv haddock dist/build -cd .. -tar cvzf haddock-*.tar.gz haddock-*/ - -# Steps for doing a release: -# * Update version number in .cabal, doc/haddock.xml -# * Update CHANGES -# * Source: -# - do the above -# - upload the dist to haskell.org:haddock/dist/${version} -# - scp CHANGES haskell.org:haddock/CHANGES.txt -# * Binaries: -# - build the Windows binary zip (see build-windows-dist.sh) -# - scp haddock--Win32.zip haskell.org:haddock/dist -# * Documentation: -# - cd doc -# - make html -# - mv haddock haddock-html -# - tar cvzf haddock-doc-html-${version}.tar.gz haddock-html -# - scp haddock-doc-html-${version}.tar.gz www.haskell.org:../haskell/haddock/doc -# - ssh haskell.org -# - cd haddock/doc -# - tar xvzf haddock-doc-html-${version}.tar.gz -# - rm -rf html-OLD -# - mv html html-OLD && mv haddock-html html -# * Update the web page (~/darcs/www/haddock/index.html), and push it -- cgit v1.2.3 From a8e08eaa66cf2695b0331fbe8bcb2621b9bdd4d2 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 16 Apr 2019 13:28:14 -0700 Subject: Remove obsolete arcanist files + STYLE Now that GHC is hosted on Gitlab, the arcanist files don't make sense anymore. The STYLE file contains nothing more than a dead link too. --- .arcconfig | 5 ----- .arclint | 24 ------------------------ STYLE | 3 --- 3 files changed, 32 deletions(-) delete mode 100644 .arcconfig delete mode 100644 .arclint delete mode 100644 STYLE diff --git a/.arcconfig b/.arcconfig deleted file mode 100644 index 0693c58f..00000000 --- a/.arcconfig +++ /dev/null @@ -1,5 +0,0 @@ -{ - "project.name" : "haddock", - "repository.callsign" : "HADDOCK", - "phabricator.uri" : "https://phabricator.haskell.org" -} diff --git a/.arclint b/.arclint deleted file mode 100644 index 01f217d7..00000000 --- a/.arclint +++ /dev/null @@ -1,24 +0,0 @@ -{ - "linters": { - "filename": { - "type": "filename" - }, - "generated": { - "type": "generated" - }, - "merge-conflict": { - "type": "merge-conflict" - }, - "nolint": { - "type": "nolint" - }, - "haskell": { - "type": "text", - "include": ["(\\.(l?hs(-boot)?|x|y\\.pp)(\\.in)?$)"], - "severity": { - "5": "disabled", - "2": "warning" - } - } - } -} diff --git a/STYLE b/STYLE deleted file mode 100644 index ce7ddfdb..00000000 --- a/STYLE +++ /dev/null @@ -1,3 +0,0 @@ - -See http://github.com/waern/haskell-style-guide - -- cgit v1.2.3 From 10cfca4c660b682827e929ce0251341cb73efd14 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 2 May 2019 21:40:15 +0300 Subject: Redo ParseModuleHeader --- .../src/Haddock/Interface/ParseModuleHeader.hs | 218 ++++++++++++--------- 1 file changed, 125 insertions(+), 93 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 802ea773..32411e9e 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | @@ -11,7 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where -import Control.Monad (mplus) +import Control.Applicative (Alternative (..)) +import Control.Monad (ap) import Data.Char import DynFlags import Haddock.Parser @@ -26,34 +28,44 @@ import Haddock.Types parseModuleHeader :: DynFlags -> Maybe Package -> String -> (HaddockModInfo NsRdrName, MDoc NsRdrName) parseModuleHeader dflags pkgName str0 = let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) - - (_moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (spdxLicenceOpt,str6) = getKey "SPDX-License-Identifier" str5 - (maintainerOpt,str7) = getKey "Maintainer" str6 - (stabilityOpt,str8) = getKey "Stability" str7 - (portabilityOpt,str9) = getKey "Portability" str8 + kvs :: [(String, String)] + str1 :: String + + (kvs, str1) = maybe ([], str0) id $ runP fields str0 + + -- trim whitespaces + trim :: String -> String + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + getKey :: String -> Maybe String + getKey key = fmap trim (lookup key kvs) + + descriptionOpt = getKey "Description" + copyrightOpt = getKey "Copyright" + licenseOpt = getKey "License" + licenceOpt = getKey "Licence" + spdxLicenceOpt = getKey "SPDX-License-Identifier" + maintainerOpt = getKey "Maintainer" + stabilityOpt = getKey "Stability" + portabilityOpt = getKey "Portability" in (HaddockModInfo { hmi_description = parseString dflags <$> descriptionOpt, hmi_copyright = copyrightOpt, - hmi_license = spdxLicenceOpt `mplus` licenseOpt `mplus` licenceOpt, + hmi_license = spdxLicenceOpt <|> licenseOpt <|> licenceOpt, hmi_maintainer = maintainerOpt, hmi_stability = stabilityOpt, hmi_portability = portabilityOpt, hmi_safety = Nothing, hmi_language = Nothing, -- set in LexParseRn hmi_extensions = [] -- also set in LexParseRn - }, parseParas dflags pkgName str9) + }, parseParas dflags pkgName str1) + +------------------------------------------------------------------------------- +-- Small parser to parse module header. +------------------------------------------------------------------------------- --- | This function is how we read keys. +-- | The below is a small parser framework how we read keys. -- -- all fields in the header are optional and have the form -- @@ -72,78 +84,98 @@ parseModuleHeader dflags pkgName str0 = -- -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces (dropWhile (`elem` ['\r', '\n']) toParse0) - - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 - - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey _ _ [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str - - accept = isFirst || sufficientIndentation || allSpaces - - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False - - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 - - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) - - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | otherwise = ([],s) - - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | otherwise = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) - - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix _ [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | otherwise = Nothing + +data C = C {-# UNPACK #-} !Int Char + +newtype P a = P { unP :: [C] -> Maybe ([C], a) } + deriving Functor + +instance Applicative P where + pure x = P $ \s -> Just (s, x) + (<*>) = ap + +instance Monad P where + return = pure + m >>= k = P $ \s0 -> do + (s1, x) <- unP m s0 + unP (k x) s1 + +instance Alternative P where + empty = P $ \_ -> Nothing + a <|> b = P $ \s -> unP a s <|> unP b s + +runP :: P a -> String -> Maybe a +runP p input = fmap snd (unP p input') + where + input' = concat + [ zipWith C [0..] l ++ [C (length l) '\n'] + | l <- lines input + ] + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +curInd :: P Int +curInd = P $ \s -> Just . (,) s $ case s of + [] -> 0 + C i _ : _ -> i + +rest :: P String +rest = P $ \cs -> Just ([], [ c | C _ c <- cs ]) + +munch :: (Int -> Char -> Bool) -> P String +munch p = P $ \cs -> + let (xs,ys) = takeWhileMaybe p' cs in Just (ys, xs) + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +munch1 :: (Int -> Char -> Bool) -> P String +munch1 p = P $ \s -> case s of + [] -> Nothing + (c:cs) | Just c' <- p' c -> let (xs,ys) = takeWhileMaybe p' cs in Just (ys, c' : xs) + | otherwise -> Nothing + where + p' (C i c) + | p i c = Just c + | otherwise = Nothing + +char :: Char -> P Char +char c = P $ \s -> case s of + [] -> Nothing + (C _ c' : cs) | c == c' -> Just (cs, c) + | otherwise -> Nothing + +skipSpaces :: P () +skipSpaces = P $ \cs -> Just (dropWhile (\(C _ c) -> isSpace c) cs, ()) + +takeWhileMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +takeWhileMaybe f = go where + go xs0@[] = ([], xs0) + go xs0@(x:xs) = case f x of + Just y -> let (ys, zs) = go xs in (y : ys, zs) + Nothing -> ([], xs0) + +------------------------------------------------------------------------------- +-- Fields +------------------------------------------------------------------------------- + +field :: Int -> P (String, String) +field i = do + fn <- munch1 $ \_ c -> isAlpha c || c == '-' + skipSpaces + _ <- char ':' + skipSpaces + val <- munch $ \j c -> isSpace c || j > i + return (fn, val) + +fields :: P ([(String, String)], String) +fields = do + skipSpaces + i <- curInd + fs <- many (field i) + r <- rest + return (fs, r) + -- cgit v1.2.3 From bfe31a74f469b0e2c1a7360358698dcc32af9f5a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 2 May 2019 23:39:41 +0300 Subject: Comment C, which clarifies why e.g. ReadP is not enough --- haddock-api/src/Haddock/Interface/ParseModuleHeader.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs index 32411e9e..37813d16 100644 --- a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -85,6 +85,13 @@ parseModuleHeader dflags pkgName str0 = -- the value will be "this is a .. description" and the rest will begin -- at "The module comment". +-- | 'C' is a 'Char' carrying its column. +-- +-- This let us make an indentation-aware parser, as we know current indentation. +-- by looking at the next character in the stream ('curInd'). +-- +-- Thus we can munch all spaces but only not-spaces which are indented. +-- data C = C {-# UNPACK #-} !Int Char newtype P a = P { unP :: [C] -> Maybe ([C], a) } -- cgit v1.2.3 From b4c2b90dc5c19eb5ca1420d37d1fc1b0ed184afd Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 17 May 2019 11:22:47 -0400 Subject: Unbreak #1004 test case `fail` is no longer part of `Monad`. --- html-test/ref/Bug1004.html | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/html-test/ref/Bug1004.html b/html-test/ref/Bug1004.html index 630df356..be215281 100644 --- a/html-test/ref/Bug1004.html +++ b/html-test/ref/Bug1004.html @@ -249,16 +249,6 @@ > f g a #

      fail :: String -> Product f g a #

      Safe HaskellSafe

      Bug1063

      Documentation

      class (c => d) => Implies c d #

      Instances

      Instances details
      (c => d) => Implies c d #
      Instance details

      Defined in Bug1063

      \ No newline at end of file diff --git a/html-test/src/Bug1063.hs b/html-test/src/Bug1063.hs new file mode 100644 index 00000000..c6d13a1f --- /dev/null +++ b/html-test/src/Bug1063.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +module Bug1063 where + +class (c => d) => Implies c d +instance (c => d) => Implies c d -- cgit v1.2.3 From 260e1e1be0bb23b4c6d474b36d57354441133ed1 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 26 May 2019 16:01:58 -0400 Subject: Remove Haddock's dependency on `Cabal` At this point, Haddock depended on Cabal-the-library solely for a verbosity parser (which misleadingly accepts all sorts of verbosity options that Haddock never uses). Now, the only dependency on Cabal is for `haddock-test` (which uses Cabal to locate the Haddock interface files of a couple boot libraries). --- haddock-api/haddock-api.cabal | 4 +--- haddock-api/src/Haddock/Interface.hs | 1 - haddock-api/src/Haddock/Options.hs | 3 +-- haddock-api/src/Haddock/Utils.hs | 25 ++++++++++++++++++++----- haddock.cabal | 1 - 5 files changed, 22 insertions(+), 12 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 34d0bc30..c427e752 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -43,7 +43,6 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.12.0 - , Cabal ^>= 2.4.0 , ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 @@ -166,8 +165,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: Cabal ^>= 2.4 - , ghc ^>= 8.8 + build-depends: ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index e7d30fc7..336f122a 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -47,7 +47,6 @@ import Control.Exception (evaluate) import Data.List import qualified Data.Map as Map import qualified Data.Set as Set -import Distribution.Verbosity import Text.Printf import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index e314bbd0..510810b0 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -43,7 +43,6 @@ module Haddock.Options ( import qualified Data.Char as Char import Data.Version import Control.Applicative -import Distribution.Verbosity import FastString import GHC ( DynFlags, Module, moduleUnitId ) import Haddock.Types @@ -332,7 +331,7 @@ sinceQualification flags = verbosity :: [Flag] -> Verbosity verbosity flags = case [ str | Flag_Verbosity str <- flags ] of - [] -> normal + [] -> Normal x:_ -> case parseVerbosity x of Left e -> throwE e Right v -> v diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index dda42cea..7673f02d 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -49,7 +49,7 @@ module Haddock.Utils ( MonadIO(..), -- * Logging - parseVerbosity, + parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, -- * System tools @@ -81,8 +81,6 @@ import System.Directory ( createDirectory, removeDirectoryRecursive ) import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath -import Distribution.Verbosity -import Distribution.ReadE #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -95,10 +93,27 @@ import MonadUtils ( MonadIO(..) ) -- * Logging -------------------------------------------------------------------------------- +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Eq, Ord, Enum, Bounded, Show) -parseVerbosity :: String -> Either String Verbosity -parseVerbosity = runReadE flagToVerbosity +silent, normal, verbose, deafening :: Verbosity +silent = Silent +normal = Normal +verbose = Verbose +deafening = Deafening +-- | Parse out a verbosity level. Inspired from Cabal's verbosity parsing. +parseVerbosity :: String -> Either String Verbosity +parseVerbosity "0" = Right Silent +parseVerbosity "1" = Right Normal +parseVerbosity "2" = Right Silent +parseVerbosity "3" = Right Deafening +parseVerbosity "silent" = return Silent +parseVerbosity "normal" = return Normal +parseVerbosity "verbose" = return Verbose +parseVerbosity "debug" = return Deafening +parseVerbosity "deafening" = return Deafening +parseVerbosity other = Left ("Can't parse verbosity " ++ other) -- | Print a message to stdout, if it is not too verbose out :: MonadIO m diff --git a/haddock.cabal b/haddock.cabal index 603a6a9b..078955fb 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -77,7 +77,6 @@ executable haddock deepseq, array, xhtml >= 3000.2 && < 3000.3, - Cabal >= 1.10, ghc-boot, ghc == 8.8.*, bytestring, -- cgit v1.2.3 From 646c8d2752e45d9304402d4134bf1c59006610fa Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 26 May 2019 16:16:25 -0400 Subject: Regression test: promoted lists in associated types When possible, associated types with promoted lists should use the promoted list literal syntax (instead of repeated applications of ': and '[]). This was fixed in 2122de5473fd5b434af690ff9ccb1a2e58491f8c. Closes #466, --- html-test/ref/Bug466.html | 248 ++++++++++++++++++++++++++++++++++++++++++++++ html-test/src/Bug466.hs | 9 ++ 2 files changed, 257 insertions(+) create mode 100644 html-test/ref/Bug466.html create mode 100644 html-test/src/Bug466.hs diff --git a/html-test/ref/Bug466.html b/html-test/ref/Bug466.html new file mode 100644 index 00000000..a0c1cd87 --- /dev/null +++ b/html-test/ref/Bug466.html @@ -0,0 +1,248 @@ +Bug466
      Safe HaskellSafe

      Bug466

      Documentation

      class Cl a #

      Associated Types

      type Fam a :: [*] #

      Instances

      Instances details
      Cl X #
      Instance details

      Defined in Bug466

      Associated Types

      type Fam X :: [Type] #

      data X #

      Constructors

      X

      Instances

      Instances details
      Cl X #
      Instance details

      Defined in Bug466

      Associated Types

      type Fam X :: [Type] #

      type Fam X #
      Instance details

      Defined in Bug466

      type Fam X = '[Char]
      \ No newline at end of file diff --git a/html-test/src/Bug466.hs b/html-test/src/Bug466.hs new file mode 100644 index 00000000..ec7cde2c --- /dev/null +++ b/html-test/src/Bug466.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, TypeFamilies, StarIsType #-} +module Bug466 where + +class Cl a where + type Fam a :: [*] + +data X = X +instance Cl X where + type Fam X = '[Char] -- cgit v1.2.3 From 91f55209065497c8cd0d0a23e5ed5561410b4df0 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 26 May 2019 15:19:27 -0400 Subject: Release haddock-2.23, haddock-library-1.8.0 Tentatively adjust bounds and changelogs for the release to be bundled with GHC 8.8.1. --- CHANGES.md | 4 +++- haddock-api/haddock-api.cabal | 6 +++--- haddock-library/haddock-library.cabal | 2 +- .../src/Documentation/Haddock/Parser/Identifier.hs | 10 +++++----- haddock-test/haddock-test.cabal | 2 +- haddock.cabal | 11 +++++------ 6 files changed, 18 insertions(+), 17 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index a6d96fed..88656da4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,4 @@ -## Changes in TBA +## Changes in 2.23.0 * "Linuwial" is the new default theme (#721, #782, #949) @@ -29,6 +29,8 @@ * Many fixes to the LaTeX backend, mostly focused on not crashing as well as generating LaTeX source that compiles + * More flexible parsing of the module header + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index c427e752..9a120f5d 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.22.0 +version: 2.23.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -42,7 +42,7 @@ library default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base ^>= 4.12.0 + build-depends: base ^>= 4.13.0 , ghc ^>= 8.8 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 @@ -65,7 +65,7 @@ library ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 ghc-options: -Wall if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances exposed-modules: Documentation.Haddock diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 5c744082..99773475 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -33,7 +33,7 @@ common lib-defaults ghc-options: -funbox-strict-fields -Wall -fwarn-tabs if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances library import: lib-defaults diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs index 7bc98b62..a83e5abf 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -109,7 +109,7 @@ takeIdentifier input = listToMaybe $ do (cl, input'''') <- maybeToList (T.uncons input''') guard (cl == '\'' || cl == '`') - pure (ns, op, ident, cl, input'''') + return (ns, op, ident, cl, input'''') where @@ -122,21 +122,21 @@ takeIdentifier input = listToMaybe $ do , c' == ',' || c' == ')' -> do let (commas, t'') = T.span (== ',') t' (')', t''') <- maybeToList (T.uncons t'') - pure (T.take (T.length commas + 2) t, t''') + return (T.take (T.length commas + 2) t, t''') -- Parenthesized '(' -> do (n, t'' ) <- general False 0 [] t' (')', t''') <- maybeToList (T.uncons t'') - pure (T.take (n + 2) t, t''') + return (T.take (n + 2) t, t''') -- Backticked '`' -> do (n, t'' ) <- general False 0 [] t' ('`', t''') <- maybeToList (T.uncons t'') - pure (T.take (n + 2) t, t''') + return (T.take (n + 2) t, t''') -- Unadorned _ -> do (n, t'' ) <- general False 0 [] t - pure (T.take n t, t'') + return (T.take n t, t'') -- | Parse out a possibly qualified operator or identifier general :: Bool -- ^ refuse inputs starting with operators diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 23b5953c..ed174e4f 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -16,7 +16,7 @@ library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - build-depends: base >= 4.3 && < 4.13, bytestring, directory, process, filepath, Cabal, xml, xhtml + build-depends: base >= 4.3 && < 4.14, bytestring, directory, process, filepath, Cabal, xml, xhtml exposed-modules: Test.Haddock diff --git a/haddock.cabal b/haddock.cabal index 078955fb..563955b9 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock -version: 2.22.0 +version: 2.23.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -23,7 +23,7 @@ description: without any documentation annotations, Haddock can generate useful documentation from your source code. . - <> + <> license: BSD3 license-file: LICENSE author: Simon Marlow, David Waern @@ -33,7 +33,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.6.* +tested-with: GHC==8.8.* extra-source-files: CHANGES.md @@ -64,8 +64,7 @@ executable haddock -- haddock typically only supports a single GHC major version build-depends: - -- FIXME: drop 4.12.0.0 once GHC HEAD updates to 4.13.0.0 - base ^>= 4.12.0.0 || ^>= 4.13.0.0 + base ^>= 4.13.0.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src @@ -141,7 +140,7 @@ executable haddock else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.22.0 + build-depends: haddock-api == 2.23.0 test-suite html-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From 91c65619149f4866abcce33a56036e2e2454629f Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 25 May 2019 16:47:55 +0530 Subject: update for new way to store hiefile headers --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 251c886b..7571db9e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -19,7 +19,7 @@ import System.Directory import System.FilePath import HieTypes ( HieFile(..), HieASTs(..) ) -import HieBin ( readHieFile ) +import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) @@ -60,7 +60,8 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc - } <- fmap fst (readHieFile (initNameCache u []) hfp) + } <- (hie_file_result . fst) + <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want let mast | M.size asts == 1 = snd <$> M.lookupMin asts -- cgit v1.2.3 From 395205c0d86efd006bc8ccde7ddeb425dffe2e9e Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 20 Sep 2019 03:21:00 -0400 Subject: Fix Travis CI, loosen .cabal bounds (#1089) Tentatively for the 2.23 release: * updated Travis CI to work again * tweaked bounds in the `.cabal` files * adjusted `extra-source-files` to properly identify test files --- .travis.yml | 200 +++++++++++++++++++--------------- haddock-api/haddock-api.cabal | 8 +- haddock-library/haddock-library.cabal | 16 +-- haddock.cabal | 13 ++- 4 files changed, 135 insertions(+), 102 deletions(-) diff --git a/.travis.yml b/.travis.yml index 2417dea9..896087ba 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,104 +1,134 @@ -# NOTE: manually changes were made to an otherwise autogenerated script. This is to -# query GHC CI artifacts instead of going via Herbert's PPA -# # This Travis job script has been generated by a script via # -# make_travis_yml_2.hs 'haddock.cabal' +# haskell-ci 'haddock.cabal' '--output' '.travis.yml' +# +# For more information, see https://github.com/haskell-CI/haskell-ci # -# For more information, see https://github.com/hvr/multi-ghc-travis +# version: 0.5.20190916 # language: c -sudo: false - +dist: xenial git: - submodules: false # whether to recursively clone submodules - + # whether to recursively clone submodules + submodules: false cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store - before_cache: - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx - - - rm -rfv $HOME/.cabal/packages/head.hackage - + - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* + - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - - os: linux - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head], sources: [hvr-ghc]}} - env: - - GHC_ZIP='https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/download?job=validate-x86_64-linux-deb8' - + - compiler: ghc-8.8.1 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} before_install: - # Manually install GHC validate artifact - - travis_retry curl -L $GHC_ZIP --output artifact.zip - - unzip artifact.zip - - tar xpf ghc.tar.xz --strip-components 1 - - ./configure - - sudo make V=1 install - - # Set up some vars - - HC=ghc - - HCPKG=${HC/ghc/ghc-pkg} - - PATH=/usr/local/bin:/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH - - PKGNAME='haddock' - + - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') + - WITHCOMPILER="-w $HC" + - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') + - HCPKG="$HC-pkg" + - unset CC + - CABAL=/opt/ghc/bin/cabal + - CABALHOME=$HOME/.cabal + - export PATH="$CABALHOME/bin:$PATH" + - TOP=$(pwd) + - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" + - echo $HCNUMVER + - CABAL="$CABAL -vnormal+nowrap+markoutput" + - set -o pipefail + - | + echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk + echo 'BEGIN { state = "output"; }' >> .colorful.awk + echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk + echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk + echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk + echo ' if (state == "cabal") {' >> .colorful.awk + echo ' print blue($0)' >> .colorful.awk + echo ' } else {' >> .colorful.awk + echo ' print $0' >> .colorful.awk + echo ' }' >> .colorful.awk + echo '}' >> .colorful.awk + - cat .colorful.awk + - | + color_cabal_output () { + awk -f $TOP/.colorful.awk + } + - echo text | color_cabal_output install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=--enable-benchmarks - - TEST=--enable-tests - - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - rm -fv cabal.project.local - - rm -f cabal.project.freeze - # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage - - | - sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config - for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done - - echo 'repository head.hackage' >> ${HOME}/.cabal/config - echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config - echo ' secure: True' >> ${HOME}/.cabal/config - echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config - echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config - echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config - echo ' key-threshold: 3' >> ${HOME}/.cabal.config - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - cabal new-update head.hackage -v - - travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all - - travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all - -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. + - ${CABAL} --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - TEST=--enable-tests + - BENCH=--enable-benchmarks + - HEADHACKAGE=false + - rm -f $CABALHOME/config + - | + echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config + echo "remote-build-reporting: anonymous" >> $CABALHOME/config + echo "write-ghc-environment-files: always" >> $CABALHOME/config + echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config + echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config + echo "world-file: $CABALHOME/world" >> $CABALHOME/config + echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config + echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config + echo "installdir: $CABALHOME/bin" >> $CABALHOME/config + echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config + echo "store-dir: $CABALHOME/store" >> $CABALHOME/config + echo "install-dirs user" >> $CABALHOME/config + echo " prefix: $CABALHOME" >> $CABALHOME/config + echo "repository hackage.haskell.org" >> $CABALHOME/config + echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + - | + echo "program-default-options" >> $CABALHOME/config + echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config + - cat $CABALHOME/config + - rm -fv cabal.project.local cabal.project.freeze + - travis_retry ${CABAL} v2-update -v + # Generate cabal.project + - rm -rf cabal.project.local cabal.project.freeze + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm cabal.project.freeze + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output script: - - if [ -f configure.ac ]; then autoreconf -i; fi - - rm -rf dist/ - - cabal new-sdist # test that a source-distribution can be generated - - cd dist-newstyle/sdist/ - - SRCTAR=(${PKGNAME}-*.tar.gz) - - SRC_BASENAME="${SRCTAR/%.tar.gz}" - - tar -xvf "./$SRC_BASENAME.tar.gz" - - cd "$SRC_BASENAME/" -## from here on, CWD is inside the extracted source-tarball - - rm -fv cabal.project.local - # this builds all libraries and executables (without tests/benchmarks) - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --allow-newer --constraint 'setup.Cabal installed' all - # this builds all libraries and executables (including tests/benchmarks) - # - rm -rf ./dist-newstyle - - # build & run tests - - cabal new-build -w ${HC} ${TEST} ${BENCH} --allow-newer --constraint 'setup.Cabal installed' all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} --allow-newer --constraint 'setup.Cabal installed' all; fi + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + # Packaging... + - ${CABAL} v2-sdist all | color_cabal_output + # Unpacking... + - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; + - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: ./haddock-*" >> cabal.project + - | + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + # Building... + # this builds all libraries and executables (without tests/benchmarks) + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + # Building with tests and benchmarks... + # build & run tests, build benchmarks + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # Testing... + - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # Building without installed constraints for packages in global-db... + - rm -f cabal.project.local + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output +# REGENDATA ["haddock.cabal","--output",".travis.yml"] # EOF diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 9a120f5d..f8558dca 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -166,11 +166,11 @@ test-suite spec Haddock.Backends.Hyperlinker.Types build-depends: ghc ^>= 8.8 - , ghc-paths ^>= 0.1.0.9 + , ghc-paths ^>= 0.1.0.12 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 - , hspec >= 2.4.4 && < 2.7 - , QuickCheck >= 2.11 && < 2.13 + , hspec >= 2.4.4 && < 2.8 + , QuickCheck >= 2.11 && < 2.14 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version @@ -186,7 +186,7 @@ test-suite spec , transformers build-tool-depends: - hspec-discover:hspec-discover >= 2.4.4 && < 2.7 + hspec-discover:hspec-discover >= 2.4.4 && < 2.8 source-repository head type: git diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 99773475..fe6aeede 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -19,6 +19,8 @@ bug-reports: https://github.com/haskell/haddock/issues category: Documentation extra-source-files: CHANGES.md + fixtures/examples/*.input + fixtures/examples/*.parsed common lib-defaults default-language: Haskell2010 @@ -74,8 +76,8 @@ test-suite spec Documentation.Haddock.Parser.Identifier build-depends: - , base-compat ^>= 0.9.3 || ^>= 0.10.0 - , QuickCheck ^>= 2.11 || ^>= 2.12 + , base-compat ^>= 0.9.3 || ^>= 0.11.0 + , QuickCheck ^>= 2.11 || ^>= 2.13.2 , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 -- NB: build-depends & build-tool-depends have independent @@ -83,10 +85,10 @@ test-suite spec -- version of `hspec` & `hspec-discover` to ensure -- intercompatibility build-depends: - , hspec >= 2.4.4 && < 2.7 + , hspec >= 2.4.4 && < 2.8 build-tool-depends: - , hspec-discover:hspec-discover >= 2.4.4 && < 2.7 + , hspec-discover:hspec-discover >= 2.4.4 && < 2.8 test-suite fixtures type: exitcode-stdio-1.0 @@ -101,11 +103,11 @@ test-suite fixtures , base -- extra dependencies - , base-compat >= 0.9.3 && < 0.11 + , base-compat ^>= 0.9.3 || ^>= 0.11.0 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 - , optparse-applicative ^>= 0.14.0.0 - , tree-diff ^>= 0.0.0.1 + , optparse-applicative ^>= 0.15 + , tree-diff ^>= 0.1 source-repository head type: git diff --git a/haddock.cabal b/haddock.cabal index 563955b9..0173fd84 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.0 +cabal-version: 2.4 name: haddock version: 2.23.0 synopsis: A documentation-generation tool for Haskell libraries @@ -24,7 +24,7 @@ description: from your source code. . <> -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Simon Marlow, David Waern maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk @@ -47,9 +47,10 @@ extra-source-files: html-test/ref/*.html hypsrc-test/src/*.hs hypsrc-test/ref/src/*.html - latex-test/src/Simple/*.hs - latex-test/ref/Simple/*.tex - latex-test/ref/Simple/*.sty + latex-test/src/**/*.hs + latex-test/ref/**/*.tex + hoogle-test/src/**/*.hs + hoogle-test/ref/**/*.txt flag in-ghc-tree description: Are we in a GHC tree? @@ -62,7 +63,7 @@ executable haddock hs-source-dirs: driver ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded - -- haddock typically only supports a single GHC major version + -- haddock typically only supports a single GHC major version build-depends: base ^>= 4.13.0.0 -- cgit v1.2.3 From 9bbcd3859c9ea08b75e6964490e75236f4a73454 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Mon, 30 Sep 2019 20:12:42 -0500 Subject: Fix the ignore-exports option (#1082) The `ignore-exports` option has been broken since #688, as mentioned in https://github.com/haskell/haddock/pull/766#issue-172505043. This PR fixes it. --- haddock-api/src/Haddock/Interface/Create.hs | 9 ++--- html-test/Main.hs | 6 ---- html-test/ref/IgnoreExports.html | 54 +++++++++++++++++++++++++---- html-test/src/IgnoreExports.hs | 5 ++- 4 files changed, 56 insertions(+), 18 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 463411b4..dd1d4eb3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -83,8 +83,9 @@ createInterface tm flags modMap instIfaceMap = do (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_exports = all_exports + , tcg_exports = all_exports0 }, md) = tm_internals_ tm + all_local_avails = gresToAvailInfo . filter isLocalGRE . globalRdrEnvElts $ gre -- The 'pkgName' is necessary to decide what package to mention in "@since" -- annotations. Not having it is not fatal though. @@ -111,9 +112,9 @@ createInterface tm flags modMap instIfaceMap = do let declsWithDocs = topDecls group_ exports0 = fmap (map (first unLoc)) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 + (all_exports, exports) + | OptIgnoreExports `elem` opts = (all_local_avails, Nothing) + | otherwise = (all_exports0, exports0) unrestrictedImportedMods -- module re-exports are only possible with diff --git a/html-test/Main.hs b/html-test/Main.hs index 26eefe4a..36e56d9a 100755 --- a/html-test/Main.hs +++ b/html-test/Main.hs @@ -54,12 +54,6 @@ ingoredTests = -- we need a reliable way to deduplicate here. -- Happens since PR #688. "B" - - -- ignore-exports flag broke with PR #688. We use - -- the Avails calculated by GHC now. Probably - -- requires a change to GHC to "ignore" a modules - -- export list reliably. - , "IgnoreExports" ] checkIgnore :: FilePath -> Bool diff --git a/html-test/ref/IgnoreExports.html b/html-test/ref/IgnoreExports.html index eed12c00..8b3390ae 100644 --- a/html-test/ref/IgnoreExports.html +++ b/html-test/ref/IgnoreExports.html @@ -4,12 +4,14 @@ />IgnoreExportsSynopsis

      Documentation

      data Foo #

      documentation for Foo

      Constructors

      Bar

      Documentation for Bar

      foo :: :: Int #

      bar :: :: Int #

      +> \ No newline at end of file diff --git a/html-test/src/IgnoreExports.hs b/html-test/src/IgnoreExports.hs index 0321ad02..edb7c4c1 100644 --- a/html-test/src/IgnoreExports.hs +++ b/html-test/src/IgnoreExports.hs @@ -1,5 +1,8 @@ {-# OPTIONS_HADDOCK ignore-exports #-} -module IgnoreExports (foo) where +module IgnoreExports (Foo, foo) where + +-- | documentation for Foo +data Foo = Bar -- ^ Documentation for Bar -- | documentation for foo foo :: Int -- cgit v1.2.3 From 63c7e87de4fa94cea9eb1b253054a316d3d75e1c Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 28 Sep 2019 12:09:24 +0530 Subject: Fix crash when there are no srcspans in the file due to CPP --- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 19 +++++++++++-------- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 412d8391..1b49fba3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -432,7 +432,7 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} - ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces + ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return () diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 7571db9e..3acd91be 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -7,7 +7,7 @@ module Haddock.Backends.Hyperlinker import Haddock.Types -import Haddock.Utils (writeUtf8File) +import Haddock.Utils (writeUtf8File, out, verbose, Verbosity) import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types @@ -32,27 +32,28 @@ import UniqSupply ( mkSplitUniqSupply ) -- Note that list of interfaces should also contain interfaces normally hidden -- when generating documentation. Otherwise this could lead to dead links in -- produced source. -ppHyperlinkedSource :: FilePath -- ^ Output directory +ppHyperlinkedSource :: Verbosity + -> FilePath -- ^ Output directory -> FilePath -- ^ Resource directory -> Maybe FilePath -- ^ Custom CSS file path -> Bool -- ^ Flag indicating whether to pretty-print HTML -> M.Map Module SrcPath -- ^ Paths to sources -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pretty srcs' ifaces = do +ppHyperlinkedSource verbosity outdir libdir mstyle pretty srcs' ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir srcCssFile copyFile (libdir "html" highlightScript) $ srcdir highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces + mapM_ (ppHyperlinkedModuleSource verbosity srcdir pretty srcs) ifaces where srcdir = outdir hypSrcDir srcs = (srcs', M.mapKeys moduleName srcs') -- | Generate hyperlinked source for particular interface. -ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMaps -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of +ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interface -> IO () +ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of Just hfp -> do -- Parse the GHC-produced HIE file u <- mkSplitUniqSupply 'a' @@ -75,8 +76,10 @@ ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceHieFile iface of in writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing | M.size asts == 0 -> return () - | otherwise -> error $ unwords [ "couldn't find ast for" - , file, show (M.keys asts) ] + | otherwise -> do + out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + return () Nothing -> return () where df = ifaceDynFlags iface -- cgit v1.2.3 From 5459ca8a76825da59ff4c1c11d74812d1931da50 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Oct 2019 15:11:22 -0400 Subject: Prefer un-hyperlinked sources to no sources It is possible to fail to extract an HIE ast. This is however not a reason to produce _no_ output - we should still make a colorized HTML page. --- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 38 ++++++++++++++-------- .../src/Haddock/Backends/Hyperlinker/Utils.hs | 2 +- 2 files changed, 26 insertions(+), 14 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 3acd91be..2e665204 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -18,12 +18,13 @@ import Data.Maybe import System.Directory import System.FilePath -import HieTypes ( HieFile(..), HieASTs(..) ) +import HieTypes ( HieFile(..), HieASTs(..), HieAST(..), NodeInfo(..) ) import HieBin ( readHieFile, hie_file_result) import Data.Map as M import FastString ( mkFastString ) import Module ( Module, moduleName ) import NameCache ( initNameCache ) +import SrcLoc ( mkRealSrcLoc, realSrcLocSpan ) import UniqSupply ( mkSplitUniqSupply ) @@ -65,27 +66,38 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile <$> (readHieFile (initNameCache u []) hfp) -- Get the AST and tokens corresponding to the source file we want - let mast | M.size asts == 1 = snd <$> M.lookupMin asts - | otherwise = M.lookup (mkFastString file) asts + let fileFs = mkFastString file + mast | M.size asts == 1 = snd <$> M.lookupMin asts + | otherwise = M.lookup fileFs asts + ast = fromMaybe (emptyHieAst fileFs) mast + fullAst = recoverFullIfaceTypes df types ast tokens = parse df file rawSrc + -- Warn if we didn't find an AST, but there were still ASTs + if M.null asts + then pure () + else out verbosity verbose $ unwords [ "couldn't find ast for" + , file, show (M.keys asts) ] + -- Produce and write out the hyperlinked sources - case mast of - Just ast -> - let fullAst = recoverFullIfaceTypes df types ast - in writeUtf8File path . renderToString pretty . render' fullAst $ tokens - Nothing - | M.size asts == 0 -> return () - | otherwise -> do - out verbosity verbose $ unwords [ "couldn't find ast for" - , file, show (M.keys asts) ] - return () + writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing -> return () where df = ifaceDynFlags iface render' = render (Just srcCssFile) (Just highlightScript) srcs path = srcdir hypSrcModuleFile (ifaceMod iface) + emptyNodeInfo = NodeInfo + { nodeAnnotations = mempty + , nodeType = [] + , nodeIdentifiers = mempty + } + emptyHieAst fileFs = Node + { nodeInfo = emptyNodeInfo + , nodeSpan = realSrcLocSpan (mkRealSrcLoc fileFs 1 0) + , nodeChildren = [] + } + -- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs index 4e8b88d2..2c48e00b 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs @@ -102,7 +102,7 @@ type PrintedType = String -- > hieAst -- -- However, this is very inefficient (both in time and space) because the --- mutliple calls to 'recoverFullType' don't share intermediate results. This +-- multiple calls to 'recoverFullType' don't share intermediate results. This -- function fixes that. recoverFullIfaceTypes :: DynFlags -- cgit v1.2.3 From 80b8a8a2525d4e4c60b7c9439a23ac47d9612802 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Oct 2019 15:13:52 -0400 Subject: Add a regression test for #1091 Previously, this input would crash Haddock. --- haddock.cabal | 1 + hypsrc-test/ref/src/Bug1091.html | 34 ++++++++++++++++++++++++++++++++++ hypsrc-test/src/Bug1091.hs | 4 ++++ hypsrc-test/src/Include1For1091.h | 6 ++++++ hypsrc-test/src/Include2For1091.h | 4 ++++ 5 files changed, 49 insertions(+) create mode 100644 hypsrc-test/ref/src/Bug1091.html create mode 100644 hypsrc-test/src/Bug1091.hs create mode 100644 hypsrc-test/src/Include1For1091.h create mode 100644 hypsrc-test/src/Include2For1091.h diff --git a/haddock.cabal b/haddock.cabal index 0173fd84..fa87e07e 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -46,6 +46,7 @@ extra-source-files: html-test/src/*.hs html-test/ref/*.html hypsrc-test/src/*.hs + hypsrc-test/src/*.h hypsrc-test/ref/src/*.html latex-test/src/**/*.hs latex-test/ref/**/*.tex diff --git a/hypsrc-test/ref/src/Bug1091.html b/hypsrc-test/ref/src/Bug1091.html new file mode 100644 index 00000000..730b6e25 --- /dev/null +++ b/hypsrc-test/ref/src/Bug1091.html @@ -0,0 +1,34 @@ +
      {-# LANGUAGE CPP #-}
+module Bug1091 where
+
+#include "Include1For1091.h"
+
      \ No newline at end of file diff --git a/hypsrc-test/src/Bug1091.hs b/hypsrc-test/src/Bug1091.hs new file mode 100644 index 00000000..f0cea033 --- /dev/null +++ b/hypsrc-test/src/Bug1091.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +module Bug1091 where + +#include "Include1For1091.h" diff --git a/hypsrc-test/src/Include1For1091.h b/hypsrc-test/src/Include1For1091.h new file mode 100644 index 00000000..32854b95 --- /dev/null +++ b/hypsrc-test/src/Include1For1091.h @@ -0,0 +1,6 @@ +/* Include1For1091.h */ + +foo :: Int +foo = 42 + +#include "Include2For1091.h" diff --git a/hypsrc-test/src/Include2For1091.h b/hypsrc-test/src/Include2For1091.h new file mode 100644 index 00000000..c0848fa9 --- /dev/null +++ b/hypsrc-test/src/Include2For1091.h @@ -0,0 +1,4 @@ +/* Include2For1091.h */ + +bar :: Int +bar = 27 -- cgit v1.2.3 From cdf4445a877428f5969f712a95830af38029b9a0 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 7 Oct 2019 20:45:40 -0400 Subject: Add Hyperlinker test cases for TH-related stuff Hopefully this will guard against regressions around quasiquotes, TH quotes, and TH splices. --- hypsrc-test/ref/src/CallingQuotes.html | 104 ++++ hypsrc-test/ref/src/Quasiquoter.html | 415 +++++++++++++ .../ref/src/TemplateHaskellQuasiquotes.html | 659 +++++++++++++++++++++ hypsrc-test/ref/src/TemplateHaskellSplices.html | 135 +++++ hypsrc-test/ref/src/UsingQuasiquotes.html | 104 ++++ hypsrc-test/src/Quasiquoter.hs | 16 + hypsrc-test/src/TemplateHaskellQuasiquotes.hs | 39 ++ hypsrc-test/src/TemplateHaskellSplices.hs | 8 + hypsrc-test/src/UsingQuasiquotes.hs | 9 + 9 files changed, 1489 insertions(+) create mode 100644 hypsrc-test/ref/src/CallingQuotes.html create mode 100644 hypsrc-test/ref/src/Quasiquoter.html create mode 100644 hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html create mode 100644 hypsrc-test/ref/src/TemplateHaskellSplices.html create mode 100644 hypsrc-test/ref/src/UsingQuasiquotes.html create mode 100644 hypsrc-test/src/Quasiquoter.hs create mode 100644 hypsrc-test/src/TemplateHaskellQuasiquotes.hs create mode 100644 hypsrc-test/src/TemplateHaskellSplices.hs create mode 100644 hypsrc-test/src/UsingQuasiquotes.hs diff --git a/hypsrc-test/ref/src/CallingQuotes.html b/hypsrc-test/ref/src/CallingQuotes.html new file mode 100644 index 00000000..9b2e3209 --- /dev/null +++ b/hypsrc-test/ref/src/CallingQuotes.html @@ -0,0 +1,104 @@ +
      {-# LANGUAGE QuasiQuotes #-}
+module CallingQuotes where
+
+import Quasiquoter
+
+baz :: [Char]
+baz  = [string| foo bar |] [Char] -> [Char] -> [Char]
+forall a. [a] -> [a] -> [a]
+++ [string| some
+  mulitline
+  quasiquote
+|]
+
      \ No newline at end of file diff --git a/hypsrc-test/ref/src/Quasiquoter.html b/hypsrc-test/ref/src/Quasiquoter.html new file mode 100644 index 00000000..ab631e8c --- /dev/null +++ b/hypsrc-test/ref/src/Quasiquoter.html @@ -0,0 +1,415 @@ +
      module Quasiquoter ( string ) where
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+
+-- | Quoter for constructing multiline string literals
+string :: QuasiQuoter
+string :: QuasiQuoter
+string = QuasiQuoter :: (String -> Q Exp)
+-> (String -> Q Pat)
+-> (String -> Q Type)
+-> (String -> Q [Dec])
+-> QuasiQuoter
+QuasiQuoter
+  { quoteExp :: String -> Q Exp
+quoteExp = Exp -> Q Exp
+forall (f :: * -> *) a. Applicative f => a -> f a
+pure (Exp -> Q Exp) -> (String -> Exp) -> String -> Q Exp
+forall b c a. (b -> c) -> (a -> b) -> a -> c
+. Lit -> Exp
+LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
+forall b c a. (b -> c) -> (a -> b) -> a -> c
+. String -> Lit
+StringL
+  , quotePat :: String -> Q Pat
+quotePat = String -> Q Pat
+forall a. String -> Q a
+invalidDomain
+  , quoteType :: String -> Q Type
+quoteType = String -> Q Type
+forall a. String -> Q a
+invalidDomain
+  , quoteDec :: String -> Q [Dec]
+quoteDec = String -> Q [Dec]
+forall a. String -> Q a
+invalidDomain
+  }
+  where
+    invalidDomain :: String -> Q a
+    invalidDomain :: String -> Q a
+invalidDomain _ = String -> Q a
+forall (m :: * -> *) a. MonadFail m => String -> m a
+fail "stringQuoter: only valid in expression context"
+
      \ No newline at end of file diff --git a/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html b/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html new file mode 100644 index 00000000..6552b676 --- /dev/null +++ b/hypsrc-test/ref/src/TemplateHaskellQuasiquotes.html @@ -0,0 +1,659 @@ +
      {-# LANGUAGE TemplateHaskell #-}
+
+module TemplateHaskellQuasiquotes where
+
+import Language.Haskell.TH
+
+aDecl :: DecsQ
+aDecl :: DecsQ
+aDecl = [d|
+    bar :: $aType -> [ (Int, String) ]
+    bar $aPattern = $anExpression
+  |]
+
+aPattern :: PatQ
+aPattern :: PatQ
+aPattern = [p|
+    [ aCrazyLongVariableName
+    , _unused
+    , (y, z)
+    , ( $aNumberPattern, "hello")
+    ]
+  |]
+
+aNumberPattern :: PatQ
+aNumberPattern :: PatQ
+aNumberPattern = [p|
+    w @ v @ 4.5
+  |]
+
+anExpression, anExpression2 :: ExpQ
+anExpression :: ExpQ
+anExpression = [e|
+    [ (1 + $anExpression2, "world") ]
+  |]
+anExpression2 :: ExpQ
+anExpression2 = [| (1 + round pi) |]
+
+aType :: TypeQ
+aType :: TypeQ
+aType = [t|
+    [ (Double, String) ]
+  |]
+
+
+
+
      \ No newline at end of file diff --git a/hypsrc-test/ref/src/TemplateHaskellSplices.html b/hypsrc-test/ref/src/TemplateHaskellSplices.html new file mode 100644 index 00000000..85288453 --- /dev/null +++ b/hypsrc-test/ref/src/TemplateHaskellSplices.html @@ -0,0 +1,135 @@ +
      {-# LANGUAGE TemplateHaskell #-}
+module TemplateHaskellSplices where
+
+import TemplateHaskellQuasiquotes
+
+$([(Double, String)] -> [(Int, String)]
+aDecl)
+
+foo :: Integer
+foo = Integer -> Integer
+forall a. a -> a
+id $(Double
+Double -> Integer
+Integer -> Integer -> Integer
+forall a. Floating a => a
+forall a. Num a => a -> a -> a
+forall a b. (RealFrac a, Integral b) => a -> b
++ :: forall a. Num a => a -> a -> a
+round :: forall a b. (RealFrac a, Integral b) => a -> b
+pi :: forall a. Floating a => a
+anExpression2)
+
      \ No newline at end of file diff --git a/hypsrc-test/ref/src/UsingQuasiquotes.html b/hypsrc-test/ref/src/UsingQuasiquotes.html new file mode 100644 index 00000000..a5c791c4 --- /dev/null +++ b/hypsrc-test/ref/src/UsingQuasiquotes.html @@ -0,0 +1,104 @@ +
      {-# LANGUAGE QuasiQuotes #-}
+module UsingQuasiquotes where
+
+import Quasiquoter
+
+baz :: [Char]
+baz  = [string| foo bar |] [Char] -> [Char] -> [Char]
+forall a. [a] -> [a] -> [a]
+++ [string| some
+  mulitline
+  quasiquote
+|]
+
      \ No newline at end of file diff --git a/hypsrc-test/src/Quasiquoter.hs b/hypsrc-test/src/Quasiquoter.hs new file mode 100644 index 00000000..d0a46c33 --- /dev/null +++ b/hypsrc-test/src/Quasiquoter.hs @@ -0,0 +1,16 @@ +module Quasiquoter ( string ) where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax + +-- | Quoter for constructing multiline string literals +string :: QuasiQuoter +string = QuasiQuoter + { quoteExp = pure . LitE . StringL + , quotePat = invalidDomain + , quoteType = invalidDomain + , quoteDec = invalidDomain + } + where + invalidDomain :: String -> Q a + invalidDomain _ = fail "stringQuoter: only valid in expression context" diff --git a/hypsrc-test/src/TemplateHaskellQuasiquotes.hs b/hypsrc-test/src/TemplateHaskellQuasiquotes.hs new file mode 100644 index 00000000..a1661895 --- /dev/null +++ b/hypsrc-test/src/TemplateHaskellQuasiquotes.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TemplateHaskellQuasiquotes where + +import Language.Haskell.TH + +aDecl :: DecsQ +aDecl = [d| + bar :: $aType -> [ (Int, String) ] + bar $aPattern = $anExpression + |] + +aPattern :: PatQ +aPattern = [p| + [ aCrazyLongVariableName + , _unused + , (y, z) + , ( $aNumberPattern, "hello") + ] + |] + +aNumberPattern :: PatQ +aNumberPattern = [p| + w @ v @ 4.5 + |] + +anExpression, anExpression2 :: ExpQ +anExpression = [e| + [ (1 + $anExpression2, "world") ] + |] +anExpression2 = [| (1 + round pi) |] + +aType :: TypeQ +aType = [t| + [ (Double, String) ] + |] + + + diff --git a/hypsrc-test/src/TemplateHaskellSplices.hs b/hypsrc-test/src/TemplateHaskellSplices.hs new file mode 100644 index 00000000..bbd3948e --- /dev/null +++ b/hypsrc-test/src/TemplateHaskellSplices.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module TemplateHaskellSplices where + +import TemplateHaskellQuasiquotes + +$(aDecl) + +foo = id $(anExpression2) diff --git a/hypsrc-test/src/UsingQuasiquotes.hs b/hypsrc-test/src/UsingQuasiquotes.hs new file mode 100644 index 00000000..34872d4d --- /dev/null +++ b/hypsrc-test/src/UsingQuasiquotes.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE QuasiQuotes #-} +module UsingQuasiquotes where + +import Quasiquoter + +baz = [string| foo bar |] ++ [string| some + mulitline + quasiquote +|] -- cgit v1.2.3 From 2a5fc0ad50c857098558461434c29abd478ea0a1 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 23 Oct 2019 09:42:20 -0400 Subject: Reify oversaturated data family instances correctly (#1103) This fixes #1103 by adapting the corresponding patch for GHC (see https://gitlab.haskell.org/ghc/ghc/issues/17296 and https://gitlab.haskell.org/ghc/ghc/merge_requests/1877). --- haddock-api/src/Haddock/Convert.hs | 38 ++- html-test/ref/Bug1103.html | 556 +++++++++++++++++++++++++++++++++++++ html-test/src/Bug1103.hs | 24 ++ 3 files changed, 603 insertions(+), 15 deletions(-) create mode 100644 html-test/ref/Bug1103.html create mode 100644 html-test/src/Bug1103.hs diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d22efc9a..5dc3a508 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -150,8 +150,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args typats = map (synifyType WithinType []) args_types_only - annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) - args_types_only typats + annot_typats = zipWith3 annotHsType args_poly args_types_only typats hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt @@ -162,7 +161,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , feqn_fixity = synifyFixity name , feqn_rhs = hs_rhs } } where - fam_tvs = tyConVisibleTyVars tc + args_poly = tyConArgsPolyKinded tc synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) @@ -472,17 +471,26 @@ annotHsType True ty hs_ty in noLoc (HsKindSig noExt 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 +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs + ++ repeat True where - is_poly_tv tv = not $ + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ isEmptyVarSet $ filterVarSet isTyVar $ - tyCoVarsOfType $ - tyVarKind tv + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [TyCoBinder] + tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc --states of what to do with foralls: data SynifyTypeState @@ -787,8 +795,8 @@ synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types ts' = map (synifyType WithinType vs) ts - annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' - is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded cls_tycon synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family @@ -827,8 +835,8 @@ synifyFamInst fi opaque = do 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) + annot_ts = zipWith3 annotHsType args_poly ts ts' + args_poly = tyConArgsPolyKinded fam_tc {- Note [Invariant: Never expand type synonyms] diff --git a/html-test/ref/Bug1103.html b/html-test/ref/Bug1103.html new file mode 100644 index 00000000..cc16017b --- /dev/null +++ b/html-test/ref/Bug1103.html @@ -0,0 +1,556 @@ +Bug1103
      Safe HaskellSafe

      Bug1103

      Documentation

      data family Foo1 :: Type -> Type #

      Instances

      Instances details
      data Foo1 Bool #
      Instance details

      Defined in Bug1103

      data Foo1 Bool = Foo1Bool
      data Foo1 (Maybe a) #
      Instance details

      Defined in Bug1103

      data Foo1 (Maybe a)

      data family Foo2 :: k -> Type #

      Instances

      Instances details
      data Foo2 (a :: Char) #
      Instance details

      Defined in Bug1103

      data Foo2 (a :: Char)
      data Foo2 Bool #
      Instance details

      Defined in Bug1103

      data Foo2 Bool = Foo2Bool
      data Foo2 (Maybe a :: Type) #
      Instance details

      Defined in Bug1103

      data Foo2 (Maybe a :: Type)
      data Foo2 (a :: Char -> Char) #
      Instance details

      Defined in Bug1103

      data Foo2 (a :: Char -> Char)

      data family Foo3 :: k #

      Instances

      Instances details
      data Foo3 #
      Instance details

      Defined in Bug1103

      data Foo3
      data Foo3 (a :: Char) #
      Instance details

      Defined in Bug1103

      data Foo3 (a :: Char)
      data Foo3 (a :: Char -> Char) #
      Instance details

      Defined in Bug1103

      data Foo3 (a :: Char -> Char)
      data Foo3 Bool #
      Instance details

      Defined in Bug1103

      data Foo3 Bool = Foo3Bool
      data Foo3 (Maybe a :: Type) #
      Instance details

      Defined in Bug1103

      data Foo3 (Maybe a :: Type)
      \ No newline at end of file diff --git a/html-test/src/Bug1103.hs b/html-test/src/Bug1103.hs new file mode 100644 index 00000000..1f387e62 --- /dev/null +++ b/html-test/src/Bug1103.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module Bug1103 where + +import Data.Kind + +data family Foo1 :: Type -> Type +data instance Foo1 Bool = Foo1Bool +data instance Foo1 (Maybe a) + +data family Foo2 :: k -> Type +data instance Foo2 Bool = Foo2Bool +data instance Foo2 (Maybe a) +data instance Foo2 :: Char -> Type +data instance Foo2 :: (Char -> Char) -> Type where + +data family Foo3 :: k +data instance Foo3 +data instance Foo3 Bool = Foo3Bool +data instance Foo3 (Maybe a) +data instance Foo3 :: Char -> Type +data instance Foo3 :: (Char -> Char) -> Type where -- cgit v1.2.3 From b34ca2554a3440f092f585bb7fc1e9d4b2ca8616 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Thu, 17 Oct 2019 10:52:12 +0200 Subject: Define `XRec` for location information and get rid of `HasSrcSpan` In https://gitlab.haskell.org/ghc/ghc/merge_requests/1970 I propose a simpler way to encode location information into the GHC and Haddock AST while incurring no cost for e.g. TH which doesn't need location information. These are just changes that have to happen in lock step. --- haddock-api/src/Haddock/Types.hs | 19 +++---------------- 1 file changed, 3 insertions(+), 16 deletions(-) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c03ab385..b5659038 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -668,6 +668,8 @@ instance MonadIO ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- +type instance XRec DocNameI f = Located (f DocNameI) + type instance XForAllTy DocNameI = NoExtField type instance XQualTy DocNameI = NoExtField type instance XTyVar DocNameI = NoExtField @@ -748,19 +750,4 @@ type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField type instance XXConDeclField DocNameI = NoExtCon -type instance XXPat DocNameI = Located (Pat DocNameI) - -type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI -instance HasSrcSpan (LPat DocNameI) where - -- NB: The following chooses the behaviour of the outer location - -- wrapper replacing the inner ones. - composeSrcSpan (L sp p) = if sp == noSrcSpan - then p - else XPat (L sp (stripSrcSpanPat p)) - -- NB: The following only returns the top-level location, if any. - decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) - decomposeSrcSpan p = L noSrcSpan p - -stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI -stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p -stripSrcSpanPat p = p +type instance XXPat DocNameI = NoExtCon -- cgit v1.2.3 From e6ca100973c496cd98da3385594fa9a81320f7cb Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Wed, 30 Jan 2019 20:17:29 -0500 Subject: Changes from #14579 We now have a top-level `tyConAppNeedsKindSig` function, which means that we can delete lots of code in `Convert`. (cherry picked from commit cfd682c5fd03b099a3d78c44f9279faf56a0ac70) --- haddock-api/src/Haddock/Convert.hs | 27 +++++---------------------- 1 file changed, 5 insertions(+), 22 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5dc3a508..709e20d4 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -28,7 +28,6 @@ import ConLike import Data.Either (lefts, rights) import DataCon import FamInstEnv -import FV import HsSyn import Name import NameSet ( emptyNameSet ) @@ -45,8 +44,7 @@ import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import Unique ( getUnique ) -import Util ( chkAppend, compareLength, dropList, filterByList, filterOut - , splitAtList ) +import Util ( chkAppend,dropList, filterByList, filterOut, splitAtList ) import Var import VarSet @@ -547,7 +545,7 @@ synifyType _ vs (TyConApp tc tys) = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys + , tyConArity tc == tys_len = noLoc $ HsTupleTy noExt (case sort of BoxedTuple -> HsBoxedTuple @@ -604,32 +602,17 @@ synifyType _ vs (TyConApp tc tys) (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) - vis_tys = filterOutInvisibleTypes tc tys - binders = tyConBinders tc - res_kind = tyConResKind tc + tys_len = length tys + vis_tys = filterOutInvisibleTypes tc tys maybe_sig :: LHsType GhcRn -> LHsType GhcRn maybe_sig ty' - | needs_kind_sig + | tyConAppNeedsKindSig False tc tys_len = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt 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 vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 synifyType _ vs (AppTy t1 t2) = let s1 = synifyType WithinType vs t1 -- cgit v1.2.3 From 70f4b3a03a47b38ee301f0da9c72d5a7ff0ed9b0 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sun, 10 Nov 2019 12:47:06 -0500 Subject: Bump to GHC 8.10 --- haddock-api/haddock-api.cabal | 2 +- haddock.cabal | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 99140231..aac3dfd8 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -44,7 +44,7 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.12.0 , Cabal ^>= 2.4.0 - , ghc ^>= 8.9 + , ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 diff --git a/haddock.cabal b/haddock.cabal index d8b6f448..0ed722f4 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -64,8 +64,7 @@ executable haddock -- haddock typically only supports a single GHC major version build-depends: - -- FIXME: drop 4.12.0.0 once GHC HEAD updates to 4.13.0.0 - base ^>= 4.12.0.0 || ^>= 4.13.0.0 + base ^>= 4.13.0.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src @@ -80,7 +79,7 @@ executable haddock Cabal >= 1.10, ghc-boot, ghc-boot-th, - ghc == 8.9.*, + ghc == 8.10.*, bytestring, parsec, text, -- cgit v1.2.3 From ee05ff1ecde866e31f72e3fa4f773dca98944dc3 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 8 Dec 2019 11:47:58 +0100 Subject: Document error-prone conditional definition of instances This can easily trip up people if one isn't aware of it. Usually it's better to avoid this kind of conditionality especially for typeclasses for which there's an compat-package as conditional instances like these tend to fragment the ecosystem into those packages that go the extra mile to provide backward compat via those compat-packages and those that fail to do so. --- haddock-library/src/Documentation/Haddock/Types.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index ba2f873c..4cf61fee 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -44,14 +44,17 @@ data MetaDoc mod id = } deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0) +-- | __NOTE__: Only defined for @base >= 4.8.0@ instance Bifunctor MetaDoc where bimap f g (MetaDoc m d) = MetaDoc m (bimap f g d) #endif #if MIN_VERSION_base(4,10,0) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bifoldable MetaDoc where bifoldr f g z d = bifoldr f g z (_doc d) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bitraversable MetaDoc where bitraverse f g (MetaDoc m d) = MetaDoc m <$> bitraverse f g d #endif @@ -131,6 +134,7 @@ data DocH mod id deriving (Eq, Show, Functor, Foldable, Traversable) #if MIN_VERSION_base(4,8,0) +-- | __NOTE__: Only defined for @base >= 4.8.0@ instance Bifunctor DocH where bimap _ _ DocEmpty = DocEmpty bimap f g (DocAppend docA docB) = DocAppend (bimap f g docA) (bimap f g docB) @@ -159,6 +163,7 @@ instance Bifunctor DocH where #endif #if MIN_VERSION_base(4,10,0) +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bifoldable DocH where bifoldr f g z (DocAppend docA docB) = bifoldr f g (bifoldr f g z docA) docB bifoldr f g z (DocParagraph doc) = bifoldr f g z doc @@ -176,6 +181,7 @@ instance Bifoldable DocH where bifoldr f g z (DocTable (Table header body)) = foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) (foldr (\r acc -> foldr (flip (bifoldr f g)) acc r) z body) header bifoldr _ _ z _ = z +-- | __NOTE__: Only defined for @base >= 4.10.0@ instance Bitraversable DocH where bitraverse _ _ DocEmpty = pure DocEmpty bitraverse f g (DocAppend docA docB) = DocAppend <$> bitraverse f g docA <*> bitraverse f g docB -- cgit v1.2.3 From be8b02c4e3cffe7d45b3dad0a0f071d35a274d65 Mon Sep 17 00:00:00 2001 From: Herbert Valerio Riedel Date: Sun, 8 Dec 2019 11:53:39 +0100 Subject: Fix build-failure regression for base < 4.7 The `$>` operator definition is available only since base-4.7 which unfortunately wasn't caught before release to Hackage (but has been fixed up by a metadata-revision) This commit introduces a `CompatPrelude` module which allows to reduce the amount of CPP by ousting it to a central location, i.e. the new `CompatPrelude` module. This pattern also tends to reduce the tricks needed to silence unused import warnings. Addresses #1119 --- haddock-library/CHANGES.md | 4 ++ haddock-library/haddock-library.cabal | 3 +- haddock-library/src/CompatPrelude.hs | 52 ++++++++++++++++++++++ .../src/Documentation/Haddock/Parser.hs | 1 - .../src/Documentation/Haddock/Parser/Identifier.hs | 28 +----------- .../src/Documentation/Haddock/Parser/Monad.hs | 3 +- 6 files changed, 61 insertions(+), 30 deletions(-) create mode 100644 haddock-library/src/CompatPrelude.hs diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index 265579ca..d112db45 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,7 @@ +## Changes in version 1.8.0.1 + + * Fix build-time regression for `base < 4.7` (#1119) + ## Changes in version 1.8.0 * Support inline markup in markdown-style links (#875) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index fe6aeede..7f91fd19 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: haddock-library -version: 1.8.0 +version: 1.8.0.1 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell @@ -49,6 +49,7 @@ library Documentation.Haddock.Types other-modules: + CompatPrelude Documentation.Haddock.Parser.Util Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Identifier diff --git a/haddock-library/src/CompatPrelude.hs b/haddock-library/src/CompatPrelude.hs new file mode 100644 index 00000000..60fa94d9 --- /dev/null +++ b/haddock-library/src/CompatPrelude.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +#if !MIN_VERSION_base(4,5,0) +# error This module doesn't provide compat-shims for versions prior to base-4.5 +#endif + +-- | Bridge impedance mismatch of different @base@ versions back till @base-4.5@ (GHC 7.4.2) +module CompatPrelude + ( ($>) + , isSymbolChar + ) where + +#if MIN_VERSION_base(4,7,0) +import Data.Functor ( ($>) ) +#else +import Data.Functor ( (<$) ) +#endif + +#if MIN_VERSION_base(4,9,0) +import Text.Read.Lex (isSymbolChar) +#else +import Data.Char (GeneralCategory(..), generalCategory) +#endif + + +#if !MIN_VERSION_base(4,7,0) +infixl 4 $> + +-- | Flipped version of '<$'. +-- +-- @since 4.7.0.0 +($>) :: Functor f => f a -> b -> f b +($>) = flip (<$) +#endif + +#if !MIN_VERSION_base(4,9,0) +-- inlined from base-4.10.0.0 +isSymbolChar :: Char -> Bool +isSymbolChar c = not (isPuncChar c) && case generalCategory c of + MathSymbol -> True + CurrencySymbol -> True + ModifierSymbol -> True + OtherSymbol -> True + DashPunctuation -> True + OtherPunctuation -> c `notElem` "'\"" + ConnectorPunctuation -> c /= '_' + _ -> False + where + -- | The @special@ character class as defined in the Haskell Report. + isPuncChar :: Char -> Bool + isPuncChar = (`elem` (",;()[]{}`" :: String)) +#endif diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 36c8bb5b..028422a7 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | diff --git a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs index a83e5abf..b8afb951 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Identifier.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} -- | @@ -29,15 +28,8 @@ import qualified Data.Text as T import Data.Char (isAlpha, isAlphaNum) import Control.Monad (guard) -import Data.Functor (($>)) -#if MIN_VERSION_base(4,9,0) -import Text.Read.Lex (isSymbolChar) -#else -import Data.Char (GeneralCategory (..), - generalCategory) -#endif - import Data.Maybe +import CompatPrelude -- | Identifier string surrounded with namespace, opening, and closing quotes/backticks. data Identifier = Identifier !Namespace !Char String !Char @@ -57,24 +49,6 @@ parseValid = do in setParserState s' $> Identifier ns op (T.unpack ident) cl -#if !MIN_VERSION_base(4,9,0) --- inlined from base-4.10.0.0 -isSymbolChar :: Char -> Bool -isSymbolChar c = not (isPuncChar c) && case generalCategory c of - MathSymbol -> True - CurrencySymbol -> True - ModifierSymbol -> True - OtherSymbol -> True - DashPunctuation -> True - OtherPunctuation -> c `notElem` "'\"" - ConnectorPunctuation -> c /= '_' - _ -> False - where - -- | The @special@ character class as defined in the Haskell Report. - isPuncChar :: Char -> Bool - isPuncChar = (`elem` (",;()[]{}`" :: String)) -#endif - -- | Try to parse a delimited identifier off the front of the given input. -- -- This tries to match as many valid Haskell identifiers/operators as possible, diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index fa46f536..7c73a168 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -29,7 +29,6 @@ import qualified Data.Text as T import Data.Text ( Text ) import Control.Monad ( mfilter ) -import Data.Functor ( ($>) ) import Data.String ( IsString(..) ) import Data.Bits ( Bits(..) ) import Data.Char ( ord ) @@ -37,7 +36,9 @@ import Data.List ( foldl' ) import Control.Applicative as App import Documentation.Haddock.Types ( Version ) + import Prelude hiding (takeWhile) +import CompatPrelude -- | The only bit of information we really care about truding along with us -- through parsing is the version attached to a @\@since@ annotation - if -- cgit v1.2.3 From 9a737d67d97ec4310b1ae89de640093c9d89e372 Mon Sep 17 00:00:00 2001 From: Kleidukos Date: Thu, 19 Mar 2020 16:02:31 +0100 Subject: Replace the 'caption' class so that the collapsible sections are shown --- haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 1901cf05..edab4b16 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -182,7 +182,7 @@ hackMarkup fmt' currPkg h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - col' = collapseControl id_ "caption" + col' = collapseControl id_ "subheading" summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] -- cgit v1.2.3 From b54a182873bdf5ac635872a28d8e9892846ab322 Mon Sep 17 00:00:00 2001 From: Kleidukos Date: Thu, 19 Mar 2020 16:55:28 +0100 Subject: Force ghc-8.8.3 --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 896087ba..9215057a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -26,8 +26,8 @@ before_cache: - rm -rfv $CABALHOME/packages/head.hackage matrix: include: - - compiler: ghc-8.8.1 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} + - compiler: ghc-8.8.3 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.3","cabal-install-3.0"]}} before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" -- cgit v1.2.3 From dae8d9de6aaf3913a3776f1af235fb72404e9970 Mon Sep 17 00:00:00 2001 From: Kleidukos Date: Thu, 19 Mar 2020 17:12:59 +0100 Subject: Update test fixtures --- html-test/ref/Bug335.html | 6 +++--- html-test/ref/Bug953.html | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/html-test/ref/Bug335.html b/html-test/ref/Bug335.html index 8a0e0843..9e16b3ef 100644 --- a/html-test/ref/Bug335.html +++ b/html-test/ref/Bug335.html @@ -69,7 +69,7 @@ >#

      ExF:

      #

      ExG:

      \ No newline at end of file +> diff --git a/html-test/ref/Bug953.html b/html-test/ref/Bug953.html index b49b1fb6..2a430db1 100644 --- a/html-test/ref/Bug953.html +++ b/html-test/ref/Bug953.html @@ -81,7 +81,7 @@ >

      A foo

      Examples

      A bar

      Examples

      \ No newline at end of file +> -- cgit v1.2.3 From dec888641006eb685a642ec489b198c61a5736dc Mon Sep 17 00:00:00 2001 From: Alina Banerjee Date: Thu, 1 Aug 2019 16:01:39 -0500 Subject: Update parsing to strip whitespace from table cells (#1074) * Update parsing to strip leading & trailing whitespace from table cells * Update fixture data to disallow whitespaces at both ends in table cells * Add test case for whitespaces stripped from both ends of table cells * Update table reference test data for html tests --- .../examples/table-cell-strip-whitespaces.input | 5 ++ .../examples/table-cell-strip-whitespaces.parsed | 29 +++++++ .../fixtures/examples/table-simple.parsed | 28 ++----- haddock-library/fixtures/examples/table1.parsed | 45 ++++------ haddock-library/fixtures/examples/table2.parsed | 20 ++--- haddock-library/fixtures/examples/table3.parsed | 22 ++--- haddock-library/fixtures/examples/table4.parsed | 10 +-- haddock-library/fixtures/examples/table5.parsed | 27 +++--- .../src/Documentation/Haddock/Parser.hs | 14 ++-- html-test/ref/Table.html | 96 +++++++++++----------- 10 files changed, 150 insertions(+), 146 deletions(-) create mode 100644 haddock-library/fixtures/examples/table-cell-strip-whitespaces.input create mode 100644 haddock-library/fixtures/examples/table-cell-strip-whitespaces.parsed diff --git a/haddock-library/fixtures/examples/table-cell-strip-whitespaces.input b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.input new file mode 100644 index 00000000..f5e3756d --- /dev/null +++ b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.input @@ -0,0 +1,5 @@ ++------+--------------+-------------------------------------------------+ +| C1 | C2 | C3 | ++======+==============+=================================================+ +| row | 'test' | 'test table cell with .. whitepspace ' | ++------+--------------+-------------------------------------------------+ diff --git a/haddock-library/fixtures/examples/table-cell-strip-whitespaces.parsed b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.parsed new file mode 100644 index 00000000..19002369 --- /dev/null +++ b/haddock-library/fixtures/examples/table-cell-strip-whitespaces.parsed @@ -0,0 +1,29 @@ +DocTable + Table + {tableBodyRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "row", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocIdentifier "test", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString + "'test table cell with .. whitepspace '", + tableCellRowspan = 1}]], + tableHeaderRows = [TableRow + [TableCell + {tableCellColspan = 1, + tableCellContents = DocString "C1", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "C2", + tableCellRowspan = 1}, + TableCell + {tableCellColspan = 1, + tableCellContents = DocString "C3", + tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table-simple.parsed b/haddock-library/fixtures/examples/table-simple.parsed index b5e62453..d027c75d 100644 --- a/haddock-library/fixtures/examples/table-simple.parsed +++ b/haddock-library/fixtures/examples/table-simple.parsed @@ -3,50 +3,40 @@ DocTable {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " 200 ", + tableCellContents = DocString "200", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocAppend - (DocString " ") - (DocAppend - (DocMonospaced (DocString "OK")) - (DocString " ")), + tableCellContents = DocMonospaced (DocString "OK"), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString - " operation successful ", + tableCellContents = DocString "operation successful", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " 204 ", + tableCellContents = DocString "204", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocAppend - (DocString " ") - (DocAppend - (DocMonospaced (DocString "No Content")) - (DocString " ")), + tableCellContents = DocMonospaced (DocString "No Content"), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString - " operation successful, no body returned ", + "operation successful, no body returned", tableCellRowspan = 1}]], tableHeaderRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " code ", + tableCellContents = DocString "code", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " message ", + tableCellContents = DocString "message", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString - " description ", + tableCellContents = DocString "description", tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table1.parsed b/haddock-library/fixtures/examples/table1.parsed index 2fa58fd8..8b8908f4 100644 --- a/haddock-library/fixtures/examples/table1.parsed +++ b/haddock-library/fixtures/examples/table1.parsed @@ -3,79 +3,66 @@ DocTable {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " body row 1, column 1 ", + tableCellContents = DocString "body row 1, column 1", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 2 ", + tableCellContents = DocString "column 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 3 ", + tableCellContents = DocString "column 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 4 ", + tableCellContents = DocString "column 4", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " body row 2 ", + tableCellContents = DocString "body row 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 3, - tableCellContents = DocString " Cells may span columns. ", + tableCellContents = DocString "Cells may span columns.", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " body row 3 ", + tableCellContents = DocString "body row 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, tableCellContents = DocString - (concat - [" Cells may \n", - " span rows. \n", - " "]), + (concat ["Cells may\n", "span rows.\n"]), tableCellRowspan = 2}, TableCell {tableCellColspan = 2, - tableCellContents = DocAppend - (DocString " ") - (DocAppend - (DocMathDisplay - (concat - [" \n", - " f(n) = \\sum_{i=1} \n", - " "])) - (DocString " ")), + tableCellContents = DocMathDisplay + (concat ["\n", "f(n) = \\sum_{i=1}\n"]), tableCellRowspan = 2}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " body row 4 ", + tableCellContents = DocString "body row 4", tableCellRowspan = 1}]], tableHeaderRows = [TableRow [TableCell {tableCellColspan = 1, tableCellContents = DocString (concat - [" Header row, column 1 \n", - " (header rows optional) "]), + ["Header row, column 1\n", + "(header rows optional)"]), tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString - (concat [" Header 2 \n", " "]), + tableCellContents = DocString "Header 2\n", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString - (concat [" Header 3 \n", " "]), + tableCellContents = DocString "Header 3\n", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString - (concat [" Header 4 \n", " "]), + tableCellContents = DocString "Header 4\n", tableCellRowspan = 1}]]} diff --git a/haddock-library/fixtures/examples/table2.parsed b/haddock-library/fixtures/examples/table2.parsed index e3dbf0b4..44cc813b 100644 --- a/haddock-library/fixtures/examples/table2.parsed +++ b/haddock-library/fixtures/examples/table2.parsed @@ -3,44 +3,44 @@ DocTable {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 1, col 1 ", + tableCellContents = DocString "row 1, col 1", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 2 ", + tableCellContents = DocString "column 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 3 ", + tableCellContents = DocString "column 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 4 ", + tableCellContents = DocString "column 4", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 2 ", + tableCellContents = DocString "row 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 3, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 3 ", + tableCellContents = DocString "row 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}]], tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table3.parsed b/haddock-library/fixtures/examples/table3.parsed index cabff9cb..c978b50f 100644 --- a/haddock-library/fixtures/examples/table3.parsed +++ b/haddock-library/fixtures/examples/table3.parsed @@ -3,48 +3,48 @@ DocTable {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 1, col 1 ", + tableCellContents = DocString "row 1, col 1", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 2 ", + tableCellContents = DocString "column 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 3 ", + tableCellContents = DocString "column 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 4 ", + tableCellContents = DocString "column 4", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 2 ", + tableCellContents = DocString "row 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 2, - tableCellContents = DocString " Use the command ``ls ", + tableCellContents = DocString "Use the command ``ls", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " more``. ", + tableCellContents = DocString "more``.", tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 3 ", + tableCellContents = DocString "row 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}]], tableHeaderRows = []} diff --git a/haddock-library/fixtures/examples/table4.parsed b/haddock-library/fixtures/examples/table4.parsed index cfdd6f0f..c4dabb0d 100644 --- a/haddock-library/fixtures/examples/table4.parsed +++ b/haddock-library/fixtures/examples/table4.parsed @@ -8,10 +8,10 @@ DocAppend {tableCellColspan = 1, tableCellContents = DocString (concat - [" outer \n", - " \n", - "-------+ \n", - " inner | "]), + ["outer\n", + "\n", + "-------+\n", + "inner |"]), tableCellRowspan = 1}]], tableHeaderRows = []}) (DocAppend @@ -21,6 +21,6 @@ DocAppend {tableBodyRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " inner ", + tableCellContents = DocString "inner", tableCellRowspan = 1}]], tableHeaderRows = []}))) diff --git a/haddock-library/fixtures/examples/table5.parsed b/haddock-library/fixtures/examples/table5.parsed index 9a547ad3..f9a387bb 100644 --- a/haddock-library/fixtures/examples/table5.parsed +++ b/haddock-library/fixtures/examples/table5.parsed @@ -4,50 +4,43 @@ DocTable [TableCell {tableCellColspan = 1, tableCellContents = DocString - (concat - [" row 2 \n", - " \n", - " \n", - " row 3 "]), + (concat ["row 2\n", "\n", "\n", "row 3"]), tableCellRowspan = 2}, TableCell {tableCellColspan = 3, tableCellContents = DocAppend - (DocString " Use the command ") + (DocString "Use the command ") (DocAppend (DocMonospaced (DocString "ls | more")) - (DocString - (concat - [". \n", - " "]))), + (DocString ".\n")), tableCellRowspan = 1}], TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " ", + tableCellContents = DocEmpty, tableCellRowspan = 1}]], tableHeaderRows = [TableRow [TableCell {tableCellColspan = 1, - tableCellContents = DocString " row 1, col 1 ", + tableCellContents = DocString "row 1, col 1", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 2 ", + tableCellContents = DocString "column 2", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 3 ", + tableCellContents = DocString "column 3", tableCellRowspan = 1}, TableCell {tableCellColspan = 1, - tableCellContents = DocString " column 4 ", + tableCellContents = DocString "column 4", tableCellRowspan = 1}]]} diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 028422a7..17240792 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -267,7 +267,7 @@ picture = DocPic . makeLabeled Picture -- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)" -- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathInline :: Parser (DocH mod a) -mathInline = DocMathInline . T.unpack +mathInline = DocMathInline . T.unpack <$> disallowNewline ("\\(" *> takeUntil "\\)") -- | Display math parser, surrounded by \\[ and \\]. @@ -492,7 +492,7 @@ tableStepFour rs hdrIndex cells = case hdrIndex of -- extract cell contents given boundaries extract :: Int -> Int -> Int -> Int -> Text extract x y x2 y2 = T.intercalate "\n" - [ T.take (x2 - x + 1) $ T.drop x $ rs !! y' + [ T.stripEnd $ T.stripStart $ T.take (x2 - x + 1) $ T.drop x $ rs !! y' | y' <- [y .. y2] ] @@ -579,7 +579,7 @@ definitionList indent = DocDefList <$> p Right i -> (label, contents) : i -- | Drops all trailing newlines. -dropNLs :: Text -> Text +dropNLs :: Text -> Text dropNLs = T.dropWhileEnd (== '\n') -- | Main worker for 'innerList' and 'definitionList'. @@ -653,7 +653,7 @@ takeNonEmptyLine = do -- -- More precisely: skips all whitespace-only lines and returns indentation -- (horizontal space, might be empty) of that non-empty line. -takeIndent :: Parser Text +takeIndent :: Parser Text takeIndent = do indent <- takeHorizontalSpace choice' [ "\n" *> takeIndent @@ -711,14 +711,14 @@ examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go) substituteBlankLine "" = "" substituteBlankLine xs = xs -nonEmptyLine :: Parser Text +nonEmptyLine :: Parser Text nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) takeLine :: Parser Text takeLine = try (takeWhile (/= '\n') <* endOfLine) endOfLine :: Parser () -endOfLine = void "\n" <|> Parsec.eof +endOfLine = void "\n" <|> Parsec.eof -- | Property parser. -- @@ -800,7 +800,7 @@ autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url where url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace) - + mkLink :: Text -> DocH mod a mkLink s = case T.unsnoc s of Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x] diff --git a/html-test/ref/Table.html b/html-test/ref/Table.html index 8a299018..26b0254d 100644 --- a/html-test/ref/Table.html +++ b/html-test/ref/Table.html @@ -87,33 +87,33 @@ >
    code message description
    200 OK operation successful
    204 No Content operation successful, no body returned
    200 OK operation successful
    204 No Content operation successful, no body returned
    404 Not Found resource not found
    Header row, column 1 - (header rows optional) Header 2 - Header 3 - Header 4 -
    body row 1, column 1 column 2 column 3 column 4
    tableWithHeader Cells may span columns.
    body row 3 Cells may - span rows. - \[ - f(n) = \sum_{i=1} - \]
    body row 4
    Date: Sun, 22 Mar 2020 11:46:42 -0400 Subject: Clean up warnings * unused imports * imports of `Data.List` without import lists * missing `CompatPrelude` file in `.cabal` --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 9 +------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 1 - .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 +- haddock-api/src/Haddock/Interface.hs | 2 +- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 2 +- haddock-api/src/Haddock/Interface/LexParseRn.hs | 2 +- haddock-api/src/Haddock/Interface/Rename.hs | 2 -- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 1 - haddock-api/src/Haddock/Utils/Json.hs | 2 +- haddock-library/haddock-library.cabal | 26 ++++++++++------------ haddock.cabal | 1 + 14 files changed, 22 insertions(+), 35 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1f98ef9c..b38d4047 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -27,10 +27,9 @@ import Haddock.Utils hiding (out) import GHC import Outputable -import NameSet import Data.Char -import Data.List +import Data.List (isPrefixOf, intercalate) import Data.Maybe import Data.Version diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index f2fb1041..63b12a14 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -38,7 +38,7 @@ import System.FilePath import Data.Char import Control.Monad import Data.Maybe -import Data.List +import Data.List ( sort ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -517,12 +517,6 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ gadtOpen = char '{' -ppForAllSeparator :: Bool -> ForallVisFlag -> LaTeX -ppForAllSeparator unicode fvf = - case fvf of - ForallVis -> text "\\ " <> arrow unicode - ForallInvis -> dot - ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX ppTypeSig nms ty unicode = hsep (punctuate comma $ map ppSymName nms) @@ -1063,7 +1057,6 @@ ppForAllPart unicode tvs fvf = hsep (forallSymbol unicode : tvs') <> fv ForallVis -> text "\\ " <> arrow unicode ForallInvis -> dot - ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index c7ae15ca..b450dc94 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -36,7 +36,6 @@ import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) import GHC hiding (LexicalFixity(..)) -import qualified GHC import GHC.Exts import Name import BooleanFormula diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index edab4b16..0d7accfc 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -19,7 +19,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( docElement, docSection, docSection_, ) where -import Data.List +import Data.List (intersperse) import Documentation.Haddock.Markup import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index c2c0d733..24568235 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -44,7 +44,7 @@ import Haddock.Utils import Control.Monad import Control.Exception (evaluate) -import Data.List +import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map import qualified Data.Set as Set import Text.Printf diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 35f24ee5..685dca01 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -21,7 +21,7 @@ import Haddock.GhcUtils import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) -import Data.List +import Data.List (sortBy) import Data.Ord (comparing) import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d5cbdaf5..b182a615 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -32,7 +32,7 @@ import Data.Bifunctor import Data.Bitraversable import qualified Data.Map as M import Data.Map (Map) -import Data.List +import Data.List (find, foldl', sortBy) import Data.Maybe import Data.Ord import Control.Applicative diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 0b40ed3c..08a3c0f8 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -22,7 +22,7 @@ module Haddock.Interface.LexParseRn import Control.Arrow import Control.Monad import Data.Functor (($>)) -import Data.List +import Data.List (maximumBy, (\\)) import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 72d063dc..0b122b07 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -22,14 +22,12 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name -import Outputable ( panic ) import RdrName (RdrName(Exact)) import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) -import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index b5be311a..3ce2fabb 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -26,7 +26,7 @@ import Haddock.Utils hiding (out) import Control.Monad import Data.Array import Data.IORef -import Data.List +import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 79673365..3eb702c9 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -65,7 +65,6 @@ import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs index e3c3dddc..2270a547 100644 --- a/haddock-api/src/Haddock/Utils/Json.hs +++ b/haddock-api/src/Haddock/Utils/Json.hs @@ -19,7 +19,7 @@ import Data.Char import Data.Int import Data.String import Data.Word -import Data.List +import Data.List (intersperse) import Data.Monoid import Data.ByteString.Builder (Builder) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index e58fe2ef..294ef5be 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -59,22 +59,20 @@ test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: - test - src - - cpp-options: - -DTEST + test + src other-modules: - Documentation.Haddock.Doc - Documentation.Haddock.Markup - Documentation.Haddock.Parser - Documentation.Haddock.Parser.Monad - Documentation.Haddock.Parser.Util - Documentation.Haddock.Parser.UtilSpec - Documentation.Haddock.ParserSpec - Documentation.Haddock.Types - Documentation.Haddock.Parser.Identifier + CompatPrelude + Documentation.Haddock.Doc + Documentation.Haddock.Markup + Documentation.Haddock.Parser + Documentation.Haddock.Parser.Monad + Documentation.Haddock.Parser.Util + Documentation.Haddock.Parser.UtilSpec + Documentation.Haddock.ParserSpec + Documentation.Haddock.Types + Documentation.Haddock.Parser.Identifier build-depends: , base-compat ^>= 0.9.3 || ^>= 0.11.0 diff --git a/haddock.cabal b/haddock.cabal index 92fe249e..425ed454 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -87,6 +87,7 @@ executable haddock transformers other-modules: + CompatPrelude Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Parser.Identifier -- cgit v1.2.3 From d576b2327e2bc117f912fe0a9d595e9ae62614e0 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 22 Mar 2020 18:46:54 -0400 Subject: Fix NPM security warnings This was done by calling `npm audit fix`. Note that the security issues seem to have been entirely in the build dependencies, since the output JS has not changed. --- haddock-api/resources/html/package-lock.json | 345 ++++++++++++++------------- 1 file changed, 182 insertions(+), 163 deletions(-) diff --git a/haddock-api/resources/html/package-lock.json b/haddock-api/resources/html/package-lock.json index b332921c..0496a79c 100644 --- a/haddock-api/resources/html/package-lock.json +++ b/haddock-api/resources/html/package-lock.json @@ -18,9 +18,9 @@ }, "dependencies": { "acorn": { - "version": "5.7.3", - "resolved": "https://registry.npmjs.org/acorn/-/acorn-5.7.3.tgz", - "integrity": "sha512-T/zvzYRfbVojPWahDsE5evJdHb3oJoQfFbsrKM7w5Zcs++Tr257tia3BmMP8XYVjp1S9RZXQMh7gao96BlqZOw==", + "version": "5.7.4", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-5.7.4.tgz", + "integrity": "sha512-1D++VG7BhrtvQpNbBzovKNc1FLGGEE/oGe7b9xJm/RFHMBeUaUGpluV9RLjZa47YFdPcDAenEYuq9pQPcMdLJg==", "dev": true }, "source-map": { @@ -52,9 +52,9 @@ } }, "acorn": { - "version": "6.0.2", - "resolved": "https://registry.npmjs.org/acorn/-/acorn-6.0.2.tgz", - "integrity": "sha512-GXmKIvbrN3TV7aVqAzVFaMW8F8wzVX7voEBRO3bDA64+EX37YSayggRJP5Xig6HYHBkWKpFg9W5gg6orklubhg==", + "version": "6.4.1", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-6.4.1.tgz", + "integrity": "sha512-ZVA9k326Nwrj3Cj9jlh3wGFutC2ZornPNARZwsNYqQYgN0EsV2d53w5RN/co65Ohn4sUAUtb1rSUAOD6XN9idA==", "dev": true }, "acorn-dynamic-import": { @@ -324,9 +324,9 @@ } }, "async-each": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/async-each/-/async-each-1.0.1.tgz", - "integrity": "sha1-GdOGodntxufByF04iu28xW0zYC0=", + "version": "1.0.3", + "resolved": "https://registry.npmjs.org/async-each/-/async-each-1.0.3.tgz", + "integrity": "sha512-z/WhQ5FPySLdvREByI2vZiTWwCnF0moMJ1hK9YQwDTHKh6I7/uSckMetoRGb5UBZPC1z0jlw+n/XCgjeH7y1AQ==", "dev": true }, "async-settle": { @@ -429,11 +429,21 @@ "dev": true }, "binary-extensions": { - "version": "1.12.0", - "resolved": "https://registry.npmjs.org/binary-extensions/-/binary-extensions-1.12.0.tgz", - "integrity": "sha512-DYWGk01lDcxeS/K9IHPGWfT8PsJmbXRtRd2Sx72Tnb8pcYZQFF1oSDb8hJtS1vhp212q1Rzi5dUf9+nq0o9UIg==", + "version": "1.13.1", + "resolved": "https://registry.npmjs.org/binary-extensions/-/binary-extensions-1.13.1.tgz", + "integrity": "sha512-Un7MIEDdUC5gNpcGDV97op1Ywk748MpHcFTHoYs6qnj1Z3j7I53VG3nwZhKzoBZmbdRNnb6WRdFlwl7tSDuZGw==", "dev": true }, + "bindings": { + "version": "1.5.0", + "resolved": "https://registry.npmjs.org/bindings/-/bindings-1.5.0.tgz", + "integrity": "sha512-p2q/t/mhvuOj/UeLlV6566GD/guowlr0hHxClI0W9m7MWYkL1F0hLo+0Aexs9HSPCtR1SXQ0TD3MMKrXZajbiQ==", + "dev": true, + "optional": true, + "requires": { + "file-uri-to-path": "1.0.0" + } + }, "bl": { "version": "1.2.2", "resolved": "http://registry.npmjs.org/bl/-/bl-1.2.2.tgz", @@ -718,9 +728,9 @@ } }, "cached-path-relative": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/cached-path-relative/-/cached-path-relative-1.0.1.tgz", - "integrity": "sha1-0JxLUoAKpMB44t2BqGmqyQ0uVOc=", + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/cached-path-relative/-/cached-path-relative-1.0.2.tgz", + "integrity": "sha512-5r2GqsoEb4qMTTN9J+WzXfjov+hjxT+j3u5K+kIVNIwAd99DLCJE9pBIMP1qVeybV6JiijL385Oz0DcYxfbOIg==", "dev": true }, "camelcase": { @@ -730,24 +740,31 @@ "dev": true }, "chokidar": { - "version": "2.0.4", - "resolved": "https://registry.npmjs.org/chokidar/-/chokidar-2.0.4.tgz", - "integrity": "sha512-z9n7yt9rOvIJrMhvDtDictKrkFHeihkNl6uWMmZlmL6tJtX9Cs+87oK+teBx+JIgzvbX3yZHT3eF8vpbDxHJXQ==", + "version": "2.1.8", + "resolved": "https://registry.npmjs.org/chokidar/-/chokidar-2.1.8.tgz", + "integrity": "sha512-ZmZUazfOzf0Nve7duiCKD23PFSCs4JPoYyccjUFF3aQkQadqBhfzhjkwBH2mNOG9cTBwhamM37EIsIkZw3nRgg==", "dev": true, "requires": { "anymatch": "^2.0.0", - "async-each": "^1.0.0", - "braces": "^2.3.0", - "fsevents": "^1.2.2", + "async-each": "^1.0.1", + "braces": "^2.3.2", + "fsevents": "^1.2.7", "glob-parent": "^3.1.0", - "inherits": "^2.0.1", + "inherits": "^2.0.3", "is-binary-path": "^1.0.0", "is-glob": "^4.0.0", - "lodash.debounce": "^4.0.8", - "normalize-path": "^2.1.1", + "normalize-path": "^3.0.0", "path-is-absolute": "^1.0.0", - "readdirp": "^2.0.0", - "upath": "^1.0.5" + "readdirp": "^2.2.1", + "upath": "^1.1.1" + }, + "dependencies": { + "normalize-path": { + "version": "3.0.0", + "resolved": "https://registry.npmjs.org/normalize-path/-/normalize-path-3.0.0.tgz", + "integrity": "sha512-6eZs5Ls3WtCisHWp9S2GUy8dqkpGi4BVSz3GaqiE6ezub0512ESztXUwUB6C6IKbQkY2Pnb/mD4WYojCRwcwLA==", + "dev": true + } } }, "cipher-base": { @@ -1230,9 +1247,9 @@ }, "dependencies": { "acorn": { - "version": "5.7.3", - "resolved": "https://registry.npmjs.org/acorn/-/acorn-5.7.3.tgz", - "integrity": "sha512-T/zvzYRfbVojPWahDsE5evJdHb3oJoQfFbsrKM7w5Zcs++Tr257tia3BmMP8XYVjp1S9RZXQMh7gao96BlqZOw==", + "version": "5.7.4", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-5.7.4.tgz", + "integrity": "sha512-1D++VG7BhrtvQpNbBzovKNc1FLGGEE/oGe7b9xJm/RFHMBeUaUGpluV9RLjZa47YFdPcDAenEYuq9pQPcMdLJg==", "dev": true } } @@ -1560,6 +1577,13 @@ "time-stamp": "^1.0.0" } }, + "file-uri-to-path": { + "version": "1.0.0", + "resolved": "https://registry.npmjs.org/file-uri-to-path/-/file-uri-to-path-1.0.0.tgz", + "integrity": "sha512-0Zt+s3L7Vf1biwWZ29aARiVYLx7iMGnEUl9x33fbB/j3jR81u/O2LbqK+Bm1CDSNDKVtJ/YjwY7TUd5SkeLQLw==", + "dev": true, + "optional": true + }, "fill-range": { "version": "4.0.0", "resolved": "https://registry.npmjs.org/fill-range/-/fill-range-4.0.0.tgz", @@ -1686,14 +1710,15 @@ "dev": true }, "fsevents": { - "version": "1.2.4", - "resolved": "https://registry.npmjs.org/fsevents/-/fsevents-1.2.4.tgz", - "integrity": "sha512-z8H8/diyk76B7q5wg+Ud0+CqzcAF3mBBI/bA5ne5zrRUUIvNkJY//D3BqyH571KuAC4Nr7Rw7CjWX4r0y9DvNg==", + "version": "1.2.12", + "resolved": "https://registry.npmjs.org/fsevents/-/fsevents-1.2.12.tgz", + "integrity": "sha512-Ggd/Ktt7E7I8pxZRbGIs7vwqAPscSESMrCSkx2FtWeqmheJgCo2R74fTsZFCifr0VTPwqRpPv17+6b8Zp7th0Q==", "dev": true, "optional": true, "requires": { - "nan": "^2.9.2", - "node-pre-gyp": "^0.10.0" + "bindings": "^1.5.0", + "nan": "^2.12.1", + "node-pre-gyp": "*" }, "dependencies": { "abbrev": { @@ -1705,7 +1730,8 @@ "ansi-regex": { "version": "2.1.1", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "aproba": { "version": "1.2.0", @@ -1714,7 +1740,7 @@ "optional": true }, "are-we-there-yet": { - "version": "1.1.4", + "version": "1.1.5", "bundled": true, "dev": true, "optional": true, @@ -1726,19 +1752,21 @@ "balanced-match": { "version": "1.0.0", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "brace-expansion": { "version": "1.1.11", "bundled": true, "dev": true, + "optional": true, "requires": { "balanced-match": "^1.0.0", "concat-map": "0.0.1" } }, "chownr": { - "version": "1.0.1", + "version": "1.1.4", "bundled": true, "dev": true, "optional": true @@ -1746,17 +1774,20 @@ "code-point-at": { "version": "1.1.0", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "concat-map": { "version": "0.0.1", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "console-control-strings": { "version": "1.1.0", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "core-util-is": { "version": "1.0.2", @@ -1765,16 +1796,16 @@ "optional": true }, "debug": { - "version": "2.6.9", + "version": "3.2.6", "bundled": true, "dev": true, "optional": true, "requires": { - "ms": "2.0.0" + "ms": "^2.1.1" } }, "deep-extend": { - "version": "0.5.1", + "version": "0.6.0", "bundled": true, "dev": true, "optional": true @@ -1792,12 +1823,12 @@ "optional": true }, "fs-minipass": { - "version": "1.2.5", + "version": "1.2.7", "bundled": true, "dev": true, "optional": true, "requires": { - "minipass": "^2.2.1" + "minipass": "^2.6.0" } }, "fs.realpath": { @@ -1823,7 +1854,7 @@ } }, "glob": { - "version": "7.1.2", + "version": "7.1.6", "bundled": true, "dev": true, "optional": true, @@ -1843,16 +1874,16 @@ "optional": true }, "iconv-lite": { - "version": "0.4.21", + "version": "0.4.24", "bundled": true, "dev": true, "optional": true, "requires": { - "safer-buffer": "^2.1.0" + "safer-buffer": ">= 2.1.2 < 3" } }, "ignore-walk": { - "version": "3.0.1", + "version": "3.0.3", "bundled": true, "dev": true, "optional": true, @@ -1871,9 +1902,10 @@ } }, "inherits": { - "version": "2.0.3", + "version": "2.0.4", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "ini": { "version": "1.3.5", @@ -1885,6 +1917,7 @@ "version": "1.0.0", "bundled": true, "dev": true, + "optional": true, "requires": { "number-is-nan": "^1.0.0" } @@ -1899,78 +1932,82 @@ "version": "3.0.4", "bundled": true, "dev": true, + "optional": true, "requires": { "brace-expansion": "^1.1.7" } }, "minimist": { - "version": "0.0.8", + "version": "1.2.5", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "minipass": { - "version": "2.2.4", + "version": "2.9.0", "bundled": true, "dev": true, + "optional": true, "requires": { - "safe-buffer": "^5.1.1", + "safe-buffer": "^5.1.2", "yallist": "^3.0.0" } }, "minizlib": { - "version": "1.1.0", + "version": "1.3.3", "bundled": true, "dev": true, "optional": true, "requires": { - "minipass": "^2.2.1" + "minipass": "^2.9.0" } }, "mkdirp": { - "version": "0.5.1", + "version": "0.5.3", "bundled": true, "dev": true, + "optional": true, "requires": { - "minimist": "0.0.8" + "minimist": "^1.2.5" } }, "ms": { - "version": "2.0.0", + "version": "2.1.2", "bundled": true, "dev": true, "optional": true }, "needle": { - "version": "2.2.0", + "version": "2.3.3", "bundled": true, "dev": true, "optional": true, "requires": { - "debug": "^2.1.2", + "debug": "^3.2.6", "iconv-lite": "^0.4.4", "sax": "^1.2.4" } }, "node-pre-gyp": { - "version": "0.10.0", + "version": "0.14.0", "bundled": true, "dev": true, "optional": true, "requires": { "detect-libc": "^1.0.2", "mkdirp": "^0.5.1", - "needle": "^2.2.0", + "needle": "^2.2.1", "nopt": "^4.0.1", "npm-packlist": "^1.1.6", "npmlog": "^4.0.2", - "rc": "^1.1.7", + "rc": "^1.2.7", "rimraf": "^2.6.1", "semver": "^5.3.0", - "tar": "^4" + "tar": "^4.4.2" } }, "nopt": { - "version": "4.0.1", + "version": "4.0.3", "bundled": true, "dev": true, "optional": true, @@ -1980,19 +2017,29 @@ } }, "npm-bundled": { - "version": "1.0.3", + "version": "1.1.1", + "bundled": true, + "dev": true, + "optional": true, + "requires": { + "npm-normalize-package-bin": "^1.0.1" + } + }, + "npm-normalize-package-bin": { + "version": "1.0.1", "bundled": true, "dev": true, "optional": true }, "npm-packlist": { - "version": "1.1.10", + "version": "1.4.8", "bundled": true, "dev": true, "optional": true, "requires": { "ignore-walk": "^3.0.1", - "npm-bundled": "^1.0.1" + "npm-bundled": "^1.0.1", + "npm-normalize-package-bin": "^1.0.1" } }, "npmlog": { @@ -2010,7 +2057,8 @@ "number-is-nan": { "version": "1.0.1", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "object-assign": { "version": "4.1.1", @@ -2022,6 +2070,7 @@ "version": "1.4.0", "bundled": true, "dev": true, + "optional": true, "requires": { "wrappy": "1" } @@ -2055,33 +2104,25 @@ "optional": true }, "process-nextick-args": { - "version": "2.0.0", + "version": "2.0.1", "bundled": true, "dev": true, "optional": true }, "rc": { - "version": "1.2.7", + "version": "1.2.8", "bundled": true, "dev": true, "optional": true, "requires": { - "deep-extend": "^0.5.1", + "deep-extend": "^0.6.0", "ini": "~1.3.0", "minimist": "^1.2.0", "strip-json-comments": "~2.0.1" - }, - "dependencies": { - "minimist": { - "version": "1.2.0", - "bundled": true, - "dev": true, - "optional": true - } } }, "readable-stream": { - "version": "2.3.6", + "version": "2.3.7", "bundled": true, "dev": true, "optional": true, @@ -2096,18 +2137,19 @@ } }, "rimraf": { - "version": "2.6.2", + "version": "2.7.1", "bundled": true, "dev": true, "optional": true, "requires": { - "glob": "^7.0.5" + "glob": "^7.1.3" } }, "safe-buffer": { - "version": "5.1.1", + "version": "5.1.2", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "safer-buffer": { "version": "2.1.2", @@ -2122,7 +2164,7 @@ "optional": true }, "semver": { - "version": "5.5.0", + "version": "5.7.1", "bundled": true, "dev": true, "optional": true @@ -2143,6 +2185,7 @@ "version": "1.0.2", "bundled": true, "dev": true, + "optional": true, "requires": { "code-point-at": "^1.0.0", "is-fullwidth-code-point": "^1.0.0", @@ -2162,6 +2205,7 @@ "version": "3.0.1", "bundled": true, "dev": true, + "optional": true, "requires": { "ansi-regex": "^2.0.0" } @@ -2173,18 +2217,18 @@ "optional": true }, "tar": { - "version": "4.4.1", + "version": "4.4.13", "bundled": true, "dev": true, "optional": true, "requires": { - "chownr": "^1.0.1", + "chownr": "^1.1.1", "fs-minipass": "^1.2.5", - "minipass": "^2.2.4", - "minizlib": "^1.1.0", + "minipass": "^2.8.6", + "minizlib": "^1.2.1", "mkdirp": "^0.5.0", - "safe-buffer": "^5.1.1", - "yallist": "^3.0.2" + "safe-buffer": "^5.1.2", + "yallist": "^3.0.3" } }, "util-deprecate": { @@ -2194,23 +2238,25 @@ "optional": true }, "wide-align": { - "version": "1.1.2", + "version": "1.1.3", "bundled": true, "dev": true, "optional": true, "requires": { - "string-width": "^1.0.2" + "string-width": "^1.0.2 || 2" } }, "wrappy": { "version": "1.0.2", "bundled": true, - "dev": true + "dev": true, + "optional": true }, "yallist": { - "version": "3.0.2", + "version": "3.1.1", "bundled": true, - "dev": true + "dev": true, + "optional": true } } }, @@ -2297,13 +2343,15 @@ } }, "glob-watcher": { - "version": "5.0.1", - "resolved": "https://registry.npmjs.org/glob-watcher/-/glob-watcher-5.0.1.tgz", - "integrity": "sha512-fK92r2COMC199WCyGUblrZKhjra3cyVMDiypDdqg1vsSDmexnbYivK1kNR4QItiNXLKmGlqan469ks67RtNa2g==", + "version": "5.0.3", + "resolved": "https://registry.npmjs.org/glob-watcher/-/glob-watcher-5.0.3.tgz", + "integrity": "sha512-8tWsULNEPHKQ2MR4zXuzSmqbdyV5PtwwCaWSGQ1WwHsJ07ilNeN1JB8ntxhckbnpSHaf9dXFUHzIWvm1I13dsg==", "dev": true, "requires": { + "anymatch": "^2.0.0", "async-done": "^1.2.0", "chokidar": "^2.0.0", + "is-negated-glob": "^1.0.0", "just-debounce": "^1.0.0", "object.defaults": "^1.1.0" } @@ -2419,9 +2467,9 @@ }, "dependencies": { "acorn": { - "version": "5.7.3", - "resolved": "https://registry.npmjs.org/acorn/-/acorn-5.7.3.tgz", - "integrity": "sha512-T/zvzYRfbVojPWahDsE5evJdHb3oJoQfFbsrKM7w5Zcs++Tr257tia3BmMP8XYVjp1S9RZXQMh7gao96BlqZOw==", + "version": "5.7.4", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-5.7.4.tgz", + "integrity": "sha512-1D++VG7BhrtvQpNbBzovKNc1FLGGEE/oGe7b9xJm/RFHMBeUaUGpluV9RLjZa47YFdPcDAenEYuq9pQPcMdLJg==", "dev": true }, "source-map": { @@ -2787,9 +2835,9 @@ } }, "is-glob": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/is-glob/-/is-glob-4.0.0.tgz", - "integrity": "sha1-lSHHaEXMJhCoUgPd8ICpWML/q8A=", + "version": "4.0.1", + "resolved": "https://registry.npmjs.org/is-glob/-/is-glob-4.0.1.tgz", + "integrity": "sha512-5G0tKtBTFImOqDnLB2hG6Bp2qcKEFduo4tZu9MT/H6NQv/ghhy30o55ufafxJ/LdH79LLs2Kfrn85TLKyA7BUg==", "dev": true, "requires": { "is-extglob": "^2.1.1" @@ -2918,9 +2966,9 @@ "dev": true }, "kind-of": { - "version": "6.0.2", - "resolved": "https://registry.npmjs.org/kind-of/-/kind-of-6.0.2.tgz", - "integrity": "sha512-s5kLOcnH0XqDO+FvuaLX8DDjZ18CGFk7VygH40QoKPUQhW4e2rvM0rwUq0t8IQDOwYSeLK01U90OjzBTme2QqA==", + "version": "6.0.3", + "resolved": "https://registry.npmjs.org/kind-of/-/kind-of-6.0.3.tgz", + "integrity": "sha512-dcS1ul+9tmeD95T+x28/ehLgd9mENa3LsvDTtzm3vyBEO7RPptvAD+t44WVXaUjTBRcrpFeFlC8WCruUR456hw==", "dev": true }, "labeled-stream-splicer": { @@ -3009,15 +3057,9 @@ } }, "lodash": { - "version": "4.17.11", - "resolved": "https://registry.npmjs.org/lodash/-/lodash-4.17.11.tgz", - "integrity": "sha512-cQKh8igo5QUhZ7lg38DYWAxMvjSAKG0A8wGSVimP07SIUEK2UO+arSRKbRZWtelMtN5V0Hkwh5ryOto/SshYIg==", - "dev": true - }, - "lodash.debounce": { - "version": "4.0.8", - "resolved": "https://registry.npmjs.org/lodash.debounce/-/lodash.debounce-4.0.8.tgz", - "integrity": "sha1-gteb/zCmfEAF/9XiUVMArZyk168=", + "version": "4.17.15", + "resolved": "https://registry.npmjs.org/lodash/-/lodash-4.17.15.tgz", + "integrity": "sha512-8xOcRHvCjnocdS5cpwXQXVzmmh5e5+saE2QGoeQmbKmRS6J3VQppPOIt0MnmE+4xlZoumy0GPG0D0MVIQbNA1A==", "dev": true }, "lodash.memoize": { @@ -3198,15 +3240,15 @@ } }, "minimist": { - "version": "1.2.0", - "resolved": "https://registry.npmjs.org/minimist/-/minimist-1.2.0.tgz", - "integrity": "sha1-o1AIsg9BOD7sH7kU9M1d95omQoQ=", + "version": "1.2.5", + "resolved": "https://registry.npmjs.org/minimist/-/minimist-1.2.5.tgz", + "integrity": "sha512-FM9nNUYrRBAELZQT3xeZQ7fmMOBg6nWNmJKTcgsJeaLstP/UODVpGsr5OhXhhXg6f+qtJ8uiZ+PUxkDWcgIXLw==", "dev": true }, "mixin-deep": { - "version": "1.3.1", - "resolved": "https://registry.npmjs.org/mixin-deep/-/mixin-deep-1.3.1.tgz", - "integrity": "sha512-8ZItLHeEgaqEvd5lYBXfm4EZSFCX29Jb9K+lAHhDKzReKBQKj3R+7NOF6tjqYi9t4oI8VUfaWITJQm86wnXGNQ==", + "version": "1.3.2", + "resolved": "https://registry.npmjs.org/mixin-deep/-/mixin-deep-1.3.2.tgz", + "integrity": "sha512-WRoDn//mXBiJ1H40rqa3vH0toePwSsGb45iInWlTySa+Uu4k3tYUSxa2v1KqAiLtvlrSzaExqS1gtk96A9zvEA==", "dev": true, "requires": { "for-in": "^1.0.2", @@ -3254,9 +3296,9 @@ "dev": true }, "nan": { - "version": "2.11.1", - "resolved": "https://registry.npmjs.org/nan/-/nan-2.11.1.tgz", - "integrity": "sha512-iji6k87OSXa0CcrLl9z+ZiYSuR2o+c0bGuNmXdrhTQTakxytAFsC56SArGYoiHlJlFoHSnvmhpceZJaXkVuOtA==", + "version": "2.14.0", + "resolved": "https://registry.npmjs.org/nan/-/nan-2.14.0.tgz", + "integrity": "sha512-INOFj37C7k3AfaNTtX8RhsTw7qRy7eLET14cROi9+5HAVbbHuIWUHEauBv5qT4Av2tWasiTY1Jw6puUNqRJXQg==", "dev": true, "optional": true }, @@ -3974,9 +4016,9 @@ "dev": true }, "set-value": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/set-value/-/set-value-2.0.0.tgz", - "integrity": "sha512-hw0yxk9GT/Hr5yJEYnHNKYXkIA8mVJgd9ditYZCe16ZczcaELYYcfvaXesNACk2O8O0nTiPQcQhGUQj8JLzeeg==", + "version": "2.0.1", + "resolved": "https://registry.npmjs.org/set-value/-/set-value-2.0.1.tgz", + "integrity": "sha512-JxHc1weCN68wRY0fhCoXpyK55m/XPHafOmK4UWD7m2CI14GMcFypt4w/0+NV5f/ZMby2F6S2wwA7fgynh9gWSw==", "dev": true, "requires": { "extend-shallow": "^2.0.1", @@ -4682,38 +4724,15 @@ "dev": true }, "union-value": { - "version": "1.0.0", - "resolved": "https://registry.npmjs.org/union-value/-/union-value-1.0.0.tgz", - "integrity": "sha1-XHHDTLW61dzr4+oM0IIHulqhrqQ=", + "version": "1.0.1", + "resolved": "https://registry.npmjs.org/union-value/-/union-value-1.0.1.tgz", + "integrity": "sha512-tJfXmxMeWYnczCVs7XAEvIV7ieppALdyepWMkHkwciRpZraG/xwT+s2JN8+pr1+8jCRf80FFzvr+MpQeeoF4Xg==", "dev": true, "requires": { "arr-union": "^3.1.0", "get-value": "^2.0.6", "is-extendable": "^0.1.1", - "set-value": "^0.4.3" - }, - "dependencies": { - "extend-shallow": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/extend-shallow/-/extend-shallow-2.0.1.tgz", - "integrity": "sha1-Ua99YUrZqfYQ6huvu5idaxxWiQ8=", - "dev": true, - "requires": { - "is-extendable": "^0.1.0" - } - }, - "set-value": { - "version": "0.4.3", - "resolved": "https://registry.npmjs.org/set-value/-/set-value-0.4.3.tgz", - "integrity": "sha1-fbCPnT0i3H945Trzw79GZuzfzPE=", - "dev": true, - "requires": { - "extend-shallow": "^2.0.1", - "is-extendable": "^0.1.1", - "is-plain-object": "^2.0.1", - "to-object-path": "^0.3.0" - } - } + "set-value": "^2.0.1" } }, "unique-stream": { @@ -4784,9 +4803,9 @@ } }, "upath": { - "version": "1.1.0", - "resolved": "https://registry.npmjs.org/upath/-/upath-1.1.0.tgz", - "integrity": "sha512-bzpH/oBhoS/QI/YtbkqCg6VEiPYjSZtrHQM6/QnJS6OL9pKUFLqb3aFh4Scvwm45+7iAgiMkLhSbaZxUqmrprw==", + "version": "1.2.0", + "resolved": "https://registry.npmjs.org/upath/-/upath-1.2.0.tgz", + "integrity": "sha512-aZwGpamFO61g3OlfT7OQCHqhGnW43ieH9WZeP7QxN/G/jS4jfqUkZxoryvJgVPEcrl5NL/ggHsSmLMHuH64Lhg==", "dev": true }, "urix": { -- cgit v1.2.3 From 03dbfdd70186e484135ba1ea8d27672264cd9712 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sun, 22 Mar 2020 20:10:52 -0400 Subject: Tentative 2.24 release Adjusted changelogs and versions in `.cabal` files in preparation for the upcoming release bundled with GHC 8.10. --- CHANGES.md | 7 +++++++ haddock-api/haddock-api.cabal | 6 +++--- haddock-api/src/Haddock/Backends/Hoogle.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-library/CHANGES.md | 4 +++- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 4 ++-- 7 files changed, 18 insertions(+), 9 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 88656da4..b0600381 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +## Changes in 2.24.0 + + * Reify oversaturated data family instances correctly (#1103) + + * Removed the majority of Haddock's possible `panic` routes through + the TTG refactor to make extension variants empty + ## Changes in 2.23.0 * "Linuwial" is the new default theme (#721, #782, #949) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 8ad0ae64..0324fcd6 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock-api -version: 2.23.0 +version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -45,7 +45,7 @@ library build-depends: base ^>= 4.14.0 , ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.8.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -167,7 +167,7 @@ test-suite spec build-depends: ghc ^>= 8.10 , ghc-paths ^>= 0.1.0.12 - , haddock-library ^>= 1.8.0 + , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.8 , QuickCheck >= 2.11 && < 2.14 diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b38d4047..b4a605f2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -260,7 +260,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k - tyVarBndr2Type (XTyVarBndr _) = panic "haddock:ppCtor" + tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 3ce2fabb..17be6fa1 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 809) && (__GLASGOW_HASKELL__ < 811) -binaryInterfaceVersion = 35 +binaryInterfaceVersion = 36 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index d112db45..5b400d7c 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,7 +1,9 @@ -## Changes in version 1.8.0.1 +## Changes in version 1.9.0 * Fix build-time regression for `base < 4.7` (#1119) + * Update parsing to strip whitespace from table cells (#1074) + ## Changes in version 1.8.0 * Support inline markup in markdown-style links (#875) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 294ef5be..57f45887 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: haddock-library -version: 1.8.0.1 +version: 1.9.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell diff --git a/haddock.cabal b/haddock.cabal index 425ed454..f01fe8fc 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: haddock -version: 2.23.0 +version: 2.24.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -144,7 +144,7 @@ executable haddock else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version. - build-depends: haddock-api == 2.23.0 + build-depends: haddock-api == 2.24.0 test-suite html-test type: exitcode-stdio-1.0 -- cgit v1.2.3 From 7013f52cca144e8d5e4deb08913370f1819dbc68 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 26 Mar 2020 18:18:07 -0400 Subject: Update `.travis.yml` to work with GHC 8.10.1 * Regenerated the Travis file with `haskell-ci` * Beef up `.cabal` files with more `tested-with` information --- .travis.yml | 108 ++++++++++++++++++++-------------- haddock-api/haddock-api.cabal | 1 + haddock-library/haddock-library.cabal | 13 +++- haddock-test/haddock-test.cabal | 1 + 4 files changed, 78 insertions(+), 45 deletions(-) diff --git a/.travis.yml b/.travis.yml index 88292b40..32ac3065 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,12 +1,14 @@ # This Travis job script has been generated by a script via # -# haskell-ci 'haddock.cabal' '--output' '.travis.yml' +# haskell-ci 'cabal.project' '--output=.travis.yml' # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.5.20190916 +# version: 0.9.20200321 # +version: ~> 1.0 language: c +os: linux dist: xenial git: # whether to recursively clone submodules @@ -15,6 +17,7 @@ cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store + - $HOME/.hlint before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' @@ -24,13 +27,13 @@ before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage -matrix: +jobs: include: - - os: linux - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head], sources: [hvr-ghc]}} - env: - - GHC_ZIP='https://gitlab.haskell.org/ghc/ghc/-/jobs/artifacts/master/download?job=validate-x86_64-linux-deb9' - + - compiler: ghc-8.10.1 + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} + os: linux + allow_failures: + - compiler: ghc-8.10.1 before_install: - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" @@ -43,32 +46,12 @@ before_install: - TOP=$(pwd) - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap+markoutput" + - CABAL="$CABAL -vnormal+nowrap" - set -o pipefail - - | - echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk - echo 'BEGIN { state = "output"; }' >> .colorful.awk - echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk - echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk - echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk - echo ' if (state == "cabal") {' >> .colorful.awk - echo ' print blue($0)' >> .colorful.awk - echo ' } else {' >> .colorful.awk - echo ' print $0' >> .colorful.awk - echo ' }' >> .colorful.awk - echo '}' >> .colorful.awk - - cat .colorful.awk - - | - color_cabal_output () { - awk -f $TOP/.colorful.awk - } - - echo text | color_cabal_output -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - TEST=--enable-tests - BENCH=--enable-benchmarks - HEADHACKAGE=false + - HEADHACKAGE=true - rm -f $CABALHOME/config - | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config @@ -86,52 +69,89 @@ install: echo " prefix: $CABALHOME" >> $CABALHOME/config echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + - | + if $HEADHACKAGE; then + echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config + echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config + echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config + echo " secure: True" >> $CABALHOME/config + echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config + echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config + echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config + echo " key-threshold: 3" >> $CABALHOME/config + fi +install: + - ${CABAL} --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - | echo "program-default-options" >> $CABALHOME/config echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - cat $CABALHOME/config - - rm -fv cabal.project.local cabal.project.freeze + - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v # Generate cabal.project - - rm -rf cabal.project.local cabal.project.freeze - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: ." >> cabal.project + echo "packages: ./haddock-api" >> cabal.project + echo "packages: ./haddock-library" >> cabal.project + echo "packages: ./haddock-test" >> cabal.project + - | + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock|haddock-api|haddock-library|haddock-test)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - if [ -f "./haddock-api/configure.ac" ]; then (cd "./haddock-api" && autoreconf -i); fi + - if [ -f "./haddock-library/configure.ac" ]; then (cd "./haddock-library" && autoreconf -i); fi + - if [ -f "./haddock-test/configure.ac" ]; then (cd "./haddock-test" && autoreconf -i); fi + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output + - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all + - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - - ${CABAL} v2-sdist all | color_cabal_output + - ${CABAL} v2-sdist all # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - cd ${DISTDIR} || false - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; + - PKGDIR_haddock="$(find . -maxdepth 1 -type d -regex '.*/haddock-[0-9.]*')" + - PKGDIR_haddock_api="$(find . -maxdepth 1 -type d -regex '.*/haddock-api-[0-9.]*')" + - PKGDIR_haddock_library="$(find . -maxdepth 1 -type d -regex '.*/haddock-library-[0-9.]*')" + - PKGDIR_haddock_test="$(find . -maxdepth 1 -type d -regex '.*/haddock-test-[0-9.]*')" # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | - echo "packages: ./haddock-*" >> cabal.project + echo "packages: ${PKGDIR_haddock}" >> cabal.project + echo "packages: ${PKGDIR_haddock_api}" >> cabal.project + echo "packages: ${PKGDIR_haddock_library}" >> cabal.project + echo "packages: ${PKGDIR_haddock_test}" >> cabal.project - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock|haddock-api|haddock-library|haddock-test)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true # Building... # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all # Building with tests and benchmarks... # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all + # cabal check... + - (cd ${PKGDIR_haddock} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_haddock_api} && ${CABAL} -vnormal check) + - (cd ${PKGDIR_haddock_library} && ${CABAL} -vnormal check) + # haddock... + - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all -# REGENDATA ["haddock.cabal","--output",".travis.yml"] +# REGENDATA ("0.9.20200321",["cabal.project","--output=.travis.yml"]) # EOF diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 0324fcd6..54255e09 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -13,6 +13,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple +tested-with: GHC==8.10.* extra-source-files: CHANGES.md diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 57f45887..1a06d0e5 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -12,11 +12,22 @@ description: Haddock is a documentation-generation tool for Haskell itself, see the [haddock package](https://hackage.haskell.org/package/haddock). license: BSD-2-Clause -license-files: LICENSE +license-file: LICENSE maintainer: Alec Theriault , Alex Biehl , Simon Hengel , Mateusz Kowalczyk homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues category: Documentation +tested-with: GHC == 7.4.2 + , GHC == 7.6.3 + , GHC == 7.8.4 + , GHC == 7.10.3 + , GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.3 + , GHC == 8.10.1 + extra-source-files: CHANGES.md fixtures/examples/*.input diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 0dd3eb47..a722c30e 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -9,6 +9,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple +tested-with: GHC==8.10.* cabal-version: >= 1.10 stability: experimental -- cgit v1.2.3 From 8c6532636e6bd572455dfcf0b0d6e05f7033d110 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 26 Mar 2020 19:40:38 -0400 Subject: Update README Removed some out of date links/info, added some more useful links. * badge to Hackage * update old trac link * `ghc-head` => `ghc-8.10` * `cabal new-*` is now `cabal v2-*` and it should Just Work * `--test-option='--accept'` is the way to accept testsuite output --- README.md | 105 ++++++++++++++++++++++++++++---------------------------------- 1 file changed, 48 insertions(+), 57 deletions(-) diff --git a/README.md b/README.md index e421ef7e..4490a53e 100644 --- a/README.md +++ b/README.md @@ -1,68 +1,59 @@ -# Haddock, a Haskell Documentation Tool [![Build Status](https://travis-ci.org/haskell/haddock.svg?branch=ghc-head)](https://travis-ci.org/haskell/haddock) - - -## About haddock - -See [Description on Hackage](https://hackage.haskell.org/package/haddock). - -## Source code documentation - -Full documentation can be found in the `doc/` subdirectory, in -[reStructedText format](http://www.sphinx-doc.org/en/stable/rest.html) -format. +# Haddock [![CI][CI badge]][CI page] [![Hackage][Hackage badge]][Hackage page] +Haddock is the standard tool for generating documentation from Haskell code. +Full documentation about Haddock itself can be found in the `doc/` subdirectory, +in [reStructedText format][ReST] format. ## Project overview This project consists of three packages: -* haddock -* haddock-api -* haddock-library - -### haddock - -The haddock package provides the `haddock` executable. It is implemented as a -tiny wrapper around haddock-api's `Documentation.Haddock.haddock` function. + * `haddock`: provides the `haddock` executable. It is implemented as a tiny + wrapper around `haddock-api`'s `Documentation.Haddock.haddock` function. -### haddock-api - -haddock-api contains the program logic of the `haddock` tool. [The haddocks for -the `Documentation.Haddock` module](http://hackage.haskell.org/package/haddock-api-2.19.0.1/docs/Documentation-Haddock.html) -offer a good overview of haddock-api's functionality. - -### haddock-library - -haddock-library is concerned with the parsing and processing of the Haddock -markup language. + * `haddock-api`: contains the program logic of the `haddock` tool. + [The haddocks for the `Documentation.Haddock` module][Documentation.Haddock] + offer a good overview of the functionality. + * `haddock-library`: is concerned with the parsing and processing of the + Haddock markup language. Unlike the other packages, it is expected to build + on a fairly wide range of GHC versions. ## Contributing -Please create issues when you have any problems and pull requests if you have some code. +Please create issues when you have any problems and pull requests if you have +some code. ## Hacking -To get started you'll need a latest GHC release installed. +To get started you'll need the latest GHC release installed. Clone the repository: ```bash - git clone https://github.com/haskell/haddock.git - cd haddock +git clone https://github.com/haskell/haddock.git +cd haddock ``` and then proceed using your favourite build tool. -#### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html) +#### Using [`cabal v2-build`][cabal v2] + +```bash +cabal v2-build -w ghc-8.10.1 +cabal v2-test -w ghc-8.10.1 all +``` + +#### Using `stack` ```bash -cabal new-build -w ghc-head -# build & run the test suite -cabal new-test -w ghc-head all +stack init +stack build +export HADDOCK_PATH="$(stack exec which haddock)" +stack test ``` -#### Using Cabal sandboxes +#### Using Cabal sandboxes (deprecated) ```bash cabal sandbox init @@ -78,29 +69,29 @@ export HADDOCK_PATH="dist/build/haddock/haddock" cabal test ``` -#### Using Stack - -```bash -stack init -stack build -# run the test suite -export HADDOCK_PATH="$(stack exec which haddock)" -stack test -``` - ### Git Branches -If you're a GHC developer and want to update Haddock to work with your -changes, you should be working on `ghc-head` branch. -See instructions at -https://ghc.haskell.org/trac/ghc/wiki/WorkingConventions/Git/Submodules +If you're a GHC developer and want to update Haddock to work with your changes, +you should be working on the `ghc-head` branch. See instructions at + for an example workflow. -### Updating `html-test` +### Updating golden testsuite outputs -When accepting any changes in the output of `html-test`, it is important -to use the `--haddock-path` option. For example: +If you've changed Haddock's output, you will probably need to accept the new +output of Haddock's golden test suites (`html-test`, `latex-test`, +`hoogle-test`, and `hypsrc-test`). This can be done by passing the `--accept` +argument to these test suites. With a new enough version of `cabal-install`: ``` -cabal new-run -- html-test --haddock-path $(find dist-newstyle/ -executable -type f -name haddock) --accept +cabal v2-test html-test latex-test hoogle-test hypsrc-test \ + --test-option='--accept' ``` + +[CI page]: https://travis-ci.org/haskell/haddock +[CI badge]: https://travis-ci.org/haskell/haddock.svg?branch=ghc-8.10 +[Hackage page]: https://hackage.haskell.org/package/haddock +[Hackage badge]: https://img.shields.io/hackage/v/haddock.svg +[ReST]: http://www.sphinx-doc.org/en/stable/rest.html +[Documentation.Haddock]: http://hackage.haskell.org/package/haddock-api/docs/Documentation-Haddock.html +[cabal v2]: http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html -- cgit v1.2.3 From b0514cc5d53bb37424177d2ba986216a914f8b1c Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 27 Mar 2020 20:16:51 -0400 Subject: Fix crash in `haddock-library` on unicode space Our quickcheck tests for `haddock-library` stumbled across an edge case input that was causing Haddock to crash: it was a unicode space character. The root cause of the crash is that we were implicitly assuming that if a space character was not " \t\f\v\r", it would have to be "\n". We fix this by instead defining horizontal space as: any space character that is not '\n'. Fixes #1142 --- haddock-library/src/Documentation/Haddock/Parser/Util.hs | 14 +++++++------- haddock-library/test/Documentation/Haddock/ParserSpec.hs | 8 +++++++- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs index 98570c22..eef744d8 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -31,16 +31,16 @@ import Prelude hiding (takeWhile) import Data.Char (isSpace) -- | Characters that count as horizontal space -horizontalSpace :: [Char] -horizontalSpace = " \t\f\v\r" +horizontalSpace :: Char -> Bool +horizontalSpace c = isSpace c && c /= '\n' -- | Skip and ignore leading horizontal space skipHorizontalSpace :: Parser () -skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) +skipHorizontalSpace = Parsec.skipMany (Parsec.satisfy horizontalSpace) -- | Take leading horizontal space -takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (`elem` horizontalSpace) +takeHorizontalSpace :: Parser Text +takeHorizontalSpace = takeWhile horizontalSpace makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of @@ -60,10 +60,10 @@ removeEscapes = T.unfoldr go -- | Consume characters from the input up to and including the given pattern. -- Return everything consumed except for the end pattern itself. -takeUntil :: Text -> Parser Text +takeUntil :: Text -> Parser Text takeUntil end_ = T.dropEnd (T.length end_) <$> requireEnd (scan p (False, end)) >>= gotSome where - end = T.unpack end_ + end = T.unpack end_ p :: (Bool, String) -> Char -> Maybe (Bool, String) p acc c = case acc of diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index bc40a0a2..8b59b560 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -3,6 +3,7 @@ module Documentation.Haddock.ParserSpec (main, spec) where +import Data.Char (isSpace) import Data.String import qualified Documentation.Haddock.Parser as Parse import Documentation.Haddock.Types @@ -442,6 +443,10 @@ spec = do property $ \xs -> (length . show . parseParas) xs `shouldSatisfy` (> 0) + -- See + it "doesn't crash on unicode whitespace" $ do + "\8197" `shouldParseTo` DocEmpty + context "when parsing @since" $ do it "adds specified version to the result" $ do parseParas "@since 0.5.0" `shouldBe` @@ -470,7 +475,8 @@ spec = do context "when parsing text paragraphs" $ do - let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) + let isSpecial c = isSpace c || c `elem` (".(=#-[*`\\\"'_/@<>" :: String) + filterSpecial = filter (not . isSpecial) it "parses an empty paragraph" $ do "" `shouldParseTo` DocEmpty -- cgit v1.2.3 From 2a2020c5331c593319bd196aadccdc46e7a3f779 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Thu, 28 Feb 2019 12:41:09 -0800 Subject: Disallow qualified uses of reserved identifiers This a GHC bug (https://gitlab.haskell.org/ghc/ghc/issues/14109) too, but it is a relatively easy fix in Haddock. Note that the fix must live in `haddock-api` instead of `haddock-library` because we can only really decide if an identifier is a reserved one by asking the GHC lexer. Fixes #952 --- haddock-api/src/Haddock/Parser.hs | 34 +++++++++++------- html-test/ref/Bug952.html | 76 +++++++++++++++++++++++++++++++++++++++ html-test/src/Bug952.hs | 5 +++ 3 files changed, 103 insertions(+), 12 deletions(-) create mode 100644 html-test/ref/Bug952.html create mode 100644 html-test/src/Bug952.hs diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs index 6d5dc103..05f3c7f0 100644 --- a/haddock-api/src/Haddock/Parser.hs +++ b/haddock-api/src/Haddock/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013, @@ -19,8 +20,10 @@ import Haddock.Types import DynFlags ( DynFlags ) import FastString ( fsLit ) -import Lexer ( mkPState, unP, ParseResult(POk) ) +import Lexer ( mkPState, unP, ParseResult(..) ) +import OccName ( occNameString ) import Parser ( parseIdentifier ) +import RdrName ( RdrName(Qual) ) import SrcLoc ( mkRealSrcLoc, GenLocated(..) ) import StringBuffer ( stringToStringBuffer ) @@ -33,14 +36,21 @@ parseString d = P.overIdentifier (parseIdent d) . P.parseString parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName) parseIdent dflags ns str0 = - let buffer = stringToStringBuffer str1 - realSrcLc = mkRealSrcLoc (fsLit "") 0 0 - pstate = mkPState dflags buffer realSrcLc - (wrap,str1) = case str0 of - '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names - -> (Parenthesized, init s) - '`' : s@(_ : _) -> (Backticked, init s) - _ -> (Unadorned, str0) - in case unP parseIdentifier pstate of - POk _ (L _ name) -> Just (wrap (NsRdrName ns name)) - _ -> Nothing + case unP parseIdentifier (pstate str1) of + POk _ (L _ name) + -- Guards against things like 'Q.--', 'Q.case', etc. + -- See https://github.com/haskell/haddock/issues/952 and Trac #14109 + | Qual _ occ <- name + , PFailed{} <- unP parseIdentifier (pstate (occNameString occ)) + -> Nothing + | otherwise + -> Just (wrap (NsRdrName ns name)) + PFailed{} -> Nothing + where + realSrcLc = mkRealSrcLoc (fsLit "") 0 0 + pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc + (wrap,str1) = case str0 of + '(' : s@(c : _) | c /= ',', c /= ')' -- rule out tuple names + -> (Parenthesized, init s) + '`' : s@(_ : _) -> (Backticked, init s) + _ -> (Unadorned, str0) diff --git a/html-test/ref/Bug952.html b/html-test/ref/Bug952.html new file mode 100644 index 00000000..bd301bcd --- /dev/null +++ b/html-test/ref/Bug952.html @@ -0,0 +1,76 @@ +Bug952
    Safe HaskellSafe-Inferred

    Bug952

    Synopsis

    Documentation

    foo :: () #

    See 'case', 'of', '--' compared to 'Q.case', 'Q.of', 'Q.--'

    diff --git a/html-test/src/Bug952.hs b/html-test/src/Bug952.hs new file mode 100644 index 00000000..09b365e4 --- /dev/null +++ b/html-test/src/Bug952.hs @@ -0,0 +1,5 @@ +module Bug952 where + +-- | See 'case', 'of', '--' compared to 'Q.case', 'Q.of', 'Q.--' +foo :: () +foo = () -- cgit v1.2.3 From e68cc0f05c102193660466d611640aec922bc9a9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 08:50:57 -0400 Subject: Remove unused `Haddock.Utils` functions * removed functions in `Haddock.Utils` that were not used anywhere (or exported from the `haddock-api` package) * moved GHC-specific utils from `Haddock.Utils` to `Haddock.GhcUtils` --- haddock-api/src/Haddock.hs | 1 + haddock-api/src/Haddock/Backends/Xhtml.hs | 4 + haddock-api/src/Haddock/GhcUtils.hs | 91 ++++++++++++++++++ haddock-api/src/Haddock/Interface.hs | 1 + haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-api/src/Haddock/Utils.hs | 150 +----------------------------- 6 files changed, 102 insertions(+), 147 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index cf7bd857..0b5e33a3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -42,6 +42,7 @@ import Haddock.Utils import Haddock.GhcUtils (modifySessionDynFlags, setOutputDir) import Control.Monad hiding (forM_) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 9add4cae..d30312b7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -294,6 +294,10 @@ ppHtmlContents dflags odir doctitle _maybe_package ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + where + -- Extract a module's short description. + toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) + toInstalledDescription = fmap mkMeta . hmi_description . instInfo ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 6577e08f..77d6ec39 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -20,9 +20,11 @@ module Haddock.GhcUtils where import Control.Arrow import Data.Char ( isSpace ) +import Data.Maybe ( mapMaybe ) import Haddock.Types( DocName, DocNameI ) +import BasicTypes ( PromotionFlag(..) ) import Exception import FV import Outputable ( Outputable, panic, showPpr ) @@ -253,6 +255,95 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" getGADTConTypeG (XConDecl nec) = noExtCon nec +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn +-- Dubious, because the implicit binders are empty even +-- though the type might have free varaiables +mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) + + +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn +-- Add the class context to a class-op signature +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) + -- The mkEmptySigWcType is suspicious + where + go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) + = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tvs, hst_body = go ty }) + go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) + go (L loc ty) + = L loc (HsQualTy { hst_xqual = noExtField + , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + + extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) + add_ctxt (L loc preds) = L loc (extra_pred : preds) + +addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine + +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] +lHsQTyVarsToTypes tvs + = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) + | tv <- hsQTvExplicit tvs ] + + +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- + + +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn +restrictTo names (L loc decl) = L loc $ case decl of + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), + tcdATs = restrictATs names (tcdATs d) }) + _ -> decl + +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn +restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) + | DataType <- new_or_data + = defn { dd_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { dd_ND = DataType, dd_cons = [] } + [con] -> defn { dd_cons = [con] } + _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" + +restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] +restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] + where + keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = + case con_args d of + PrefixCon _ -> Just d + RecCon fields + | all field_avail (unL fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + where + field_avail :: LConDeclField GhcRn -> Bool + field_avail (L _ (ConDeclField _ fs _ _)) + = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + field_avail (L _ (XConDeclField nec)) = noExtCon nec + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] + + keep _ = Nothing + +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) + + +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] +restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] + + ------------------------------------------------------------------------------- -- * Parenthesization ------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 24568235..6775cf2b 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -43,6 +43,7 @@ import Haddock.Types import Haddock.Utils import Control.Monad +import Control.Monad.IO.Class ( liftIO ) import Control.Exception (evaluate) import Data.List (foldl', isPrefixOf, nub) import qualified Data.Map as Map diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 17be6fa1..7b0f29f4 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -21,9 +21,9 @@ module Haddock.InterfaceFile ( import Haddock.Types -import Haddock.Utils hiding (out) import Control.Monad +import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Array import Data.IORef import Data.List (mapAccumR) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 3eb702c9..1d213420 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -13,15 +13,9 @@ ----------------------------------------------------------------------------- module Haddock.Utils ( - -- * Misc utilities - restrictTo, emptyHsQTvs, - toDescription, toInstalledDescription, - mkEmptySigWcType, addClassContext, lHsQTyVarsToTypes, - -- * Filename utilities moduleHtmlFile, moduleHtmlFile', contentsHtmlFile, indexHtmlFile, indexJsonFile, - moduleIndexFrameName, mainFrameName, synopsisFrameName, subIndexHtmlFile, haddockJsFile, jsQuickJumpFile, quickJumpCssFile, @@ -32,7 +26,7 @@ module Haddock.Utils ( makeAnchorId, -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + getProgramName, bye, die, escapeStr, writeUtf8File, withTempDir, -- * HTML cross reference mapping @@ -45,9 +39,6 @@ module Haddock.Utils ( replace, spanWith, - -- * MTL stuff - MonadIO(..), - -- * Logging parseVerbosity, Verbosity(..), silent, normal, verbose, deafening, out, @@ -61,23 +52,21 @@ import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types import Haddock.GhcUtils -import BasicTypes ( PromotionFlag(..) ) import Exception (ExceptionMonad) import GHC import Name -import Control.Monad ( liftM ) +import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) import Numeric ( showIntAtBase ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) -import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit import System.Directory ( createDirectory, removeDirectoryRecursive ) -import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) +import System.IO ( hPutStr, hSetEncoding, IOMode(..), utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -85,8 +74,6 @@ import qualified System.FilePath.Posix as HtmlPath import qualified System.Posix.Internals #endif -import MonadUtils ( MonadIO(..) ) - -------------------------------------------------------------------------------- -- * Logging @@ -129,117 +116,14 @@ out progVerbosity msgVerbosity msg -------------------------------------------------------------------------------- --- | Extract a module's short description. -toDescription :: Interface -> Maybe (MDoc Name) -toDescription = fmap mkMeta . hmi_description . ifaceInfo - - --- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name) -toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn --- Dubious, because the implicit binders are empty even --- though the type might have free varaiables -mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) - -addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn --- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) - = L pos (TypeSig noExtField lname (mkEmptySigWcType (go (hsSigType ltype)))) - -- The mkEmptySigWcType is suspicious - where - go (L loc (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField - , hst_bndrs = tvs, hst_body = go ty }) - go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt ctxt, hst_body = ty }) - go (L loc ty) - = L loc (HsQualTy { hst_xqual = noExtField - , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) - - extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) - add_ctxt (L loc preds) = L loc (extra_pred : preds) - -addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine - -lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] -lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) - | tv <- hsQTvExplicit tvs ] - --------------------------------------------------------------------------------- --- * Making abstract declarations --------------------------------------------------------------------------------- - - -restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn -restrictTo names (L loc decl) = L loc $ case decl of - TyClD x d | isDataDecl d -> - TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD x d | isClassDecl d -> - TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) - _ -> decl - -restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn -restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) - | DataType <- new_or_data - = defn { dd_cons = restrictCons names cons } - | otherwise -- Newtype - = case restrictCons names cons of - [] -> defn { dd_ND = DataType, dd_cons = [] } - [con] -> defn { dd_cons = [con] } - _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" - -restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case con_args d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField _ fs _ _)) - = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_avail (L _ (XConDeclField nec)) = noExtCon nec - field_types flds = [ t | ConDeclField _ _ t _ <- flds ] - - keep _ = Nothing - -restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) - - -restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] - -emptyHsQTvs :: LHsQTyVars GhcRn --- This function is here, rather than in HsTypes, because it *renamed*, but --- does not necessarily have all the rigt kind variables. It is used --- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_ext = error "haddock:emptyHsQTvs" - , hsq_explicit = [] } - - -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. -------------------------------------------------------------------------------- - baseName :: ModuleName -> FilePath baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString @@ -266,13 +150,6 @@ indexHtmlFile = "doc-index.html" indexJsonFile = "doc-index.json" - -moduleIndexFrameName, mainFrameName, synopsisFrameName :: String -moduleIndexFrameName = "modules" -mainFrameName = "main" -synopsisFrameName = "synopsis" - - subIndexHtmlFile :: String -> String subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" where b | all isAlpha ls = ls @@ -346,7 +223,7 @@ quickJumpCssFile = "quick-jump.css" getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName +getProgramName = fmap (`withoutSuffix` ".bin") getProgName where str `withoutSuffix` suff | suff `isSuffixOf` str = take (length str - length suff) str | otherwise = str @@ -355,25 +232,6 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a bye s = putStr s >> exitSuccess - -dieMsg :: String -> IO () -dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - - -noDieMsg :: String -> IO () -noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) - - -mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] -mapSnd _ [] = [] -mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs - - -mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = liftM Just (f a) - - escapeStr :: String -> String escapeStr = escapeURIString isUnreserved -- cgit v1.2.3 From 730a2163245cf7aaf389458113e6fa338eca7865 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 12:04:16 -0400 Subject: Use TTG empty extensions to remove some `error`'s None of these error cases should ever have been reachable, so this is just a matter of leveraging the type system to assert this. * Use the `NoExtCon` and `noExtCon` to handle case matches for no extension constructors, instead of throwing an `error`. * Use the extension field of `HsSpliceTy` to ensure that this variant of `HsType` cannot exist in an `HsType DocNameI`. --- haddock-api/src/Haddock/Backends/LaTeX.hs | 5 +++-- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 3 ++- haddock-api/src/Haddock/GhcUtils.hs | 15 +++++++-------- haddock-api/src/Haddock/Interface/Rename.hs | 4 ++-- haddock-api/src/Haddock/Interface/Specialize.hs | 17 +++++------------ haddock-api/src/Haddock/Types.hs | 3 ++- 6 files changed, 21 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 63b12a14..d52c136f 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -39,6 +39,7 @@ import Data.Char import Control.Monad import Data.Maybe import Data.List ( sort ) +import Data.Void ( absurd ) import Prelude hiding ((<>)) import Haddock.Doc (combineDocumentation) @@ -530,7 +531,7 @@ ppTyVars unicode = map (ppHsTyVarBndr unicode . unLoc) tyvarNames :: LHsQTyVars DocNameI -> [Name] -tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit +tyvarNames = map (getName . hsTyVarBndrName . unLoc) . hsQTvExplicit declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -1080,7 +1081,7 @@ ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) ppr_mono_ty (HsKindSig _ ty kind) u = ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u -ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ = absurd v ppr_mono_ty (HsRecTy {}) _ = text "{..}" ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty (HsExplicitListTy _ IsPromoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index b450dc94..25669ca7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -32,6 +32,7 @@ import Haddock.Doc (combineDocumentation) import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe +import Data.Void ( absurd ) import Text.XHtml hiding ( name, title, p, quote ) import BasicTypes (PromotionFlag(..), isPromoted) @@ -1215,7 +1216,7 @@ ppr_mono_ty (HsKindSig _ ty kind) u q e = ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts -ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsSpliceTy v _) _ _ _ = absurd v ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 77d6ec39..f600997a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -165,18 +165,17 @@ nubByName f ns = go emptyNameSet ns where y = f x + -- --------------------------------------------------------------------- -- These functions are duplicated from the GHC API, as they must be -- instantiated at DocNameI instead of (GhcPass _). -hsTyVarNameI :: HsTyVarBndr DocNameI -> DocName -hsTyVarNameI (UserTyVar _ (L _ n)) = n -hsTyVarNameI (KindedTyVar _ (L _ n) _) = n -hsTyVarNameI (XTyVarBndr nec) = noExtCon nec - -hsLTyVarNameI :: LHsTyVarBndr DocNameI -> DocName -hsLTyVarNameI = hsTyVarNameI . unLoc +-- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _) +hsTyVarBndrName :: (XXTyVarBndr n ~ NoExtCon) => HsTyVarBndr n -> IdP n +hsTyVarBndrName (UserTyVar _ name) = unLoc name +hsTyVarBndrName (KindedTyVar _ (L _ name) _) = name +hsTyVarBndrName (XTyVarBndr nec) = noExtCon nec getConNamesI :: ConDecl DocNameI -> [Located DocName] getConNamesI ConDeclH98 {con_name = name} = [name] @@ -311,7 +310,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" +restrictDataDefn _ (XHsDataDefn nec) = noExtCon nec restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0b122b07..ce3878b8 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -313,7 +313,7 @@ renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind ; return (L loc (KindedTyVar x (L lv n') kind')) } -renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" +renameLTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -512,7 +512,7 @@ renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel return $ L l (FieldOcc sel' lbl) -renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" +renameLFieldOcc (L _ (XFieldOcc nec)) = noExtCon nec renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 03cc1b7e..19b03596 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -9,6 +9,7 @@ module Haddock.Interface.Specialize ) where +import Haddock.GhcUtils ( hsTyVarBndrName ) import Haddock.Syb import Haddock.Types @@ -56,13 +57,9 @@ specialize specs = go spec_map0 -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn -specializeTyVarBndrs bndrs typs = - specialize $ zip bndrs' typs +specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where - bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar _ (L _ name)) = name - bname (KindedTyVar _ (L _ name) _) = name - bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + bndrs' = map (hsTyVarBndrName . unLoc) . hsq_explicit $ bndrs @@ -212,7 +209,7 @@ freeVariables = | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) - bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) + bndrsNames = Set.fromList . map (getName . hsTyVarBndrName . unLoc) -- | Make given type visually unambiguous. @@ -295,7 +292,7 @@ renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname renameBinder (KindedTyVar x lname lkind) = KindedTyVar x <$> located renameName lname <*> located renameType lkind -renameBinder (XTyVarBndr _) = error "haddock:renameBinder" +renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -349,7 +346,3 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b) located f (L loc e) = L loc <$> f e -tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar _ name) = unLoc name -tyVarName (KindedTyVar _ (L _ name) _) = name -tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 28e3caed..ec76fb72 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -35,6 +35,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Typeable (Typeable) import Data.Map (Map) import Data.Data (Data) +import Data.Void (Void) import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) @@ -713,7 +714,7 @@ type instance XOpTy DocNameI = NoExtField type instance XParTy DocNameI = NoExtField type instance XIParamTy DocNameI = NoExtField type instance XKindSig DocNameI = NoExtField -type instance XSpliceTy DocNameI = NoExtField +type instance XSpliceTy DocNameI = Void -- see `renameHsSpliceTy` type instance XDocTy DocNameI = NoExtField type instance XBangTy DocNameI = NoExtField type instance XRecTy DocNameI = NoExtField -- cgit v1.2.3 From b33e4bebce0fb98acfc2c1f5efc370e95a061c86 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 12:28:48 -0400 Subject: Use `unLoc`/`noLoc` from GHC instead of `unL`/`reL` * `unL` is already defined by GHC as `unLoc` * `reL` is already defined by GHC as `noLoc` (in a safer way too!) * Condense `setOutputDir` and add a about exporting from GHC Fixes #978 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 24 ++++++------ haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +- haddock-api/src/Haddock/GhcUtils.hs | 53 ++++++++++---------------- haddock-api/src/Haddock/Interface/Create.hs | 18 ++++----- 5 files changed, 44 insertions(+), 57 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index b4a605f2..63acb465 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -82,7 +82,7 @@ dropHsDocTy = f f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) f (HsParTy x a) = HsParTy x (g a) f (HsKindSig x a b) = HsKindSig x (g a) b - f (HsDocTy _ a _) = f $ unL a + f (HsDocTy _ a _) = f $ unLoc a f x = x outHsType :: (OutputableBndrId p) @@ -215,7 +215,7 @@ ppSynonym dflags x = [out dflags x] 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) + concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn) where -- GHC gives out "data Bar =", we want to delete the equals. @@ -244,22 +244,22 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y) - apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) + funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y) + apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds) -- We print the constructors as comma-separated list. See GHC -- docs for con_names on why it is a list to begin with. - name = commaSeparate dflags . map unL $ getConNames con + name = commaSeparate dflags . map unLoc $ getConNames con - resType = let c = HsTyVar noExtField NotPromoted (reL (tcdName dat)) + resType = let c = HsTyVar noExtField NotPromoted (noLoc (tcdName dat)) as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat) - in apps (map reL (c : as)) + in apps (map noLoc (c : as)) tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k + tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec ppCtor dflags _dat subdocs con@(ConDeclGADT { }) @@ -267,8 +267,8 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) where f = [typeSig name (getGADTConTypeG con)] - typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) - name = out dflags $ map unL $ getConNames con + typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty) + name = out dflags $ map unLoc $ getConNames con ppCtor _ _ _ (XConDecl nec) = noExtCon nec ppFixity :: DynFlags -> (Name, Fixity) -> [String] @@ -298,7 +298,7 @@ docWith dflags header d mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s where - getDoc = maybe [] (return . fst) (lookup (unL n) subdocs) + getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String deriving Show diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d52c136f..647812f9 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -624,7 +624,7 @@ ppClassDecl instances doc subdocs text "\\haddockpremethods{}" <> emph (text "Associated Types") $$ vcat [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True | L _ decl <- ats - , let name = unL . fdLName $ decl + , let name = unLoc . fdLName $ decl doc = lookupAnySubdoc name subdocs ] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 25669ca7..ef0ba1b6 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -492,7 +492,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t +++ shortSubDecls False ( [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats - , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ + , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ] ++ -- ToDo: add associated type defaults @@ -544,7 +544,7 @@ ppClassDecl summary links instances fixities loc d subdocs <+> subDefaults (maybeToList defTys) | at <- ats - , let name = unL . fdLName $ unL at + , let name = unLoc . fdLName $ unLoc at doc = lookupAnySubdoc name subdocs subfixs = filter ((== name) . fst) fixities defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index f600997a..923516b6 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -319,8 +319,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] case con_args d of PrefixCon _ -> Just d RecCon fields - | all field_avail (unL fields) -> Just d - | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) + | all field_avail (unLoc fields) -> Just d + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but @@ -340,7 +340,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] +restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ] ------------------------------------------------------------------------------- @@ -443,18 +443,6 @@ reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField c@XConDeclField{} = c -------------------------------------------------------------------------------- --- * Located -------------------------------------------------------------------------------- - - -unL :: Located a -> a -unL (L _ x) = x - - -reL :: a -> Located a -reL = L undefined - ------------------------------------------------------------------------------- -- * NamedThing instances ------------------------------------------------------------------------------- @@ -475,17 +463,17 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = case con_args con of - RecCon fields -> map (extFieldOcc . unL) $ - concatMap (cd_fld_names . unL) (unL fields) + RecCon fields -> map (extFieldOcc . unLoc) $ + concatMap (cd_fld_names . unLoc) (unLoc fields) _ -> [] instance Parent (TyClDecl GhcRn) where children d - | isDataDecl d = map unL $ concatMap (getConNames . unL) + | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc) $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = - map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] + map (unLoc . fdLName . unLoc) (tcdATs d) ++ + [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -495,13 +483,13 @@ family = getName &&& children familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] -familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) +familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. families :: TyClDecl GhcRn -> [(Name, [Name])] families d - | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) + | isDataDecl d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] @@ -546,17 +534,16 @@ minimalDef n = do -- * DynFlags ------------------------------------------------------------------------------- - -setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags -setObjectDir f d = d{ objectDir = Just f} -setHiDir f d = d{ hiDir = Just f} -setHieDir f d = d{ hieDir = Just f} -setStubDir f d = d{ stubDir = Just f - , includePaths = addGlobalInclude (includePaths d) [f] } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. -setOutputDir f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f - +-- TODO: use `setOutputDir` from GHC +setOutputDir :: FilePath -> DynFlags -> DynFlags +setOutputDir dir dynFlags = + dynFlags { objectDir = Just dir + , hiDir = Just dir + , hieDir = Just dir + , stubDir = Just dir + , includePaths = addGlobalInclude (includePaths dynFlags) [dir] + , dumpDir = Just dir + } ------------------------------------------------------------------------------- -- * 'StringBuffer' and 'ByteString' diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index b182a615..af006d03 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -461,14 +461,14 @@ subordinates instMap decl = case decl of dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where - cons = map unL $ (dd_cons dd) - constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c) + cons = map unLoc $ (dd_cons dd) + constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ] - fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) + fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] - derivs = [ (instName, [unL doc], M.empty) + derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd @@ -585,13 +585,13 @@ sortByLoc = sortBy (comparing getLoc) -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unL . fst) +filterDecls = filter (isHandled . unLoc . fst) where isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True - isHandled (SigD _ d) = isUserLSig (reL d) + isHandled (SigD _ d) = isUserLSig (noLoc d) isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs isHandled (DocD {}) = True @@ -677,7 +677,7 @@ mkExportItems return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $ - findNamedDoc str [ unL d | d <- decls ] >>= \case + findNamedDoc str [ unLoc d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr @@ -725,13 +725,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unL decl) + let declNames = getMainDeclBinder (unLoc decl) in case () of _ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, - Just p <- find isExported (parents t $ unL decl) -> + Just p <- find isExported (parents t $ unLoc decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty dflags (nameOccName t) ++ " is exported separately but " ++ -- cgit v1.2.3 From 8edc70fef3f3a54238d981153a6ac42b2d7f0bde Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 13:12:50 -0400 Subject: Cleanup up GHC flags in `.cabal` files * enable more useful warning flags in `haddock-api`, handle the new warnings generated * remove `-fwarn-tabs` (now we'd use `-Wtabs`, but this has been in `-Wall` for a while now) --- haddock-api/haddock-api.cabal | 12 ++++++++---- haddock-api/src/Haddock/Interface/Specialize.hs | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock-library/haddock-library.cabal | 2 +- haddock.cabal | 2 +- 5 files changed, 12 insertions(+), 8 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 54255e09..4abfd984 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -63,10 +63,14 @@ library hs-source-dirs: src - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 - ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances + ghc-options: -funbox-strict-fields -O2 + -Wall + -Wcompat + -Widentities + -Wredundant-constraints + -Wnoncanonical-monad-instances + -Wmissing-home-modules + exposed-modules: Documentation.Haddock diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 19b03596..492818bd 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -295,7 +295,7 @@ renameBinder (KindedTyVar x lname lkind) = renameBinder (XTyVarBndr nec) = noExtCon nec -- | Core renaming logic. -renameName :: (Eq name, SetName name) => name -> Rename name name +renameName :: SetName name => name -> Rename name name renameName name = do RenameEnv { .. } <- get case Map.lookup (getName name) rneCtx of diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 7b0f29f4..cb60fb00 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -158,7 +158,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m +nameCacheFromGhc :: GhcMonad m => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 1a06d0e5..24ca920f 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -44,7 +44,7 @@ common lib-defaults , text ^>= 1.2.3.0 , parsec ^>= 3.1.13.0 - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs + ghc-options: -funbox-strict-fields -Wall if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances diff --git a/haddock.cabal b/haddock.cabal index f01fe8fc..1d6ad180 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -62,7 +62,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 -threaded + ghc-options: -funbox-strict-fields -Wall -O2 -threaded -- haddock typically only supports a single GHC major version build-depends: -- cgit v1.2.3 From d8bedeb98a84db0d51c49d41c632d9d4846d1bbe Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 13:17:35 -0400 Subject: `haddock-library` document header level Document the fact the header level is going to always be between 1 and 6 inclusive. Along the way, I also optimized the parsing code a bit. --- haddock-library/src/Documentation/Haddock/Parser.hs | 8 ++++---- haddock-library/src/Documentation/Haddock/Types.hs | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 17240792..149ff93d 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -512,11 +512,11 @@ since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince header :: Parser (DocH mod Identifier) header = do let psers = map (string . flip T.replicate "=") [6, 5 .. 1] - pser = choice' psers - delim <- T.unpack <$> pser - line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText + pser = Parsec.choice psers + depth <- T.length <$> pser + line <- parseText <$> (skipHorizontalSpace *> nonEmptyLine) rest <- try paragraph <|> return DocEmpty - return $ DocHeader (Header (length delim) line) `docAppend` rest + return $ DocHeader (Header depth line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier) textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index 4cf61fee..d8c7a9fa 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -79,7 +79,7 @@ data Picture = Picture } deriving (Eq, Show) data Header id = Header - { headerLevel :: Int + { headerLevel :: Int -- ^ between 1 and 6 inclusive , headerTitle :: id } deriving (Eq, Show, Functor, Foldable, Traversable) -- cgit v1.2.3 From 5dc3866928759fcaf6b31d1598051781389a01d4 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 28 Mar 2020 14:12:48 -0400 Subject: Disallow links in section headers This is quite straightforward to implement, since we already had a function `docToHtmlNoAnchors` (which we used to generate the link in the sidebar "Contents"). This breaks test `Bug387`, but that test case has aged badly: we now automatically generate anchors for all headings, so manually adding an anchor in a section makes no sense. Nested anchors are, as pointed out in #1054, disallowed by the HTML standard. Fixes #1054 --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- html-test/ref/Bug1054.html | 90 +++++++++++++++++++++++ html-test/ref/Bug387.html | 118 ------------------------------ html-test/src/Bug1054.hs | 5 ++ html-test/src/Bug387.hs | 12 --- 5 files changed, 96 insertions(+), 131 deletions(-) create mode 100644 html-test/ref/Bug1054.html delete mode 100644 html-test/ref/Bug387.html create mode 100644 html-test/src/Bug1054.hs delete mode 100644 html-test/src/Bug387.hs diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d30312b7..e3d4e8ca 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -681,7 +681,7 @@ processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) + = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual processExport summary _ _ _ qual (ExportNoDecl y []) diff --git a/html-test/ref/Bug1054.html b/html-test/ref/Bug1054.html new file mode 100644 index 00000000..df3fae0a --- /dev/null +++ b/html-test/ref/Bug1054.html @@ -0,0 +1,90 @@ +Bug1054
    Safe HaskellSafe-Inferred

    Bug1054

    Synopsis
    diff --git a/html-test/ref/Bug387.html b/html-test/ref/Bug387.html deleted file mode 100644 index 12887a83..00000000 --- a/html-test/ref/Bug387.html +++ /dev/null @@ -1,118 +0,0 @@ -Bug387
    Safe HaskellSafe-Inferred

    Bug387

    Synopsis
    diff --git a/html-test/src/Bug1054.hs b/html-test/src/Bug1054.hs new file mode 100644 index 00000000..c699f1fb --- /dev/null +++ b/html-test/src/Bug1054.hs @@ -0,0 +1,5 @@ +module Bug1054 where + +-- * Header with 'foo' link + +foo = () diff --git a/html-test/src/Bug387.hs b/html-test/src/Bug387.hs deleted file mode 100644 index d9fed34e..00000000 --- a/html-test/src/Bug387.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Bug387 - ( -- * Section1#a:section1# - test1 - -- * Section2#a:section2# - , test2 - ) where - -test1 :: Int -test1 = 223 - -test2 :: Int -test2 = 42 -- cgit v1.2.3 From 5d034ee2ed72839a8472dba59f83b1b348691cc5 Mon Sep 17 00:00:00 2001 From: Felix Yan Date: Thu, 2 Apr 2020 04:43:40 +0800 Subject: Allow QuickCheck 2.14 Builds fine and all tests pass. --- haddock-library/haddock-library.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index 24ca920f..9e707f1b 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -87,7 +87,7 @@ test-suite spec build-depends: , base-compat ^>= 0.9.3 || ^>= 0.11.0 - , QuickCheck ^>= 2.11 || ^>= 2.13.2 + , QuickCheck ^>= 2.11 || ^>= 2.13.2 || ^>= 2.14 , deepseq ^>= 1.3.0.0 || ^>= 1.4.0.0 -- NB: build-depends & build-tool-depends have independent -- cgit v1.2.3 From 87fbc11227347da805a3d2158d462514438ca742 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Sun, 5 Apr 2020 11:48:39 -0400 Subject: Fix #1050 by filtering out invisible AppTy arguments This makes the `synifyType` case for `AppTy` more intelligent by taking into consideration the visibilities of each `AppTy` argument and filtering out any invisible arguments, as they aren't intended to be displayed in the source code. (See #1050 for an example of what can happen if you fail to filter these out.) Along the way, I noticed that a special `synifyType` case for `AppTy t1 (CoercionTy {})` could be consolidated with the case below it, so I took the opportunity to tidy this up. --- haddock-api/src/Haddock/Convert.hs | 13 +++-- html-test/ref/Bug1050.html | 110 +++++++++++++++++++++++++++++++++++++ html-test/src/Bug1050.hs | 11 ++++ 3 files changed, 129 insertions(+), 5 deletions(-) create mode 100644 html-test/ref/Bug1050.html create mode 100644 html-test/src/Bug1050.hs diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index d5fa3667..1a1e95bd 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -612,11 +612,14 @@ synifyType _ vs (TyConApp tc tys) in noLoc $ HsKindSig noExtField ty' full_kind' | otherwise = ty' -synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 -synifyType _ vs (AppTy t1 t2) = let - s1 = synifyType WithinType vs t1 - s2 = synifyType WithinType vs t2 - in noLoc $ HsAppTy noExtField s1 s2 +synifyType _ vs ty@(AppTy {}) = let + (ty_head, ty_args) = splitAppTys ty + ty_head' = synifyType WithinType vs ty_head + ty_args' = map (synifyType WithinType vs) $ + filterOut isCoercionTy $ + filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) + ty_args + in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' synifyType s vs funty@(FunTy InvisArg _ _) = synifyForAllType s Inferred vs funty synifyType _ vs (FunTy VisArg t1 t2) = let s1 = synifyType WithinType vs t1 diff --git a/html-test/ref/Bug1050.html b/html-test/ref/Bug1050.html new file mode 100644 index 00000000..2d938656 --- /dev/null +++ b/html-test/ref/Bug1050.html @@ -0,0 +1,110 @@ +Bug1050
    Safe HaskellSafe-Inferred

    Bug1050

    Documentation

    newtype T :: (forall k. k -> Type) -> forall k. k -> Type where #

    Constructors

    MkT :: forall (f :: forall k. k -> Type) k (a :: k). f a -> T f a 

    mkT :: forall k (f :: forall k1. k1 -> Type) (a :: k). f a -> T f a #

    diff --git a/html-test/src/Bug1050.hs b/html-test/src/Bug1050.hs new file mode 100644 index 00000000..ea293e6e --- /dev/null +++ b/html-test/src/Bug1050.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +module Bug1050 where + +import Data.Kind + +newtype T :: (forall k. k -> Type) -> (forall k. k -> Type) where + MkT :: forall (f :: forall k. k -> Type) k (a :: k). f a -> T f a + +mkT = MkT -- cgit v1.2.3 From d8aaaba9414b149fa7941d364b6d4a3fbcc1a520 Mon Sep 17 00:00:00 2001 From: Ignat Insarov Date: Fri, 10 Apr 2020 04:15:01 +0300 Subject: Recode Doc to Json. (#1159) * Recode Doc to Json. * More descriptive field labels. --- haddock-api/src/Haddock/Interface/Json.hs | 167 +++++++++++++++++++++++++++++- 1 file changed, 162 insertions(+), 5 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index a9834fa0..2cacabe1 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -13,7 +13,6 @@ import Outputable import Control.Arrow import Data.Map (Map) -import Data.Bifunctor import qualified Data.Map as Map import Haddock.Types @@ -58,14 +57,172 @@ 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) + , ("document", jsonDoc _doc) ] +showModName :: Wrap (ModuleName, OccName) -> String +showModName = showWrapped (moduleNameString . fst) + +showName :: Wrap Name -> String +showName = showWrapped nameStableString + + jsonDoc :: Doc Name -> JsonDoc -jsonDoc doc = jsonString (show (bimap showModName showName doc)) + +jsonDoc DocEmpty = jsonObject + [ ("tag", jsonString "DocEmpty") ] + +jsonDoc (DocAppend x y) = jsonObject + [ ("tag", jsonString "DocAppend") + , ("first", jsonDoc x) + , ("second", jsonDoc y) + ] + +jsonDoc (DocString s) = jsonObject + [ ("tag", jsonString "DocString") + , ("string", jsonString s) + ] + +jsonDoc (DocParagraph x) = jsonObject + [ ("tag", jsonString "DocParagraph") + , ("document", jsonDoc x) + ] + +jsonDoc (DocIdentifier name) = jsonObject + [ ("tag", jsonString "DocIdentifier") + , ("name", jsonString (showName name)) + ] + +jsonDoc (DocIdentifierUnchecked modName) = jsonObject + [ ("tag", jsonString "DocIdentifierUnchecked") + , ("modName", jsonString (showModName modName)) + ] + +jsonDoc (DocModule s) = jsonObject + [ ("tag", jsonString "DocModule") + , ("string", jsonString s) + ] + +jsonDoc (DocWarning x) = jsonObject + [ ("tag", jsonString "DocWarning") + , ("document", jsonDoc x) + ] + +jsonDoc (DocEmphasis x) = jsonObject + [ ("tag", jsonString "DocEmphasis") + , ("document", jsonDoc x) + ] + +jsonDoc (DocMonospaced x) = jsonObject + [ ("tag", jsonString "DocMonospaced") + , ("document", jsonDoc x) + ] + +jsonDoc (DocBold x) = jsonObject + [ ("tag", jsonString "DocBold") + , ("document", jsonDoc x) + ] + +jsonDoc (DocUnorderedList xs) = jsonObject + [ ("tag", jsonString "DocUnorderedList") + , ("documents", jsonArray (fmap jsonDoc xs)) + ] + +jsonDoc (DocOrderedList xs) = jsonObject + [ ("tag", jsonString "DocOrderedList") + , ("documents", jsonArray (fmap jsonDoc xs)) + ] + +jsonDoc (DocDefList xys) = jsonObject + [ ("tag", jsonString "DocDefList") + , ("definitions", jsonArray (fmap jsonDef xys)) + ] where - showModName = showWrapped (moduleNameString . fst) - showName = showWrapped nameStableString + jsonDef (x, y) = jsonObject [("document", jsonDoc x), ("y", jsonDoc y)] + +jsonDoc (DocCodeBlock x) = jsonObject + [ ("tag", jsonString "DocCodeBlock") + , ("document", jsonDoc x) + ] + +jsonDoc (DocHyperlink hyperlink) = jsonObject + [ ("tag", jsonString "DocHyperlink") + , ("hyperlink", jsonHyperlink hyperlink) + ] + where + jsonHyperlink Hyperlink{..} = jsonObject + [ ("hyperlinkUrl", jsonString hyperlinkUrl) + , ("hyperlinkLabel", jsonMaybe jsonDoc hyperlinkLabel) + ] + +jsonDoc (DocPic picture) = jsonObject + [ ("tag", jsonString "DocPic") + , ("picture", jsonPicture picture) + ] + where + jsonPicture Picture{..} = jsonObject + [ ("pictureUrl", jsonString pictureUri) + , ("pictureLabel", jsonMaybe jsonString pictureTitle) + ] + +jsonDoc (DocMathInline s) = jsonObject + [ ("tag", jsonString "DocMathInline") + , ("string", jsonString s) + ] + +jsonDoc (DocMathDisplay s) = jsonObject + [ ("tag", jsonString "DocMathDisplay") + , ("string", jsonString s) + ] + +jsonDoc (DocAName s) = jsonObject + [ ("tag", jsonString "DocAName") + , ("string", jsonString s) + ] + +jsonDoc (DocProperty s) = jsonObject + [ ("tag", jsonString "DocProperty") + , ("string", jsonString s) + ] + +jsonDoc (DocExamples examples) = jsonObject + [ ("tag", jsonString "DocExamples") + , ("examples", jsonArray (fmap jsonExample examples)) + ] + where + jsonExample Example{..} = jsonObject + [ ("exampleExpression", jsonString exampleExpression) + , ("exampleResult", jsonArray (fmap jsonString exampleResult)) + ] + +jsonDoc (DocHeader header) = jsonObject + [ ("tag", jsonString "DocHeader") + , ("header", jsonHeader header) + ] + where + jsonHeader Header{..} = jsonObject + [ ("headerLevel", jsonInt headerLevel) + , ("headerTitle", jsonDoc headerTitle) + ] + +jsonDoc (DocTable table) = jsonObject + [ ("tag", jsonString "DocTable") + , ("table", jsonTable table) + ] + where + jsonTable Table{..} = jsonObject + [ ("tableHeaderRows", jsonArray (fmap jsonTableRow tableHeaderRows)) + , ("tableBodyRows", jsonArray (fmap jsonTableRow tableBodyRows)) + ] + + jsonTableRow TableRow{..} = jsonArray (fmap jsonTableCell tableRowCells) + + jsonTableCell TableCell{..} = jsonObject + [ ("tableCellColspan", jsonInt tableCellColspan) + , ("tableCellRowspan", jsonInt tableCellRowspan) + , ("tableCellContents", jsonDoc tableCellContents) + ] + jsonModule :: Module -> JsonDoc jsonModule = JSString . moduleStableString -- cgit v1.2.3 From 8d83110789def9207463a035fa766b78ebf5fdd9 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 15 Apr 2020 09:21:09 -0400 Subject: Prune docstrings that are never rendered When first creating a Haddock interface, trim `ifaceDocMap` and `ifaceArgMap` to not include docstrings that can never appear in the final output. Besides checking with GHC which names are exported, we also need to keep all the docs attached to instance declarations (it is much tougher to detect when an instance is fully private). This change means: * slightly smaller interface files (7% reduction on boot libs) * slightly less work to do processing docstrings that aren't used * no warnings in Haddock's output about private docstrings (see #1070) I've tested manually that this does not affect any of the boot library generated docs (the only change in output was some small re-ordering in a handful of instance lists). This should mean no docstrings have been incorrectly dropped. --- haddock-api/src/Haddock/Interface/Create.hs | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index af006d03..f29f576e 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -31,6 +31,7 @@ import Haddock.Interface.LexParseRn import Data.Bifunctor import Data.Bitraversable import qualified Data.Map as M +import qualified Data.Set as S import Data.Map (Map) import Data.List (find, foldl', sortBy) import Data.Maybe @@ -165,6 +166,18 @@ createInterface tm flags modMap instIfaceMap = do modWarn <- liftErrMsg (moduleWarning dflags gre warnings) + -- Prune the docstring 'Map's to keep only docstrings that are not private. + -- + -- Besides all the names that GHC has told us this module exports, we also + -- keep the docs for locally defined class instances. This is more names than + -- we need, but figuring out which instances are fully private is tricky. + -- + -- We do this pruning to avoid having to rename, emit warnings, and save + -- docstrings which will anyways never be rendered. + let !localVisibleNames = S.fromList (localInsts ++ exportedNames) + !prunedDocMap = M.restrictKeys docMap localVisibleNames + !prunedArgMap = M.restrictKeys argMap localVisibleNames + return $! Interface { ifaceMod = mdl , ifaceIsSig = is_sig @@ -173,8 +186,8 @@ createInterface tm flags modMap instIfaceMap = do , ifaceDoc = Documentation mbDoc modWarn , ifaceRnDoc = Documentation Nothing Nothing , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap + , ifaceDocMap = prunedDocMap + , ifaceArgMap = prunedArgMap , ifaceRnDocMap = M.empty , ifaceRnArgMap = M.empty , ifaceExportItems = prunedExportItems -- cgit v1.2.3 From 83f0fa0b6218c34898337bf41072ee5fedec1bde Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 15 Apr 2020 09:56:55 -0400 Subject: Don't warn about missing links in miminal sigs When renaming the Haddock interface, never emit warnings when renaming a minimal signature. Also added some documention around `renameInterface`. Minimal signatures intentionally include references to potentially un-exported methods (see the discussion in #330), so it is expected that they will not always have a link destination. On the principle that warnings should always be resolvable, this shouldn't produce a warning. See #1070. --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 15 ++++++++++++++- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index f29f576e..0f24afaa 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -188,10 +188,10 @@ createInterface tm flags modMap instIfaceMap = do , ifaceOptions = opts , ifaceDocMap = prunedDocMap , ifaceArgMap = prunedArgMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty + , ifaceRnDocMap = M.empty -- Filled in `renameInterface` + , ifaceRnArgMap = M.empty -- Filled in `renameInterface` , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] + , ifaceRnExportItems = [] -- Filled in `renameInterface` , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index ce3878b8..97f128d7 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -31,6 +31,14 @@ import Control.Monad hiding (mapM) import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) +-- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to +-- 'DocName'. +-- +-- What this really boils down to is: for each 'Name', figure out which of the +-- modules that export the name is the preferred place to link to. +-- +-- The renamed output gets written into fields in the Haddock interface record +-- that were previously left empty. renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface renameInterface dflags renamingEnv warnings iface = @@ -128,6 +136,11 @@ lookupRn name = RnM $ \lkp -> (False,maps_to) -> (maps_to, (name :)) (True, maps_to) -> (maps_to, id) +-- | Look up a 'Name' in the renaming environment, but don't warn if you don't +-- find the name. Prefer to use 'lookupRn' whenever possible. +lookupRnNoWarn :: Name -> RnM DocName +lookupRnNoWarn name = RnM $ \lkp -> (snd (lkp name), id) + -- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. -- Returns the renamed value along with a list of `Name`'s that could not be -- renamed because they weren't in the environment. @@ -532,7 +545,7 @@ renameSig sig = case sig of lnames' <- mapM renameL lnames return $ FixSig noExtField (FixitySig noExtField lnames' fixity) MinimalSig _ src (L l s) -> do - s' <- traverse renameL s + s' <- traverse (traverse lookupRnNoWarn) s return $ MinimalSig noExtField src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" -- cgit v1.2.3 From 5bc5016a14bc872a8315cddc629f8171a9ccd62e Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 21 Apr 2020 10:53:28 -0400 Subject: Fallback to `hiDecl` when `extractDecl` fails Sometimes, the declaration being exported is a subdecl (for instance, a record accessor getting exported at the top-level). For these cases, Haddock has to find a way to produce some synthetic sensible top-level declaration. This is done with `extractDecl`. As is shown by #1067, this is sometimes impossible to do just at a syntactic level (for instance when the subdecl is re-exported). In these cases, the only sensible thing to do is to try to reify a declaration based on a GHC `TyThing` via `hiDecl`. --- haddock-api/src/Haddock/Interface/Create.hs | 114 +++++++++++++++++----------- html-test/ref/Bug1067A.html | 114 ++++++++++++++++++++++++++++ html-test/ref/Bug1067B.html | 84 ++++++++++++++++++++ html-test/src/Bug1067A.hs | 9 +++ html-test/src/Bug1067B.hs | 4 + 5 files changed, 280 insertions(+), 45 deletions(-) create mode 100644 html-test/ref/Bug1067A.html create mode 100644 html-test/ref/Bug1067B.html create mode 100644 html-test/src/Bug1067A.hs create mode 100644 html-test/src/Bug1067B.hs diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 0f24afaa..5a58e1ac 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -793,11 +793,24 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames _ -> return [] + -- Tries 'extractDecl' first then falls back to 'hiDecl' if that fails + availDecl :: Name -> LHsDecl GhcRn -> ErrMsgGhc (LHsDecl GhcRn) + availDecl declName parentDecl = + case extractDecl declMap declName parentDecl of + Right d -> pure d + Left err -> do + synifiedDeclOpt <- hiDecl dflags declName + case synifiedDeclOpt of + Just synifiedDecl -> pure synifiedDecl + Nothing -> O.pprPanic "availExportItem" (O.text err) + availExportDecl :: AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) | availExportsDecl avail = do + extractedDecl <- availDecl (availName avail) decl + -- bundled pattern synonyms only make sense if the declaration is -- exported (otherwise there would be nothing to bundle to) bundledPatSyns <- findBundledPatterns avail @@ -813,8 +826,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames ] return [ ExportDecl { - expItemDecl = restrictTo (fmap fst subs) - (extractDecl declMap (availName avail) decl) + expItemDecl = restrictTo (fmap fst subs) extractedDecl , expItemPats = bundledPatSyns , expItemMbDoc = doc , expItemSubDocs = subs @@ -824,18 +836,18 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames } ] - | otherwise = - return [ ExportDecl { - expItemDecl = extractDecl declMap sub decl + | otherwise = for subs $ \(sub, sub_doc) -> do + extractedDecl <- availDecl sub decl + + return ( ExportDecl { + expItemDecl = extractedDecl , 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 @@ -910,6 +922,7 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m +-- | Reify a declaration from the GHC internal 'TyThing' representation. hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t @@ -1053,20 +1066,30 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam 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 :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +-- +-- This function looks through the declarations in this module to try to find +-- the one with the right name. +extractDecl + :: DeclMap -- ^ all declarations in the file + -> Name -- ^ name of the declaration to extract + -> LHsDecl GhcRn -- ^ parent declaration + -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl - | name `elem` getMainDeclBinder (unLoc decl) = decl + | name `elem` getMainDeclBinder (unLoc decl) = pure decl | otherwise = case unLoc decl of - TyClD _ d@ClassDecl {} -> + TyClD _ d@ClassDecl { tcdLName = L _ clsNm + , tcdSigs = clsSigs + , tcdATs = clsATs } -> let matchesMethod = [ lsig - | lsig <- tcdSigs d + | lsig <- clsSigs , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig @@ -1074,51 +1097,54 @@ extractDecl declMap name decl matchesAssociatedType = [ lfam_decl - | lfam_decl <- tcdATs d + | lfam_decl <- clsATs , name == unLoc (fdLName (unLoc lfam_decl)) ] -- TODO: document fixity 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 noExtField sig) - (_, [L pos fam_decl]) -> L pos (TyClD noExtField (FamDecl noExtField fam_decl)) + ([s0], _) -> let tyvar_names = tyClDeclTyVars d + L pos sig = addClassContext clsNm tyvar_names s0 + in pure (L pos (SigD noExtField sig)) + (_, [L pos fam_decl]) -> pure (L pos (TyClD noExtField (FamDecl noExtField fam_decl))) ([], []) | Just (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 matchesMethod O.<+> O.ppr matchesAssociatedType)) - TyClD _ d@DataDecl {} -> - let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) - in if isDataConName name - then SigD noExtField <$> extractPatternSyn name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) - else SigD noExtField <$> extractRecSel name n (map HsValArg tyvar_tys) (dd_cons (tcdDataDefn d)) + _ -> Left (concat [ "Ambiguous decl for ", getOccString name + , " in class ", getOccString clsNm ]) + + TyClD _ d@DataDecl { tcdLName = L _ dataNm + , tcdDataDefn = HsDataDefn { dd_cons = dataCons } } -> do + let ty_args = map HsValArg (lHsQTyVarsToTypes (tyClDeclTyVars d)) + lsig <- if isDataConName name + then extractPatternSyn name dataNm ty_args dataCons + else extractRecSel name dataNm ty_args dataCons + pure (SigD noExtField <$> lsig) + 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 }}))) -> - if isDataConName name - then SigD noExtField <$> extractPatternSyn name n tys (dd_cons defn) - else SigD noExtField <$> extractRecSel name n tys (dd_cons defn) + FamEqn { feqn_tycon = L _ famName + , feqn_pats = ty_args + , feqn_rhs = HsDataDefn { dd_cons = dataCons } }}))) -> do + lsig <- if isDataConName name + then extractPatternSyn name famName ty_args dataCons + else extractRecSel name famName ty_args dataCons + pure (SigD noExtField <$> lsig) InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = - FamEqn { feqn_rhs = dd + FamEqn { feqn_rhs = HsDataDefn { dd_cons = dataCons } } })) <- insts - , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) + , name `elem` map unLoc (concatMap (getConNames . unLoc) dataCons) ] in case matches of [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) - _ -> error "internal: extractDecl (ClsInstD)" + _ -> Left "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts @@ -1130,16 +1156,14 @@ extractDecl declMap name decl ] in case matches of [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) - _ -> error "internal: extractDecl (ClsInstD)" - _ -> O.pprPanic "extractDecl" $ - O.text "Unhandled decl for" O.<+> O.ppr name O.<> O.text ":" - O.$$ O.nest 4 (O.ppr decl) + _ -> Left "internal: extractDecl (ClsInstD)" + _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn +extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> error "extractPatternSyn: constructor pattern not found" - con:_ -> extract <$> con + [] -> Left "extractPatternSyn: constructor pattern not found" + con:_ -> pure (extract <$> con) where matches :: LConDecl GhcRn -> Bool matches (L _ con) = nm `elem` (unLoc <$> getConNames con) @@ -1170,13 +1194,13 @@ extractPatternSyn nm t tvs cons = mkAppTyArg f (HsArgPar _) = HsParTy noExtField f extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] - -> LSig GhcRn -extractRecSel _ _ _ [] = error "extractRecSel: selector not found" + -> Either ErrMsg (LSig GhcRn) +extractRecSel _ _ _ [] = Left "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty))))) + pure (L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/html-test/ref/Bug1067A.html b/html-test/ref/Bug1067A.html new file mode 100644 index 00000000..96b8d495 --- /dev/null +++ b/html-test/ref/Bug1067A.html @@ -0,0 +1,114 @@ +Bug1067A
    Safe HaskellSafe-Inferred

    Bug1067A

    Synopsis

    Documentation

    data Foo where #

    A foo

    Bundled Patterns

    pattern P :: Foo

    A pattern

    diff --git a/html-test/ref/Bug1067B.html b/html-test/ref/Bug1067B.html new file mode 100644 index 00000000..f3bf821a --- /dev/null +++ b/html-test/ref/Bug1067B.html @@ -0,0 +1,84 @@ +Bug1067B
    Safe HaskellSafe-Inferred

    Bug1067B

    Synopsis

    Documentation

    pattern P :: Foo #

    A pattern

    diff --git a/html-test/src/Bug1067A.hs b/html-test/src/Bug1067A.hs new file mode 100644 index 00000000..57ab60b0 --- /dev/null +++ b/html-test/src/Bug1067A.hs @@ -0,0 +1,9 @@ +{-# language PatternSynonyms #-} +module Bug1067A ( Foo(P) ) where + +-- | A foo +data Foo = Foo + +-- | A pattern +pattern P :: Foo +pattern P = Foo diff --git a/html-test/src/Bug1067B.hs b/html-test/src/Bug1067B.hs new file mode 100644 index 00000000..f1a814df --- /dev/null +++ b/html-test/src/Bug1067B.hs @@ -0,0 +1,4 @@ +{-# language PatternSynonyms #-} +module Bug1067B ( pattern P ) where + +import Bug1067A -- cgit v1.2.3 From 3c9e8081228ffcc38c760a6d9501a626071a5105 Mon Sep 17 00:00:00 2001 From: Iñaki <1238558+garetxe@users.noreply.github.com> Date: Sat, 25 Apr 2020 23:38:11 +0100 Subject: Add support for custom section anchors (#1179) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This allows to have stable anchors for groups, even if the set of groups in the documentation is altered. The syntax for setting the anchor of a group is -- * Group name #desiredAnchor# Which will produce an html anchor of the form '#g:desiredAnchor' Co-authored-by: Iñaki García Etxebarria --- doc/markup.rst | 15 +++++ haddock-api/src/Haddock/Backends/Xhtml.hs | 8 ++- html-test/ref/SectionLabels.html | 91 +++++++++++++++++++++++++++++++ html-test/src/SectionLabels.hs | 8 +++ 4 files changed, 121 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/SectionLabels.html create mode 100644 html-test/src/SectionLabels.hs diff --git a/doc/markup.rst b/doc/markup.rst index 08510804..af71e7c7 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -508,6 +508,19 @@ on, where the number of ``*``\ s indicates the level of the heading If you use section headings, then Haddock will generate a table of contents at the top of the module documentation for you. +By default, when generating HTML documentation Haddock will create an +anchor to each section of the form ``#g:n``, where ``n`` is an integer +that might change as you add new section headings. If you want to +create stable links, you can add an explicit anchor (see +:ref:`anchors`) after the section heading: :: + + module Foo ( + -- * Classes #classes# + C(..) + ) where + +This will create an HTML anchor ``#g:classes`` to the section. + The alternative style of placing the commas at the beginning of each line is also supported. e.g.: :: @@ -1150,6 +1163,8 @@ Inspired by reSTs grid tables Haddock supports a complete table representation v -- | body row 4 | | \] | -- +------------------------+------------+---------------------+ +.. _anchors: + Anchors ~~~~~~~ diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index e3d4e8ca..4e87d0be 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -672,10 +672,16 @@ numberSectionHeadings = go 1 where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI] go _ [] = [] go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es + = case collectAnchors doc of + [] -> ExportGroup lev (show n) doc : go (n+1) es + (a:_) -> ExportGroup lev a doc : go (n+1) es go n (other:es) = other : go n es + collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String] + collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b + collectAnchors (DocAName a) = [a] + collectAnchors _ = [] processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html diff --git a/html-test/ref/SectionLabels.html b/html-test/ref/SectionLabels.html new file mode 100644 index 00000000..4581082e --- /dev/null +++ b/html-test/ref/SectionLabels.html @@ -0,0 +1,91 @@ + +SectionLabels
    Safe HaskellSafe-Inferred

    SectionLabels

    Synopsis
    diff --git a/html-test/src/SectionLabels.hs b/html-test/src/SectionLabels.hs new file mode 100644 index 00000000..560bafa4 --- /dev/null +++ b/html-test/src/SectionLabels.hs @@ -0,0 +1,8 @@ +module SectionLabels + ( + -- * Section heading#custom# + n + ) where + +n :: Int +n = 3 -- cgit v1.2.3 From 8551fcd2e3e0d1a34fc09233f35a62d537df7cc1 Mon Sep 17 00:00:00 2001 From: Willem Van Onsem <3482343+KommuSoft@users.noreply.github.com> Date: Mon, 25 May 2020 18:23:01 +0200 Subject: Use floor over round to calculate the percentage (#1195) If we compile documentation where only a small fraction is undocumented, it is misleading to see 100% coverage - 99% is more intuitive. Fixes #1194 --- haddock-api/src/Haddock/Interface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 6775cf2b..66e0bedc 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -182,7 +182,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + percentage = floor (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int modString = moduleString (ifaceMod interface) coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString header = case ifaceDoc interface of -- cgit v1.2.3 From 28b6b667a4f6cfb79d84ce48b6e4a1dd4592cc21 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Tue, 28 Jul 2020 13:06:53 -0400 Subject: Bump GHC version to 9.0 --- haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- haddock.cabal | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 759e12f6..be707166 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -45,7 +45,7 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.15.0 , Cabal ^>= 2.4.0 - , ghc ^>= 8.11 + , ghc ^>= 9.0 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.8.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 39de2395..9686de1f 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if MIN_VERSION_ghc(8,11,0) && !MIN_VERSION_ghc(8,13,0) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,1,0) binaryInterfaceVersion = 34 binaryInterfaceVersionCompatibility :: [Word16] diff --git a/haddock.cabal b/haddock.cabal index 52113bd1..45acf494 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -33,7 +33,7 @@ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.12.*, GHC==8.10.*, GHC==8.8.1 +tested-with: GHC==9.0.*, GHC==8.10.* extra-source-files: CHANGES.md @@ -80,7 +80,7 @@ executable haddock Cabal >= 1.10, ghc-boot, ghc-boot-th, - ghc == 8.11.*, + ghc == 9.0.*, bytestring, parsec, text, -- cgit v1.2.3 From 3cfd582503f4962843e81a2053346ad66b0b1c14 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Wed, 19 Aug 2020 10:56:32 +0200 Subject: Another round of `npm audit fix` (#1228) This should shut down the warnings on Github. Note that the security issues seem to have been entirely in the build dependencies, since the output JS has not changed. Last NPM dependency audit happend in d576b2327e2bc117f912fe0a9d595e9ae62614e0 Co-authored-by: Alex Biehl --- haddock-api/resources/html/package-lock.json | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/haddock-api/resources/html/package-lock.json b/haddock-api/resources/html/package-lock.json index 0496a79c..3d8b49c5 100644 --- a/haddock-api/resources/html/package-lock.json +++ b/haddock-api/resources/html/package-lock.json @@ -1303,9 +1303,9 @@ } }, "elliptic": { - "version": "6.4.1", - "resolved": "https://registry.npmjs.org/elliptic/-/elliptic-6.4.1.tgz", - "integrity": "sha512-BsXLz5sqX8OHcsh7CqBMztyXARmGQ3LWPtGjJi6DiJHq5C/qvi9P3OqgswKSDftbu8+IoI/QDTAm2fFnQ9SZSQ==", + "version": "6.5.3", + "resolved": "https://registry.npmjs.org/elliptic/-/elliptic-6.5.3.tgz", + "integrity": "sha512-IMqzv5wNQf+E6aHeIqATs0tOLeOTwj1QKbRcS3jBbYkl5oLAserA8yJTT7/VyHUYG91PRmPyeQDObKLPpeS4dw==", "dev": true, "requires": { "bn.js": "^4.4.0", @@ -2580,9 +2580,9 @@ } }, "hash.js": { - "version": "1.1.5", - "resolved": "https://registry.npmjs.org/hash.js/-/hash.js-1.1.5.tgz", - "integrity": "sha512-eWI5HG9Np+eHV1KQhisXWwM+4EPPYe5dFX1UZZH7k/E3JzDEazVH+VGlZi6R94ZqImq+A3D1mCEtrFIfg/E7sA==", + "version": "1.1.7", + "resolved": "https://registry.npmjs.org/hash.js/-/hash.js-1.1.7.tgz", + "integrity": "sha512-taOaskGt4z4SOANNseOviYDvjEJinIkRgmp7LbKP2YTTmVxWBl87s/uzK9r+44BclBSp2X7K1hqeNfz9JbBeXA==", "dev": true, "requires": { "inherits": "^2.0.3", @@ -3057,9 +3057,9 @@ } }, "lodash": { - "version": "4.17.15", - "resolved": "https://registry.npmjs.org/lodash/-/lodash-4.17.15.tgz", - "integrity": "sha512-8xOcRHvCjnocdS5cpwXQXVzmmh5e5+saE2QGoeQmbKmRS6J3VQppPOIt0MnmE+4xlZoumy0GPG0D0MVIQbNA1A==", + "version": "4.17.20", + "resolved": "https://registry.npmjs.org/lodash/-/lodash-4.17.20.tgz", + "integrity": "sha512-PlhdFcillOINfeV7Ni6oF1TAEayyZBoZ8bcshTHqOYJYlrqzRK5hagpagky5o4HfCzzd1TRkXPMFq6cKk9rGmA==", "dev": true }, "lodash.memoize": { -- cgit v1.2.3 From 20098c8951743244bb71b41f470a7546ec31d0f2 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Sat, 26 Sep 2020 20:59:49 +0300 Subject: Updates for the new linear types syntax: a %p -> b --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 5fd040a8..72aab285 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -274,6 +274,7 @@ classify tok = ITdot -> TkOperator ITstar {} -> TkOperator ITtypeApp -> TkGlyph + ITpercent -> TkGlyph ITbiglam -> TkGlyph -- cgit v1.2.3 From 3e29ec51498dfe092b228889343dc8370ec0e64b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 6 Oct 2020 18:38:35 +0100 Subject: Match GHC, adding IsUnicodeSyntax field to HsFunTy and HsScaled (cherry picked from commit a7d1d8e034d25612d5d08ed8fdbf6f472aded4a1) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 ++- haddock-api/src/Haddock/Convert.hs | 7 ++++--- haddock-api/src/Haddock/GhcUtils.hs | 7 ++++--- haddock-api/src/Haddock/Interface/Create.hs | 9 ++++----- haddock-api/src/Haddock/Interface/Rename.hs | 6 +++--- haddock-api/src/Haddock/Interface/Specialize.hs | 5 +++-- 6 files changed, 20 insertions(+), 17 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 75a49036..c5a0f772 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -27,6 +27,7 @@ import Haddock.Utils hiding (out) import GHC import GHC.Utils.Outputable as Outputable +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Data.Char import Data.List @@ -245,7 +246,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3b73dcd1..d95337b8 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -52,6 +52,7 @@ import GHC.Utils.Outputable ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize @@ -769,9 +770,9 @@ noKindTyVars _ _ = emptyVarSet synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of - One -> HsLinearArrow - Many -> HsUnrestrictedArrow - ty -> HsExplicitMult (synifyType WithinType vs ty) + One -> HsLinearArrow NormalSyntax + Many -> HsUnrestrictedArrow NormalSyntax + ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3abb6481..8b4bcc05 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -42,6 +42,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type ( isRuntimeRepVar ) import GHC.Builtin.Types( liftedRepDataConTyCon ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Data.StringBuffer ( StringBuffer ) import qualified GHC.Data.StringBuffer as S @@ -165,13 +166,13 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty --- tau_ty :: LHsType DocNameI +-- tau_ty :: LHsType DocNameI tau_ty = case args of RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -227,7 +228,7 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7b9674a6..dd9419eb 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -56,8 +56,7 @@ import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O import GHC.HsToCore.Docs hiding (mkMaps) - -import GHC.Core.Multiplicity +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -958,8 +957,8 @@ extractPatternSyn nm t tvs cons = typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -976,7 +975,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField HsUnrestrictedArrow data_ty (getBangType ty))))) + L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 27bad4b9..061ef8eb 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -223,9 +223,9 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) -renameArrow HsUnrestrictedArrow = return HsUnrestrictedArrow -renameArrow HsLinearArrow = return HsLinearArrow -renameArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) +renameArrow (HsLinearArrow u) = return (HsLinearArrow u) +renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 5c933f25..0e9fc851 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -17,6 +17,7 @@ import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types.Prim ( funTyConName ) import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -136,7 +137,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | unrestrictedFunTyConName == name' = HsFunTy noExtField HsUnrestrictedArrow la lb + | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -282,7 +283,7 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p renameHsArrow mult = pure mult -- cgit v1.2.3 From 1d657cf377b5f147b08aafb3ab3a5d11be538331 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 6 Oct 2020 18:38:35 +0100 Subject: Match GHC, adding IsUnicodeSyntax field to HsFunTy and HsScaled (cherry picked from commit a7d1d8e034d25612d5d08ed8fdbf6f472aded4a1) --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 ++- haddock-api/src/Haddock/Convert.hs | 7 ++++--- haddock-api/src/Haddock/GhcUtils.hs | 7 ++++--- haddock-api/src/Haddock/Interface/Create.hs | 9 ++++----- haddock-api/src/Haddock/Interface/Rename.hs | 6 +++--- haddock-api/src/Haddock/Interface/Specialize.hs | 5 +++-- 6 files changed, 20 insertions(+), 17 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 75a49036..c5a0f772 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -27,6 +27,7 @@ import Haddock.Utils hiding (out) import GHC import GHC.Utils.Outputable as Outputable +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Data.Char import Data.List @@ -245,7 +246,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noExtField HsUnrestrictedArrow x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 3b73dcd1..d95337b8 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -52,6 +52,7 @@ import GHC.Utils.Outputable ( assertPanic ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Haddock.Types import Haddock.Interface.Specialize @@ -769,9 +770,9 @@ noKindTyVars _ _ = emptyVarSet synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of - One -> HsLinearArrow - Many -> HsUnrestrictedArrow - ty -> HsExplicitMult (synifyType WithinType vs ty) + One -> HsLinearArrow NormalSyntax + Many -> HsUnrestrictedArrow NormalSyntax + ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 3abb6481..8b4bcc05 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -42,6 +42,7 @@ import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Core.Type ( isRuntimeRepVar ) import GHC.Builtin.Types( liftedRepDataConTyCon ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Data.StringBuffer ( StringBuffer ) import qualified GHC.Data.StringBuffer as S @@ -165,13 +166,13 @@ getGADTConType (ConDeclGADT { con_forall = L _ has_forall | otherwise = tau_ty --- tau_ty :: LHsType DocNameI +-- tau_ty :: LHsType DocNameI tau_ty = case args of RecCon flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty PrefixCon pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) - mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT @@ -227,7 +228,7 @@ getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall InfixCon arg1 arg2 -> (hsScaledThing arg1) `mkFunTy` ((hsScaledThing arg2) `mkFunTy` res_ty) -- mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkFunTy a b = noLoc (HsFunTy noExtField HsUnrestrictedArrow a b) + mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 7b9674a6..dd9419eb 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -56,8 +56,7 @@ import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified GHC.Utils.Outputable as O import GHC.HsToCore.Docs hiding (mkMaps) - -import GHC.Core.Multiplicity +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -958,8 +957,8 @@ extractPatternSyn nm t tvs cons = typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con @@ -976,7 +975,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField HsUnrestrictedArrow data_ty (getBangType ty))))) + L l (TypeSig noExtField [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 27bad4b9..061ef8eb 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -223,9 +223,9 @@ renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI) -renameArrow HsUnrestrictedArrow = return HsUnrestrictedArrow -renameArrow HsLinearArrow = return HsLinearArrow -renameArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) +renameArrow (HsLinearArrow u) = return (HsLinearArrow u) +renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 5c933f25..0e9fc851 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -17,6 +17,7 @@ import GHC.Types.Name import GHC.Data.FastString import GHC.Builtin.Types.Prim ( funTyConName ) import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) +import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import Control.Monad import Control.Monad.Trans.State @@ -136,7 +137,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | unrestrictedFunTyConName == name' = HsFunTy noExtField HsUnrestrictedArrow la lb + | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb where name' = getName name sugarOperators typ = typ @@ -282,7 +283,7 @@ renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult p) = HsExplicitMult <$> renameLType p +renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p renameHsArrow mult = pure mult -- cgit v1.2.3 From 6328b5a8ed7315ff60c34e0b6cbc94a7094f4053 Mon Sep 17 00:00:00 2001 From: Veronika Romashkina Date: Tue, 8 Dec 2020 15:35:33 +0000 Subject: Fix docs links from Darcs to GitHub in intro (#1262) --- doc/intro.rst | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/doc/intro.rst b/doc/intro.rst index fcdc67f1..a3497426 100644 --- a/doc/intro.rst +++ b/doc/intro.rst @@ -62,11 +62,9 @@ Obtaining Haddock Distributions (source & binary) of Haddock can be obtained from its `web site `__. -Up-to-date sources can also be obtained from our public darcs +Up-to-date sources can also be obtained from our public GitHub repository. The Haddock sources are at -``http://code.haskell.org/haddock``. See -`darcs.net `__ for more information on the darcs -version control utility. +``https://github.com/haskell/haddock``. License ------- -- cgit v1.2.3 From ef73ba4440da1acdf2a61e94f1549aa95cdb9137 Mon Sep 17 00:00:00 2001 From: Veronika Romashkina Date: Tue, 8 Dec 2020 15:36:16 +0000 Subject: Use gender neutral word in docs (#1260) --- doc/markup.rst | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/markup.rst b/doc/markup.rst index af71e7c7..178a6865 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -223,7 +223,7 @@ module documentation example and then talk about the fields. :: {-| Module : W Description : Short description - Copyright : (c) Some Guy, 2013 + Copyright : (c) Some Person, 2013 Someone Else, 2014 License : GPL-3 Maintainer : sample@email.com @@ -245,7 +245,7 @@ multiline ``Copyright`` field: :: {-| ... - Copyright : (c) Some Guy, 2013 + Copyright : (c) Some Person, 2013 Someone Else, 2014 ... -} @@ -254,21 +254,21 @@ That could equivalently be written as :: -- | ... -- Copyright: - -- (c) Some Guy, 2013 + -- (c) Some Person, 2013 -- Someone Else, 2014 -- ... or as :: -- | ... - -- Copyright: (c) Some Guy, 2013 + -- Copyright: (c) Some Person, 2013 -- Someone Else, 2014 -- ... but not as :: -- | ... - -- Copyright: (c) Some Guy, 2013 + -- Copyright: (c) Some Person, 2013 -- Someone Else, 2014 -- ... @@ -965,7 +965,7 @@ underscore if you need it bold: Monospaced (or typewriter) text is indicated by surrounding it with ``@...@``. Other markup is valid inside a monospaced span: for example ``@'f' a b@`` will hyperlink the identifier ``f`` inside the code -fragment, but ``@__FILE__@`` will render ``FILE`` in bold with no +fragment, but ``@__FILE__@`` will render ``FILE`` in bold with no underscores, which may not be what you had in mind. Linking to Modules @@ -1148,8 +1148,8 @@ Grid Tables Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. :: - -- | This is a grid table: - -- + -- | This is a grid table: + -- -- +------------------------+------------+----------+----------+ -- | Header row, column 1 | Header 2 | Header 3 | Header 4 | -- | (header rows optional) | | | | -- cgit v1.2.3 From 3145fa33864c245b81bf314e58fe02f89c83cde6 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Tue, 8 Dec 2020 10:40:03 -0500 Subject: Allow scrolling search results (#1235) Closes https://github.com/haskell/haddock/issues/1231 --- haddock-api/resources/html/quick-jump.css | 2 ++ 1 file changed, 2 insertions(+) diff --git a/haddock-api/resources/html/quick-jump.css b/haddock-api/resources/html/quick-jump.css index 8772809c..d656f51c 100644 --- a/haddock-api/resources/html/quick-jump.css +++ b/haddock-api/resources/html/quick-jump.css @@ -53,6 +53,8 @@ box-sizing: border-box; border: 0.05em solid #b2d5fb; background: #e8f3ff; + max-height: 80%; + overflow: scroll; } #search-form input + #search-results { -- cgit v1.2.3 From 1e0ad7350290fad4f8c7728c8b879113b669397a Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Tue, 8 Dec 2020 16:40:25 +0100 Subject: Bump bl from 1.2.2 to 1.2.3 in /haddock-api/resources/html (#1255) Bumps [bl](https://github.com/rvagg/bl) from 1.2.2 to 1.2.3. - [Release notes](https://github.com/rvagg/bl/releases) - [Commits](https://github.com/rvagg/bl/compare/v1.2.2...v1.2.3) Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> --- haddock-api/resources/html/package-lock.json | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/haddock-api/resources/html/package-lock.json b/haddock-api/resources/html/package-lock.json index 3d8b49c5..b4a2cbba 100644 --- a/haddock-api/resources/html/package-lock.json +++ b/haddock-api/resources/html/package-lock.json @@ -445,9 +445,9 @@ } }, "bl": { - "version": "1.2.2", - "resolved": "http://registry.npmjs.org/bl/-/bl-1.2.2.tgz", - "integrity": "sha512-e8tQYnZodmebYDWGH7KMRvtzKXaJHx3BbilrgZCfvyLUYdKpK1t5PSPmpkny/SgiTSCnjfLW7v5rlONXVFkQEA==", + "version": "1.2.3", + "resolved": "http://registry.npmjs.org/bl/-/bl-1.2.3.tgz", + "integrity": "sha512-pvcNpa0UU69UT341rO6AYy4FVAIkUHuZXRIWbq+zHnsVcRzDDjIAhGuuYoi0d//cwIwtt4pkpKycWEfjdV+vww==", "dev": true, "requires": { "readable-stream": "^2.3.5", @@ -3801,7 +3801,7 @@ }, "readable-stream": { "version": "2.3.6", - "resolved": "http://registry.npmjs.org/readable-stream/-/readable-stream-2.3.6.tgz", + "resolved": "https://registry.npmjs.org/readable-stream/-/readable-stream-2.3.6.tgz", "integrity": "sha512-tQtKA9WIAhBF3+VLAseyMqZeBjW0AHJoxOtYqSUZNJxauErmLbVm2FW1y+J/YA9dUrAC39ITejlZWhVIwawkKw==", "dev": true, "requires": { -- cgit v1.2.3 From 1bedd20b94359728c25f64f7643a0ca0fb0f9fa2 Mon Sep 17 00:00:00 2001 From: Xia Li-yao Date: Tue, 8 Dec 2020 10:42:17 -0500 Subject: Allow more characters in anchor following module reference (#1220) --- haddock-library/src/Documentation/Haddock/Parser.hs | 10 ++++++++-- haddock-library/test/Documentation/Haddock/ParserSpec.hs | 3 +++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 149ff93d..bd01f354 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -242,12 +242,18 @@ monospace = DocMonospaced . parseParagraph -- Note that we allow '#' and '\' to support anchors (old style anchors are of -- the form "SomeModule\#anchor"). moduleName :: Parser (DocH mod a) -moduleName = DocModule <$> ("\"" *> modid <* "\"") +moduleName = DocModule <$> ("\"" *> (modid `maybeFollowedBy` anchor_) <* "\"") where modid = intercalate "." <$> conid `Parsec.sepBy1` "." + anchor_ = (++) + <$> (Parsec.string "#" <|> Parsec.string "\\#") + <*> many (Parsec.satisfy (\c -> c /= '"' && not (isSpace c))) + + maybeFollowedBy pre suf = (\x -> maybe x (x ++)) <$> pre <*> optional suf + conid = (:) <$> Parsec.satisfy (\c -> isAlpha c && isUpper c) - <*> many (conChar <|> Parsec.oneOf "\\#") + <*> many conChar conChar = Parsec.alphaNum <|> Parsec.char '_' diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 8b59b560..9bf9b6ea 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -431,6 +431,9 @@ spec = do it "accepts anchor reference syntax as DocModule" $ do "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" + it "accepts anchor with hyphen as DocModule" $ do + "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo\\#bar-baz" + it "accepts old anchor reference syntax as DocModule" $ do "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" -- cgit v1.2.3 From 7240b69e3444e40546c7a17855eed2e5ab8a0816 Mon Sep 17 00:00:00 2001 From: Xia Li-yao Date: Tue, 8 Dec 2020 10:43:05 -0500 Subject: Add dangling changes from branches ghc-8.6 and ghc-8.8 (#1243) * Fix multiple typos and inconsistencies in doc/markup.rst Note: I noticed some overlap with #1112 from @wygulmage and #1081 from @parsonsmatt after creating these proposed changes - mea culpa for not looking at the open PRs sooner. * Fix #1113 If no Signatures, no section of index.html * Change the formatting of missing link destinations The current formatting of the missing link destination does not really help user to understand the reasons of the missing link. To address this, I've changed the formatting in two ways: - the missing link symbol name is now fully qualified. This way you immediately know which haskell module cannot be linked. It is then easier to understand why this module does not have documentation (hidden module or broken documentation). - one line per missing link, that's more readable now that symbol name can be longer due to qualification. For example, before haddock was listing missing symbol such as: ``` could not find link destinations for: Word8 Word16 mapMaybe ``` Now it is listed as: ``` could not find link destinations for: - Data.Word.Word8 - Data.Word.Word16 - Data.Maybe.mapMaybe ``` * Add `--ignore-link-symbol` command line argument This argument can be used multiples time. A missing link to a symbol listed by `--ignore-link-symbol` won't trigger "missing link" warning. * Forbid spaces in anchors (#1148) * Improve error messages with context information (#1060) Co-authored-by: Matt Audesse Co-authored-by: Mike Pilgrem Co-authored-by: Guillaume Bouchard Co-authored-by: Pepe Iborra --- doc/markup.rst | 77 ++++++++++++---------- haddock-api/src/Haddock/Backends/Xhtml.hs | 1 + haddock-api/src/Haddock/Interface.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 27 +++++--- haddock-api/src/Haddock/Interface/Rename.hs | 16 +++-- haddock-api/src/Haddock/Options.hs | 10 ++- haddock-api/src/Haddock/Types.hs | 22 ++++++- .../src/Documentation/Haddock/Parser.hs | 2 +- haddock-library/src/Documentation/Haddock/Types.hs | 2 +- .../test/Documentation/Haddock/ParserSpec.hs | 9 ++- 10 files changed, 111 insertions(+), 57 deletions(-) diff --git a/doc/markup.rst b/doc/markup.rst index 178a6865..8935b765 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -131,7 +131,7 @@ or like this: :: b -- ^ This is the documentation for the argument of type 'b' There is one edge case that is handled differently: only one ``-- ^`` -annotation occuring after the constructor and all its arguments is +annotation occurring after the constructor and all its arguments is applied to the constructor, not its last argument: :: data T a b @@ -156,8 +156,8 @@ Alternative layout styles are generally accepted by Haddock - for example doc comments can appear before or after the comma in separated lists such as the list of record fields above. -In case that more than one constructor exports a field with the same -name, the documentation attached to the first occurence of the field +In cases where more than one constructor exports a field with the same +name, the documentation attached to the first occurrence of the field will be used, even if a comment is not present. :: data T a = A { someField :: a -- ^ Doc for someField of A @@ -165,7 +165,7 @@ will be used, even if a comment is not present. :: | B { someField :: a -- ^ Doc for someField of B } -In the above example, all occurences of ``someField`` in the +In the above example, all occurrences of ``someField`` in the documentation are going to be documented with ``Doc for someField of A``. Note that Haddock versions 2.14.0 and before would join up documentation of each field and render the result. The @@ -238,7 +238,7 @@ module documentation example and then talk about the fields. :: All fields are optional but they must be in order if they do appear. Multi-line fields are accepted but the consecutive lines have to start -indented more than their label. If your label is indented one space as +indented more than their label. If your label is indented one space, as is often the case with the ``--`` syntax, the consecutive lines have to start at two spaces at the very least. For example, above we saw a multiline ``Copyright`` field: :: @@ -250,7 +250,7 @@ multiline ``Copyright`` field: :: ... -} -That could equivalently be written as :: +That could equivalently be written as: :: -- | ... -- Copyright: @@ -258,14 +258,14 @@ That could equivalently be written as :: -- Someone Else, 2014 -- ... -or as :: +or as: :: -- | ... -- Copyright: (c) Some Person, 2013 -- Someone Else, 2014 -- ... -but not as :: +but not as: :: -- | ... -- Copyright: (c) Some Person, 2013 @@ -352,7 +352,7 @@ Documentation Structure Examples We now give several examples that produce similar results and illustrate most of the structural markup features. The first two -example use an export list, but the third example does not. +examples use an export list, but the third example does not. The first example, using an export list with :ref:`section-headings` and inline section descriptions: :: @@ -362,7 +362,7 @@ and inline section descriptions: :: -- -- | There is a "smart" importer, 'readImage', that determines -- the image format from the file extension, and several - -- "dumb" format-specific importers that decode the file at + -- "dumb" format-specific importers that decode the file as -- the specified type. readImage , readPngImage @@ -417,7 +417,7 @@ defined elsewhere (the ``$imageImporters``; see :ref:`named-chunks`): -- -- There is a "smart" importer, 'readImage', that determines the -- image format from the file extension, and several "dumb" - -- format-specific importers that decode the file at the specified + -- format-specific importers that decode the file as the specified -- type. -- | Read an image, guessing the format from the file name. @@ -450,7 +450,7 @@ The third example, without an export list: :: -- -- There is a "smart" importer, 'readImage', that determines the -- image format from the file extension, and several "dumb" - -- format-specific importers that decode the file at the specified + -- format-specific importers that decode the file as the specified -- type. -- | Read an image, guessing the format from the file name. @@ -522,11 +522,11 @@ create stable links, you can add an explicit anchor (see This will create an HTML anchor ``#g:classes`` to the section. The alternative style of placing the commas at the beginning of each -line is also supported. e.g.: :: +line is also supported, e.g.: :: module Foo ( -- * Classes - , C(..) + C(..) -- * Types -- ** A data type , T @@ -539,7 +539,7 @@ line is also supported. e.g.: :: When not using an export list, you may insert section headers in the module body. Such section headers associate with all entities -declaried up until the next section header. For example: :: +declared up until the next section header. For example: :: module Foo where @@ -614,7 +614,7 @@ re-exporting module. It is often desirable to include a chunk of documentation which is not attached to any particular Haskell declaration, for example, when giving summary documentation for a group of related definitions (see -:ref:`structure-examples`). In addition to including such documenation +:ref:`structure-examples`). In addition to including such documentation chunks at the top of the file, as part of the :ref:`module-description`, you can also associate them with :ref:`section-headings`. @@ -668,14 +668,14 @@ headings, depending on whether you are using an export list or not: -- Here is a large chunk of documentation which may be referred to by -- the name $doc. - Just like with entity declariations when not using an export list, + Just like with entity declarations when not using an export list, named chunks of documentation are associated with the preceding section header here, or with the implicit top-level documentation section if there is no preceding section header. **Warning**: the form used in the first bullet above, where the chunk is not named, *does not work* when you aren't using an - export list. For example :: + export list. For example: :: module Foo where @@ -686,7 +686,7 @@ headings, depending on whether you are using an export list or not: -- | The fooifier. foo :: ... - will result in ``Some documentation not ...`` being attached to + will result in ``Some documentation not ...`` being attached to the *next* entity declaration, here ``foo``, in addition to any other documentation that next entity already has! @@ -756,7 +756,7 @@ type in ``C`` will therefore point locally to ``C.T``. Module Attributes ----------------- -Certain attributes may be specified for each module which affects the +Certain attributes may be specified for each module which affect the way that Haddock generates documentation for that module. Attributes are specified in a comma-separated list in an ``{-# OPTIONS_HADDOCK ... #-}`` pragma at the top of the module, either @@ -807,7 +807,7 @@ Markup Haddock understands certain textual cues inside documentation annotations that tell it how to render the documentation. The cues (or -“markup”) have been designed to be simple and mnemonic in ASCII so that +“markup”) have been designed to be simple and mnemonic in ASCII so the programmer doesn't have to deal with heavyweight annotations when editing documentation comments. @@ -820,8 +820,8 @@ comment. Special Characters ~~~~~~~~~~~~~~~~~~ -The following characters have special meanings in documentation -comments: ``\``, ``/``, ``'``, `````, ``"``, ``@``, ``<``, ``$``, ``#``. To insert a +The following characters have special meanings in documentation comments: +``\``, ``/``, ``'``, `````, ``"``, ``@``, ``<``, ``$``, ``#``. To insert a literal occurrence of one of these special characters, precede it with a backslash (``\``). @@ -839,7 +839,7 @@ Character References Although Haskell source files may contain any character from the Unicode character set, the encoding of these characters as bytes varies between -systems, so that only source files restricted to the ASCII character set +systems. Consequently, only source files restricted to the ASCII character set are portable. Other characters may be specified in character and string literals using Haskell character escapes. To represent such characters in documentation comments, Haddock supports SGML-style numeric character @@ -926,10 +926,11 @@ If ``M.T`` is not otherwise in scope, then Haddock will simply emit a link pointing to the entity ``T`` exported from module ``M`` (without checking to see whether either ``M`` or ``M.T`` exist). -Since values and types live in different namespaces in Haskell, it is -possible for a reference such as ``'X'`` to be ambiguous. In such a case, -Haddock defaults to pointing to the type. The ambiguity can be overcome by explicitly specifying a namespace, by way of a ``v`` (for value) or ``t`` -(for type) immediately before the link: :: +Since values and types live in different namespaces in Haskell, it is possible +for a reference such as ``'X'`` to be ambiguous. In such a case, Haddock +defaults to pointing to the type. The ambiguity can be overcome by explicitly +specifying a namespace, by way of a ``v`` (for value) or ``t`` (for type) +immediately before the link: :: -- | An implicit reference to 'X', the type constructor -- An explicit reference to v'X', the data constructor @@ -986,7 +987,7 @@ Itemized and Enumerated Lists A bulleted item is represented by preceding a paragraph with either “``*``” or “``-``”. A sequence of bulleted paragraphs is rendered as an -itemized list in the generated documentation, eg.: :: +itemized list in the generated documentation, e.g.: :: -- | This is a bulleted list: -- @@ -1025,7 +1026,7 @@ You can have more than one line of content in a list element: :: You can even nest whole paragraphs inside of list elements. The rules are 4 spaces for each indentation level. You're required to use a -newline before such nested paragraph: :: +newline before such nested paragraphs: :: {-| * Beginning of list @@ -1112,7 +1113,7 @@ followed by the URL enclosed in regular parentheses, for example: :: [some link](http://example.com) -The link text is used as a descriptive text for the URL, if the output +The link text is used as a description for the URL if the output format supports it. Images @@ -1125,8 +1126,8 @@ like this: :: ![image description](pathtoimage.png) If the output format supports it, the image will be rendered inside the -documentation. The image description is used as relpacement text and/or -image title. +documentation. The image description is used as replacement text and/or +an image title. Mathematics / LaTeX ~~~~~~~~~~~~~~~~~~~ @@ -1146,7 +1147,13 @@ the mathematics via `MathJax `__. Grid Tables ~~~~~~~~~~~ -Inspired by reSTs grid tables Haddock supports a complete table representation via a grid-like "ASCII art". Grid tables are described with a visual grid made up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for horizontal lines (row separators). The equals sign ("=") may be used to separate optional header rows from the table body. The vertical bar ("|") is used for vertical lines (column separators). The plus sign ("+") is used for intersections of horizontal and vertical lines. :: +Inspired by reSTs grid tables, Haddock supports a complete table representation +via grid-like "ASCII art". Grid tables are described with a visual grid made +up of the characters "-", "=", "|", and "+". The hyphen ("-") is used for +horizontal lines (row separators). The equals sign ("=") may be used to +separate optional header rows from the table body. The vertical bar ("|") is +used for vertical lines (column separators). The plus sign ("+") is used for +intersections of horizontal and vertical lines. :: -- | This is a grid table: -- @@ -1240,7 +1247,7 @@ Since ^^^^^ ``@since`` annotation can be used to convey information about when the -function was introduced or when it has changed in the way significant to +function was introduced or when it has changed in a way significant to the user. ``@since`` is a paragraph-level element. While multiple such annotations are not an error, only the one to appear in the comment last will be used. ``@since`` has to be followed with a version number, no diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 4e87d0be..f80a9c05 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -307,6 +307,7 @@ ppPrologue pkg qual title (Just doc) = ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html +ppSignatureTree _ _ [] = mempty ppSignatureTree pkg qual ts = divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 66e0bedc..d1e1dae1 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -111,7 +111,7 @@ processModules verbosity modules flags extIfaces = do let warnings = Flag_NoWarnings `notElem` flags dflags <- getDynFlags let (interfaces'', msgs) = - runWriter $ mapM (renameInterface dflags links warnings) interfaces' + runWriter $ mapM (renameInterface dflags (ignoredSymbols flags) links warnings) interfaces' liftIO $ mapM_ putStrLn msgs return (interfaces'', homeLinks) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 5a58e1ac..d554eeb3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -39,6 +39,7 @@ import Data.Ord import Control.Applicative import Control.Monad import Data.Traversable +import GHC.Stack (HasCallStack) import Avail hiding (avail) import qualified Avail @@ -58,16 +59,21 @@ import FastString ( unpackFS, bytesFS ) import BasicTypes ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) import qualified Outputable as O +mkExceptionContext :: TypecheckedModule -> String +mkExceptionContext = + ("creating Haddock interface for " ++) . moduleNameString . ms_mod_name . pm_mod_summary . tm_parsed_module -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule +createInterface :: HasCallStack + => TypecheckedModule -> [Flag] -- Boolean flags -> IfaceMap -- Locally processed modules -> InstIfaceMap -- External, already installed interfaces -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do +createInterface tm flags modMap instIfaceMap = + withExceptionContext (mkExceptionContext tm) $ do let ms = pm_mod_summary . tm_parsed_module $ tm mi = moduleInfo tm @@ -207,7 +213,6 @@ createInterface tm flags modMap instIfaceMap = do , ifaceDynFlags = dflags } - -- | Given all of the @import M as N@ declarations in a package, -- create a mapping from the module identity of M, to an alias N -- (if there are multiple aliases, we pick the last one.) This @@ -652,7 +657,8 @@ collectDocs = go Nothing [] -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: Bool -- is it a signature + :: HasCallStack + => Bool -- is it a signature -> IfaceMap -> Maybe Package -- this package -> Module -- this module @@ -711,7 +717,8 @@ mkExportItems availExportItem is_sig modMap thisMod semMod warnings exportedNames maps fixMap splices instIfaceMap dflags avail -availExportItem :: Bool -- is it a signature +availExportItem :: HasCallStack + => Bool -- is it a signature -> IfaceMap -> Module -- this module -> Module -- semantic module @@ -804,7 +811,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames Just synifiedDecl -> pure synifiedDecl Nothing -> O.pprPanic "availExportItem" (O.text err) - availExportDecl :: AvailInfo -> LHsDecl GhcRn + availExportDecl :: HasCallStack => AvailInfo -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ErrMsgGhc [ ExportItem GhcRn ] availExportDecl avail decl (doc, subs) @@ -1075,7 +1082,8 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam -- This function looks through the declarations in this module to try to find -- the one with the right name. extractDecl - :: DeclMap -- ^ all declarations in the file + :: HasCallStack + => DeclMap -- ^ all declarations in the file -> Name -- ^ name of the declaration to extract -> LHsDecl GhcRn -- ^ parent declaration -> Either ErrMsg (LHsDecl GhcRn) @@ -1159,10 +1167,11 @@ extractDecl declMap name decl _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) +extractPatternSyn :: HasCallStack => Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons = case filter matches cons of - [] -> Left "extractPatternSyn: constructor pattern not found" + [] -> Left . O.showSDocUnsafe $ + O.text "constructor pattern " O.<+> O.ppr nm O.<+> O.text "not found in type" O.<+> O.ppr t con:_ -> pure (extract <$> con) where matches :: LConDecl GhcRn -> Bool diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 97f128d7..b4ff31e5 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,6 +29,7 @@ import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) import qualified Data.Map as Map hiding ( Map ) +import qualified Data.Set as Set import Prelude hiding (mapM) -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to @@ -39,8 +40,8 @@ import Prelude hiding (mapM) -- -- The renamed output gets written into fields in the Haddock interface record -- that were previously left empty. -renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface dflags renamingEnv warnings iface = +renameInterface :: DynFlags -> [String] -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface _dflags ignoredSymbols renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming @@ -75,8 +76,15 @@ renameInterface dflags renamingEnv warnings iface = -- 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 + + qualifiedName n = (moduleNameString $ moduleName $ nameModule n) <> "." <> getOccString n + + ignoreSet = Set.fromList ignoredSymbols + + strings = [ qualifiedName n + | n <- missingNames + , not (qualifiedName n `Set.member` ignoreSet) , not (isSystemName n) , not (isBuiltInSyntax n) , Exact n /= eqTyCon_RDR @@ -88,7 +96,7 @@ renameInterface dflags renamingEnv warnings iface = unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++ - unwords (" " : strings) ] + intercalate "\n\t- " ("" : strings) ] return $ iface { ifaceRnDoc = finalModuleDoc, ifaceRnDocMap = rnDocMap, diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 510810b0..8a18a60d 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -36,7 +36,8 @@ module Haddock.Options ( readIfaceArgs, optPackageName, optPackageVersion, - modulePackageInfo + modulePackageInfo, + ignoredSymbols ) where @@ -108,6 +109,7 @@ data Flag | Flag_PackageVersion String | Flag_Reexport String | Flag_SinceQualification String + | Flag_IgnoreLinkSymbol String deriving (Eq, Show) @@ -219,7 +221,9 @@ options backwardsCompat = Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") "version of the package being documented in usual x.y.z.w format", Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL") - "package qualification of @since, one of\n'always' (default) or 'only-external'" + "package qualification of @since, one of\n'always' (default) or 'only-external'", + Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL") + "name of a symbol which does not trigger a warning in case of link issue" ] @@ -336,6 +340,8 @@ verbosity flags = Left e -> throwE e Right v -> v +ignoredSymbols :: [Flag] -> [String] +ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ] ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index ec76fb72..c2cf08bb 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -39,6 +39,7 @@ import Data.Void (Void) import Documentation.Haddock.Types import BasicTypes (Fixity(..), PromotionFlag(..)) +import Exception (ExceptionMonad(..), ghandle) import GHC import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt @@ -649,17 +650,28 @@ tell w = Writer ((), w) -- | Haddock's own exception type. -data HaddockException = HaddockException String deriving Typeable +data HaddockException + = HaddockException String + | WithContext [String] SomeException + deriving Typeable instance Show HaddockException where show (HaddockException str) = str - + show (WithContext ctxts se) = unlines $ ["While " ++ ctxt ++ ":\n" | ctxt <- reverse ctxts] ++ [show se] throwE :: String -> a instance Exception HaddockException throwE str = throw (HaddockException str) +withExceptionContext :: ExceptionMonad m => String -> m a -> m a +withExceptionContext ctxt = + ghandle (\ex -> + case ex of + HaddockException e -> throw $ WithContext [ctxt] (toException ex) + WithContext ctxts se -> throw $ WithContext (ctxt:ctxts) se + ) . + ghandle (throw . WithContext [ctxt]) -- In "Haddock.Interface.Create", we need to gather -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, @@ -694,6 +706,12 @@ instance Monad ErrMsgGhc where instance MonadIO ErrMsgGhc where liftIO m = WriterGhc (fmap (\x -> (x, [])) (liftIO m)) +instance ExceptionMonad ErrMsgGhc where + gcatch act hand = WriterGhc $ + runWriterGhc act `gcatch` (runWriterGhc . hand) + gmask act = WriterGhc $ gmask $ \mask -> + runWriterGhc $ act (WriterGhc . mask . runWriterGhc) + ----------------------------------------------------------------------------- -- * Pass sensitive types ----------------------------------------------------------------------------- diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index bd01f354..a3bba38a 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -227,7 +227,7 @@ takeWhile1_ = mfilter (not . T.null) . takeWhile_ -- DocAName "Hello world" anchor :: Parser (DocH mod a) anchor = DocAName . T.unpack <$> - disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") + ("#" *> takeWhile1_ (\x -> x /= '#' && not (isSpace x)) <* "#") -- | Monospaced strings. -- diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index d8c7a9fa..12ccd28d 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -126,7 +126,7 @@ data DocH mod id | DocMathInline String | DocMathDisplay String | DocAName String - -- ^ A (HTML) anchor. + -- ^ A (HTML) anchor. It must not contain any spaces. | DocProperty String | DocExamples [Example] | DocHeader (Header (DocH mod id)) diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 9bf9b6ea..f264dbba 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -289,8 +289,10 @@ spec = do it "parses a single word anchor" $ do "#foo#" `shouldParseTo` DocAName "foo" - it "parses a multi word anchor" $ do - "#foo bar#" `shouldParseTo` DocAName "foo bar" + -- Spaces are not allowed: + -- https://www.w3.org/TR/html51/dom.html#the-id-attribute + it "doesn't parse a multi word anchor" $ do + "#foo bar#" `shouldParseTo` "#foo bar#" it "parses a unicode anchor" $ do "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ" @@ -305,6 +307,9 @@ spec = do it "does not accept empty anchors" $ do "##" `shouldParseTo` "##" + it "does not accept anchors containing spaces" $ do + "{-# LANGUAGE GADTs #-}" `shouldParseTo` "{-# LANGUAGE GADTs #-}" + context "when parsing emphasised text" $ do it "emphasises a word on its own" $ do "/foo/" `shouldParseTo` DocEmphasis "foo" -- cgit v1.2.3 From 96a60e218b35df611ee56c4bdd8408ec4375e6ca Mon Sep 17 00:00:00 2001 From: tomjaguarpaw Date: Tue, 8 Dec 2020 17:00:04 +0000 Subject: Enable two warnings (#1245) because they will be soon be added to -Wall. See https://gitlab.haskell.org/ghc/ghc/-/issues/15656 --- haddock-api/haddock-api.cabal | 2 ++ haddock-api/src/Haddock/Backends/Hoogle.hs | 1 + haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 + haddock-api/src/Haddock/GhcUtils.hs | 1 + haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 ++ haddock-api/src/Haddock/Interface/Rename.hs | 1 + haddock-api/src/Haddock/Interface/Specialize.hs | 1 + haddock.cabal | 2 +- 8 files changed, 10 insertions(+), 1 deletion(-) diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 4abfd984..5fa51905 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -70,6 +70,8 @@ library -Wredundant-constraints -Wnoncanonical-monad-instances -Wmissing-home-modules + -Wincomplete-uni-patterns + -Wincomplete-record-updates exposed-modules: diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 63acb465..4961edc2 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0247d567..0974d6da 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Haddock.Backends.Hyperlinker.Parser (parse) where import Control.Applicative ( Alternative(..) ) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 923516b6..0874e7b4 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 685dca01..ce987b76 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b4ff31e5..78c58581 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 492818bd..6e11a859 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Haddock.Interface.Specialize ( specializeInstHead diff --git a/haddock.cabal b/haddock.cabal index 1d6ad180..0bf99950 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -62,7 +62,7 @@ executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - ghc-options: -funbox-strict-fields -Wall -O2 -threaded + ghc-options: -funbox-strict-fields -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -O2 -threaded -- haddock typically only supports a single GHC major version build-depends: -- cgit v1.2.3 From 39996e2d2ef4b69706bf279a75575bde240b1f1f Mon Sep 17 00:00:00 2001 From: Willem Van Onsem <3482343+KommuSoft@users.noreply.github.com> Date: Tue, 8 Dec 2020 18:26:55 +0100 Subject: simplify calculating percentages fixing #1194 (#1236) --- haddock-api/src/Haddock/Interface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index d1e1dae1..6dcfa594 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -182,7 +182,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = floor (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + percentage = div (haddocked * 100) haddockable modString = moduleString (ifaceMod interface) coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString header = case ifaceDoc interface of -- cgit v1.2.3 From bc962c945af2955402c8bed66ccb310f35a1e676 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Tue, 8 Dec 2020 19:42:52 +0100 Subject: Changes for GHC#17566 See https://gitlab.haskell.org/ghc/ghc/merge_requests/2469 --- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +++- haddock-api/src/Haddock/GhcUtils.hs | 29 +++++++++++++++++++++++--- haddock-api/src/Haddock/Types.hs | 1 + 5 files changed, 32 insertions(+), 6 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 647812f9..024a6c51 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -255,7 +255,7 @@ declNames :: LHsDecl DocNameI , [DocName] -- names being declared ) declNames (L _ decl) = case decl of - TyClD _ d -> (empty, [tcdName d]) + TyClD _ d -> (empty, [tcdNameI d]) SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index f80a9c05..541f40c4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -407,7 +407,7 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d exportSubs _ = [] exportName :: ExportItem DocNameI -> [IdP DocNameI] - exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) + exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index ef0ba1b6..30b8d43e 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -536,6 +536,8 @@ ppClassDecl summary links instances fixities loc d subdocs -- Only the fixity relevant to the class header fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual + nm = tcdNameI decl + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds -- Associated types @@ -794,7 +796,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats | otherwise = header_ +++ docSection curname pkg qual doc +++ constrBit +++ patternBit +++ instancesBit where - docname = tcdName dataDecl + docname = tcdNameI dataDecl curname = Just $ getName docname cons = dd_cons (tcdDataDefn dataDecl) isH98 = case unLoc (head cons) of diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 0874e7b4..43fe3e77 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -58,8 +58,7 @@ moduleString = moduleNameString . moduleName isNameSym :: Name -> Bool isNameSym = isSymOcc . nameOccName -getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - HsDecl p -> [IdP p] +getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -221,6 +220,31 @@ getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT getGADTConType (XConDecl nec) = noExtCon nec +getMainDeclBinderI :: HsDecl DocNameI -> [IdP DocNameI] +getMainDeclBinderI (TyClD _ d) = [tcdNameI d] +getMainDeclBinderI (ValD _ d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinderI (SigD _ d) = sigNameNoLoc d +getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinderI _ = [] + +familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName +familyDeclLNameI (FamilyDecl { fdLName = n }) = n +familyDeclLNameI (XFamilyDecl nec) = noExtCon nec + +tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName +tyClDeclLNameI (FamDecl { tcdFam = fd }) = familyDeclLNameI fd +tyClDeclLNameI (SynDecl { tcdLName = ln }) = ln +tyClDeclLNameI (DataDecl { tcdLName = ln }) = ln +tyClDeclLNameI (ClassDecl { tcdLName = ln }) = ln +tyClDeclLNameI (XTyClDecl nec) = noExtCon nec + +tcdNameI :: TyClDecl DocNameI -> DocName +tcdNameI = unLoc . tyClDeclLNameI + -- ------------------------------------- getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) @@ -761,4 +785,3 @@ defaultRuntimeRepVars = go emptyVarEnv go _ ty@(LitTy {}) = ty go _ ty@(CoercionTy {}) = ty - diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index c2cf08bb..853f4b1b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -789,6 +789,7 @@ type instance XDataDecl DocNameI = NoExtField type instance XSynDecl DocNameI = NoExtField type instance XFamDecl DocNameI = NoExtField type instance XXFamilyDecl DocNameI = NoExtCon +type instance XXTyClDecl DocNameI = NoExtCon type instance XHsIB DocNameI _ = NoExtField type instance XHsWC DocNameI _ = NoExtField -- cgit v1.2.3 From 02769a1fb005c68199b16f350e649464a346bd48 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 8 Dec 2020 20:03:49 +0100 Subject: Import intercalate --- haddock-api/src/Haddock/Interface/Rename.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 78c58581..4d9eadac 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -29,6 +29,7 @@ import TysWiredIn (eqTyCon_RDR) import Control.Applicative import Control.Arrow ( first ) import Control.Monad hiding (mapM) +import Data.List (intercalate) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set import Prelude hiding (mapM) -- cgit v1.2.3 From 8dcc6d652c434b6ed9aea7a6019447aa72e7ba28 Mon Sep 17 00:00:00 2001 From: Matthías Páll Gissurarson Date: Fri, 19 Jun 2020 17:47:48 +0200 Subject: Adapt Haddock for QualifiedDo --- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 0974d6da..285b0ee7 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -176,7 +176,7 @@ classify tok = ITdata -> TkKeyword ITdefault -> TkKeyword ITderiving -> TkKeyword - ITdo -> TkKeyword + ITdo {} -> TkKeyword ITelse -> TkKeyword IThiding -> TkKeyword ITforeign -> TkKeyword @@ -209,7 +209,7 @@ classify tok = ITcapiconv -> TkKeyword ITprimcallconv -> TkKeyword ITjavascriptcallconv -> TkKeyword - ITmdo -> TkKeyword + ITmdo {} -> TkKeyword ITfamily -> TkKeyword ITrole -> TkKeyword ITgroup -> TkKeyword -- cgit v1.2.3 From c4291bfc06211c9f60c9d43b4ada5c75ab8b41f8 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 8 Dec 2020 21:00:50 +0100 Subject: Fix haddock-library tests --- haddock-library/test/Documentation/Haddock/ParserSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index f264dbba..1724c664 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -437,7 +437,7 @@ spec = do "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" it "accepts anchor with hyphen as DocModule" $ do - "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo\\#bar-baz" + "\"Foo#bar-baz\"" `shouldParseTo` DocModule "Foo#bar-baz" it "accepts old anchor reference syntax as DocModule" $ do "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" -- cgit v1.2.3 From 1dbbe6cd32c609fce0857cc77ef367820eb88359 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Tue, 8 Dec 2020 23:08:23 +0100 Subject: Move to GitHub CI (#1266) * Initial version of ci.yml This is a straight copy from Dmitrii Kovanikov's blog post at https://kodimensional.dev/github-actions. Will adapt to haddock in successive commits. * Delete .travis.yml * Modify to only test on ghc-8.10.{1,2} * Use actions/setup-haskell@v1.1.4 * Relax QuickCheck bound on haddock-api * Remove stack matrix for now * Nail down to ghc-8.10 branch for now * Pin index state to 2020-12-08T20:13:44Z for now * Disable macOS and Windows tests for now for speed up --- .github/workflows/ci.yml | 49 +++++++++++++ .travis.yml | 157 ------------------------------------------ cabal.project | 3 + haddock-api/haddock-api.cabal | 2 +- 4 files changed, 53 insertions(+), 158 deletions(-) create mode 100644 .github/workflows/ci.yml delete mode 100644 .travis.yml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 00000000..d5b1bae2 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,49 @@ +name: CI + +# Trigger the workflow on push or pull request, but only for the master branch +on: + pull_request: + push: + branches: ["ghc-8.10"] + +jobs: + cabal: + name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest] + cabal: ["3.2"] + ghc: + - "8.10.1" + - "8.10.2" + + steps: + - uses: actions/checkout@v2 + if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/ghc-8.10' + + - uses: actions/setup-haskell@v1.1.4 + id: setup-haskell-cabal + name: Setup Haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Freeze + run: | + cabal freeze + + - uses: actions/cache@v1 + name: Cache ~/.cabal/store + with: + path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + + - name: Build + run: | + cabal configure --enable-tests --enable-benchmarks --test-show-details=direct + cabal build all + + - name: Test + run: | + cabal test all diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 32ac3065..00000000 --- a/.travis.yml +++ /dev/null @@ -1,157 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci 'cabal.project' '--output=.travis.yml' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.9.20200321 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} - os: linux - allow_failures: - - compiler: ghc-8.10.1 -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap" - - set -o pipefail - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - HEADHACKAGE=true - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - - | - if $HEADHACKAGE; then - echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config - echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config - echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config - echo " secure: True" >> $CABALHOME/config - echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config - echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config - echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config - echo " key-threshold: 3" >> $CABALHOME/config - fi -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ." >> cabal.project - echo "packages: ./haddock-api" >> cabal.project - echo "packages: ./haddock-library" >> cabal.project - echo "packages: ./haddock-test" >> cabal.project - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock|haddock-api|haddock-library|haddock-test)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - if [ -f "./haddock-api/configure.ac" ]; then (cd "./haddock-api" && autoreconf -i); fi - - if [ -f "./haddock-library/configure.ac" ]; then (cd "./haddock-library" && autoreconf -i); fi - - if [ -f "./haddock-test/configure.ac" ]; then (cd "./haddock-test" && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_haddock="$(find . -maxdepth 1 -type d -regex '.*/haddock-[0-9.]*')" - - PKGDIR_haddock_api="$(find . -maxdepth 1 -type d -regex '.*/haddock-api-[0-9.]*')" - - PKGDIR_haddock_library="$(find . -maxdepth 1 -type d -regex '.*/haddock-library-[0-9.]*')" - - PKGDIR_haddock_test="$(find . -maxdepth 1 -type d -regex '.*/haddock-test-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_haddock}" >> cabal.project - echo "packages: ${PKGDIR_haddock_api}" >> cabal.project - echo "packages: ${PKGDIR_haddock_library}" >> cabal.project - echo "packages: ${PKGDIR_haddock_test}" >> cabal.project - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(haddock|haddock-api|haddock-library|haddock-test)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building... - # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all - # cabal check... - - (cd ${PKGDIR_haddock} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_haddock_api} && ${CABAL} -vnormal check) - - (cd ${PKGDIR_haddock_library} && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - -# REGENDATA ("0.9.20200321",["cabal.project","--output=.travis.yml"]) -# EOF diff --git a/cabal.project b/cabal.project index ba925e3d..7330a775 100644 --- a/cabal.project +++ b/cabal.project @@ -2,3 +2,6 @@ packages: ./ ./haddock-api ./haddock-library ./haddock-test + +-- Pinning the index-state helps to make reasonably CI deterministic +index-state: 2020-12-08T20:13:44Z diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 5fa51905..982d6145 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -177,7 +177,7 @@ test-suite spec , haddock-library ^>= 1.9.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.8 - , QuickCheck >= 2.11 && < 2.14 + , QuickCheck >= 2.11 && ^>= 2.14 -- Versions for the dependencies below are transitively pinned by -- the non-reinstallable `ghc` package and hence need no version -- cgit v1.2.3 From 5af637434e941f2b404b395f14a36b09f97e2b67 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Thu, 10 Dec 2020 19:02:16 +0100 Subject: Bump ini from 1.3.5 to 1.3.7 in /haddock-api/resources/html (#1269) Bumps [ini](https://github.com/isaacs/ini) from 1.3.5 to 1.3.7. - [Release notes](https://github.com/isaacs/ini/releases) - [Commits](https://github.com/isaacs/ini/compare/v1.3.5...v1.3.7) Signed-off-by: dependabot[bot] Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com> --- haddock-api/resources/html/package-lock.json | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/haddock-api/resources/html/package-lock.json b/haddock-api/resources/html/package-lock.json index b4a2cbba..f09bde68 100644 --- a/haddock-api/resources/html/package-lock.json +++ b/haddock-api/resources/html/package-lock.json @@ -1907,12 +1907,6 @@ "dev": true, "optional": true }, - "ini": { - "version": "1.3.5", - "bundled": true, - "dev": true, - "optional": true - }, "is-fullwidth-code-point": { "version": "1.0.0", "bundled": true, @@ -2656,9 +2650,9 @@ "dev": true }, "ini": { - "version": "1.3.5", - "resolved": "https://registry.npmjs.org/ini/-/ini-1.3.5.tgz", - "integrity": "sha512-RZY5huIKCMRWDUqZlEi72f/lmXKMvuszcMBduliQ3nnWbx9X/ZBQO7DijMEYS9EhHBb2qacRUMtC7svLwe0lcw==", + "version": "1.3.7", + "resolved": "https://registry.npmjs.org/ini/-/ini-1.3.7.tgz", + "integrity": "sha512-iKpRpXP+CrP2jyrxvg1kMUpXDyRUFDWurxbnVT1vQPx+Wz9uCYsMIqYuSBLV+PAaZG/d7kRLKRFc9oDMsH+mFQ==", "dev": true }, "inline-source-map": { -- cgit v1.2.3 From 24f504c386e390136aa2309ed7cf79b217c25a98 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 20 Aug 2017 16:03:26 +0200 Subject: Build instructions: haddock-library and -api first! --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 4490a53e..e9ff09ca 100644 --- a/README.md +++ b/README.md @@ -37,6 +37,10 @@ cd haddock and then proceed using your favourite build tool. +Note: before building `haddock`, you need to build the subprojects +`haddock-library` and `haddock-api`, in this order! +The `cabal v2-build` takes care of this automatically. + #### Using [`cabal v2-build`][cabal v2] ```bash -- cgit v1.2.3 From df96565cf1c6b7468f58d9173bbbcbefb7445b08 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sat, 6 Feb 2021 11:39:30 -0500 Subject: Fix partial record selector warning --- haddock-api/src/Haddock/Interface/Create.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 272b8f02..72f1ab62 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, CPP, TupleSections, BangPatterns, LambdaCase, NamedFieldPuns, ScopedTypeVariables, RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DerivingStrategies #-} @@ -687,11 +687,11 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let newDecl = L loc . SigD noExtField . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD _ cl@ClassDecl{}) -> do + L loc (TyClD _ ClassDecl {..}) -> do mdef <- minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD noExtField cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ _ -> availExportDecl avail decl docs_ -- cgit v1.2.3