haddock-api (empty) → 2.15.0
raw patch · 44 files changed
+11470/−0 lines, 44 filesdep +Cabaldep +arraydep +basesetup-changedbinary-added
Dependencies added: Cabal, array, base, bytestring, containers, deepseq, directory, filepath, ghc, ghc-paths, haddock-library, xhtml
Files
- LICENSE +23/−0
- Setup.lhs +3/−0
- haddock-api.cabal +94/−0
- resources/html/Classic.theme/haskell_icon.gif binary
- resources/html/Classic.theme/minus.gif binary
- resources/html/Classic.theme/plus.gif binary
- resources/html/Classic.theme/xhaddock.css +499/−0
- resources/html/Ocean.std-theme/hslogo-16.png binary
- resources/html/Ocean.std-theme/minus.gif binary
- resources/html/Ocean.std-theme/ocean.css +577/−0
- resources/html/Ocean.std-theme/plus.gif binary
- resources/html/Ocean.std-theme/synopsis.png binary
- resources/html/frames.html +30/−0
- resources/html/haddock-util.js +344/−0
- resources/latex/haddock.sty +57/−0
- src/Documentation/Haddock.hs +89/−0
- src/Haddock.hs +488/−0
- src/Haddock/Backends/HaddockDB.hs +170/−0
- src/Haddock/Backends/Hoogle.hs +331/−0
- src/Haddock/Backends/LaTeX.hs +1221/−0
- src/Haddock/Backends/Xhtml.hs +690/−0
- src/Haddock/Backends/Xhtml/Decl.hs +884/−0
- src/Haddock/Backends/Xhtml/DocMarkup.hs +143/−0
- src/Haddock/Backends/Xhtml/Layout.hs +235/−0
- src/Haddock/Backends/Xhtml/Names.hs +171/−0
- src/Haddock/Backends/Xhtml/Themes.hs +209/−0
- src/Haddock/Backends/Xhtml/Types.hs +37/−0
- src/Haddock/Backends/Xhtml/Utils.hs +218/−0
- src/Haddock/Convert.hs +403/−0
- src/Haddock/Doc.hs +31/−0
- src/Haddock/GhcUtils.hs +304/−0
- src/Haddock/Interface.hs +244/−0
- src/Haddock/Interface/AttachInstances.hs +221/−0
- src/Haddock/Interface/Create.hs +867/−0
- src/Haddock/Interface/LexParseRn.hs +146/−0
- src/Haddock/Interface/ParseModuleHeader.hs +150/−0
- src/Haddock/Interface/Rename.hs +506/−0
- src/Haddock/InterfaceFile.hs +636/−0
- src/Haddock/ModuleTree.hs +56/−0
- src/Haddock/Options.hs +287/−0
- src/Haddock/Parser.hs +44/−0
- src/Haddock/Types.hs +552/−0
- src/Haddock/Utils.hs +480/−0
- src/Haddock/Version.hs +30/−0
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright 2002-2010, Simon Marlow. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ haddock-api.cabal view
@@ -0,0 +1,94 @@+name: haddock-api+version: 2.15.0+synopsis: A documentation-generation tool for Haskell libraries+description: Haddock is a documentation-generation tool for Haskell+ libraries+license: BSD3+license-file: LICENSE+author: Simon Marlow, David Waern+maintainer: Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>+homepage: http://www.haskell.org/haddock/+bug-reports: https://github.com/haskell/haddock/issues+copyright: (c) Simon Marlow, David Waern+category: Documentation+build-type: Simple+cabal-version: >= 1.10+stability: experimental++data-dir:+ resources+data-files:+ html/frames.html+ html/haddock-util.js+ html/Classic.theme/haskell_icon.gif+ html/Classic.theme/minus.gif+ html/Classic.theme/plus.gif+ html/Classic.theme/xhaddock.css+ html/Ocean.std-theme/hslogo-16.png+ html/Ocean.std-theme/minus.gif+ html/Ocean.std-theme/ocean.css+ html/Ocean.std-theme/plus.gif+ html/Ocean.std-theme/synopsis.png+ latex/haddock.sty++library+ default-language:+ Haskell2010++ build-depends:+ base >= 4.3 && < 4.8+ , bytestring+ , filepath+ , directory+ , containers+ , deepseq+ , array+ , xhtml >= 3000.2 && < 3000.3+ , Cabal >= 1.10+ , ghc >= 7.8.2 && < 7.8.4++ , ghc-paths+ , haddock-library == 1.1.1.*++ hs-source-dirs:+ src++ ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2++ exposed-modules:+ Documentation.Haddock++ other-modules:+ Haddock+ Haddock.Interface+ Haddock.Interface.Rename+ Haddock.Interface.Create+ Haddock.Interface.AttachInstances+ Haddock.Interface.LexParseRn+ Haddock.Interface.ParseModuleHeader+ Haddock.Parser+ Haddock.Utils+ Haddock.Backends.Xhtml+ Haddock.Backends.Xhtml.Decl+ Haddock.Backends.Xhtml.DocMarkup+ Haddock.Backends.Xhtml.Layout+ Haddock.Backends.Xhtml.Names+ Haddock.Backends.Xhtml.Themes+ Haddock.Backends.Xhtml.Types+ Haddock.Backends.Xhtml.Utils+ Haddock.Backends.LaTeX+ Haddock.Backends.HaddockDB+ Haddock.Backends.Hoogle+ Haddock.ModuleTree+ Haddock.Types+ Haddock.Doc+ Haddock.Version+ Haddock.InterfaceFile+ Haddock.Options+ Haddock.GhcUtils+ Haddock.Convert+ Paths_haddock_api++source-repository head+ type: git+ location: https://github.com/haskell/haddock.git
+ resources/html/Classic.theme/haskell_icon.gif view
binary file changed (absent → 911 bytes)
+ resources/html/Classic.theme/minus.gif view
binary file changed (absent → 56 bytes)
+ resources/html/Classic.theme/plus.gif view
binary file changed (absent → 59 bytes)
+ resources/html/Classic.theme/xhaddock.css view
@@ -0,0 +1,499 @@+* {+ margin: 0;+ padding: 0;+}++.extension-list {+ list-style-type: none;+ margin-left: 0;+ padding-left: 0;+}++body {+ background-color: #ffffff;+ color: #000000;+ font-size: 100%;+ font-family: sans-serif;+ padding: 8px;+}++a:link { color: #0000e0; text-decoration: none }+a:visited { color: #0000a0; text-decoration: none }+a:hover { background-color: #e0e0ff; text-decoration: none }++/* <tt> font is a little too small in MSIE */+tt { font-size: 100%; }+pre { font-size: 100%; }+.keyword { text-decoration: underline; }+.caption {+ font-weight: bold;+ margin: 0;+ padding: 0;+}++h1 {+ padding-top: 15px;+ font-weight: bold;+ font-size: 150%;+}++h2 {+ padding-top: 10px;+ font-weight: bold;+ font-size: 130%+ }++h3 {+ padding-top: 5px;+ font-weight: bold;+ font-size: 110%+ }++h4, h5 {+ font-weight: bold;+ font-size: 100%+ }++h1, h2, h3, h4, h5 {+ margin-top: 0.5em;+ margin-bottom: 0.5em;+}++p {+ padding-top: 2px;+ padding-left: 10px;+}++ul, ol, dl {+ padding-top: 2px;+ padding-left: 10px;+ margin-left: 2.5em;+}++pre {+ padding-top: 2px;+ padding-left: 20px;+}++* + p, * + pre {+ margin-top: 1em;+}+.caption + p, .src + p {+ margin-top: 0;+}++.def {+ font-weight: bold;+}++ul.links {+ list-style: none;+ text-align: left;+ float: right;+ display: inline-table;+ padding: 0;+}++ul.links li {+ display: inline;+ border-left-width: 1px;+ border-left-color: #ffffff;+ border-left-style: solid;+ white-space: nowrap;+ padding: 1px 5px;+}++.hide { display: none; }+.show { }+.collapser {+ background: url(minus.gif) no-repeat 0 0.3em;+}+.expander {+ background: url(plus.gif) no-repeat 0 0.3em;+}+.collapser, .expander {+ padding-left: 14px;+ cursor: pointer;+}++#package-header {+ color: #ffffff;+ padding: 5px 5px 5px 31px;+ margin: 0 0 1px;+ background: #000099 url(haskell_icon.gif) no-repeat 5px 6px;+ position: relative;+}++#package-header .caption {+ font-weight: normal;+ font-style: normal;+}+#package-header a:link { color: #ffffff }+#package-header a:visited { color: #ffff00 }+#package-header a:hover { background-color: #6060ff; }+#package-header ul.links li:hover { background-color: #6060ff; }++div#style-menu-holder {+ position: relative;+ z-index: 2;+ display: inline;+}++#style-menu {+ position: absolute;+ z-index: 1;+ overflow: visible;+ background-color: #000099;+ margin: 0;+ width: 6em;+ text-align: center;+ right: 0;+ padding: 2px 2px 1px;+}++#style-menu li {+ display: list-item;+ border-style: none;+ margin: 0;+ padding: 3px;+ color: #000;+ list-style-type: none;+ border-top: 1px solid #ffffff;+}++#module-header {+ overflow: hidden; /* makes sure info float is properly contained */+ display: inline-block; /* triggers hasLayout in IE*/+}++#module-header {+ display: block; /* back to block */+ background-color: #0077dd;+ padding: 5px;+}++#module-header .caption {+ font-size: 200%;+ padding: .35em 0;+ font-weight: normal;+ font-style: normal;+}++table.info {+ color: #ffffff;+ display: block;+ float: right;+ max-width: 50%;+}++.info th, .info td {+ text-align: left;+ padding: 0 10px 0 0;+}+++#table-of-contents {+ margin-top: 1em;+ margin-bottom: 2em;+}++#table-of-contents ul {+ margin-top: 1em;+ margin-bottom: 1em;+ margin-left: 0;+ list-style-type: none;+ padding: 0;+}++#table-of-contents ul ul {+ margin-left: 2.5em;+}++#description .caption,+#synopsis .caption,+#module-list .caption,+#index .caption {+ padding-top: 15px;+ font-weight: bold;+ font-size: 150%+}++#synopsis {+ margin-bottom: 2em;+}++#synopsis .expander,+#synopsis .collapser {+ background: none;+ padding-left: inherit;+}++#synopsis .hide {+ display: inherit;+}++#synopsis ul {+ margin: 0;+ padding-top: 0;+ padding-left: 20px;+ list-style-type: none;+}++#synopsis li {+ margin-top: 8px;+ margin-bottom: 8px;+ padding: 3px;+}++#synopsis li li {+ padding: 0;+ margin-top: 0;+ margin-bottom: 0;+}+++div.top {+ margin-top: 1em;+ clear: left;+ margin-bottom: 1em;+}++div.top h5 {+ margin-left: 10px;+}+++.src {+ padding: 3px;+ background-color: #f0f0f0;+ font-family: monospace;+ margin-bottom: 0;+}+++.src a.link {+ float: right;+ border-left-width: 1px;+ border-left-color: #000099;+ border-left-style: solid;+ white-space: nowrap;+ font-size: small;+ padding: 0 8px 2px 5px;+ margin-right: -3px;+ background-color: #f0f0f0;+}++div.subs {+ margin-left: 10px;+ clear: both;+ margin-top: 2px;+}++.subs dl {+ margin-left: 0;+}++.subs dl dl {+ padding-left: 0;+ padding-top: 4px;+}++.subs dd+{+ margin: 2px 0 9px 2em;+}++.subs dd.empty {+ display: none;+}++.subs table {+ margin-left: 10px;+ border-spacing: 1px 1px;+ margin-top: 4px;+ margin-bottom: 4px;+}++.subs table table {+ margin-left: 0;+}++.arguments .caption,+.fields .caption {+ display: none;+}++/* need extra .subs in the selector to make it override the rules for .subs and .subs table */++.subs.arguments {+ margin: 0;+}++.subs.arguments table {+ border-spacing: 0;+ margin-top: 0;+ margin-bottom: 0;+}++.subs.arguments td.src {+ white-space: nowrap;+}++.subs.arguments + p {+ margin-top: 0;+}++.subs.associated-types,+.subs.methods {+ margin-left: 20px;+}++.subs.associated-types .caption,+.subs.methods .caption {+ margin-top: 0.5em;+ margin-left: -10px;+}++.subs.associated-types .src + .src,+.subs.methods .src + .src {+ margin-top: 8px;+}++p.arg {+ margin-bottom: 0;+}+p.arg span {+ background-color: #f0f0f0;+ font-family: monospace;+ white-space: nowrap;+ float: none;+}+++img.coll {+ width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em+}+++td.arg {+ padding: 3px;+ background-color: #f0f0f0;+ font-family: monospace;+ margin-bottom: 0;+}++td.rdoc p {+ margin-bottom: 0;+}++++#footer {+ background-color: #000099;+ color: #ffffff;+ padding: 4px+ }++#footer p {+ padding: 1px;+ margin: 0;+}++#footer a:link {+ color: #ffffff;+ text-decoration: underline+ }+#footer a:visited {+ color: #ffff00+ }+#footer a:hover {+ background-color: #6060ff+ }+++#module-list ul {+ list-style: none;+ padding-bottom: 15px;+ padding-left: 2px;+ margin: 0;+}++#module-list ul ul {+ padding-bottom: 0;+ padding-left: 20px;+}++#module-list li .package {+ float: right;+}+#mini #module-list .caption {+ display: none;+}++#index .caption {+}++#alphabet ul {+ list-style: none;+ padding: 0;+ margin: 0.5em 0 0;+}++#alphabet li {+ display: inline;+ margin: 0 0.2em;+}++#index .src {+ background: none;+ font-family: inherit;+}++#index td.alt {+ padding-left: 2em;+}++#index td {+ padding-top: 2px;+ padding-bottom: 1px;+ padding-right: 1em;+}+++#mini h1 { font-size: 130%; }+#mini h2 { font-size: 110%; }+#mini h3 { font-size: 100%; }+#mini h1, #mini h2, #mini h3 {+ margin-top: 0.5em;+ margin-bottom: 0.25em;+ padding: 0 0;+}++#mini h1 { border-bottom: 1px solid #ccc; }++#mini #module-header {+ margin: 0;+ padding: 0;+}+#mini #module-header .caption {+ font-size: 130%;+ background: #0077dd;+ padding: 0.25em;+ height: inherit;+ margin: 0;+}++#mini #interface .top {+ margin: 0;+ padding: 0;+}+#mini #interface .src {+ margin: 0;+ padding: 0;+ font-family: inherit;+ background: inherit;+}++.warning {+ color: red;+}
+ resources/html/Ocean.std-theme/hslogo-16.png view
binary file changed (absent → 1684 bytes)
+ resources/html/Ocean.std-theme/minus.gif view
binary file changed (absent → 56 bytes)
+ resources/html/Ocean.std-theme/ocean.css view
@@ -0,0 +1,577 @@+/* @group Fundamentals */++* { margin: 0; padding: 0 }++/* Is this portable? */+html {+ background-color: white;+ width: 100%;+ height: 100%;+}++body {+ background: white;+ color: black;+ text-align: left;+ min-height: 100%;+ position: relative;+}++p {+ margin: 0.8em 0;+}++ul, ol {+ margin: 0.8em 0 0.8em 2em;+}++dl {+ margin: 0.8em 0;+}++dt {+ font-weight: bold;+}+dd {+ margin-left: 2em;+}++a { text-decoration: none; }+a[href]:link { color: rgb(196,69,29); }+a[href]:visited { color: rgb(171,105,84); }+a[href]:hover { text-decoration:underline; }++/* @end */++/* @group Fonts & Sizes */++/* Basic technique & IE workarounds from YUI 3+ For reasons, see:+ http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css+ */++body {+ font:13px/1.4 sans-serif;+ *font-size:small; /* for IE */+ *font:x-small; /* for IE in quirks mode */+}++h1 { font-size: 146.5%; /* 19pt */ }+h2 { font-size: 131%; /* 17pt */ }+h3 { font-size: 116%; /* 15pt */ }+h4 { font-size: 100%; /* 13pt */ }+h5 { font-size: 100%; /* 13pt */ }++select, input, button, textarea {+ font:99% sans-serif;+}++table {+ font-size:inherit;+ font:100%;+}++pre, code, kbd, samp, tt, .src {+ font-family:monospace;+ *font-size:108%;+ line-height: 124%;+}++.links, .link {+ font-size: 85%; /* 11pt */+}++#module-header .caption {+ font-size: 182%; /* 24pt */+}++.info {+ font-size: 85%; /* 11pt */+}++#table-of-contents, #synopsis {+ /* font-size: 85%; /* 11pt */+}+++/* @end */++/* @group Common */++.caption, h1, h2, h3, h4, h5, h6 {+ font-weight: bold;+ color: rgb(78,98,114);+ margin: 0.8em 0 0.4em;+}++* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {+ margin-top: 2em;+}++h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {+ margin-top: inherit;+}++ul.links {+ list-style: none;+ text-align: left;+ float: right;+ display: inline-table;+ margin: 0 0 0 1em;+}++ul.links li {+ display: inline;+ border-left: 1px solid #d5d5d5;+ white-space: nowrap;+ padding: 0;+}++ul.links li a {+ padding: 0.2em 0.5em;+}++.hide { display: none; }+.show { display: inherit; }+.clear { clear: both; }++.collapser {+ background-image: url(minus.gif);+ background-repeat: no-repeat;+}+.expander {+ background-image: url(plus.gif);+ background-repeat: no-repeat;+}+p.caption.collapser,+p.caption.expander {+ background-position: 0 0.4em;+}+.collapser, .expander {+ padding-left: 14px;+ margin-left: -14px;+ cursor: pointer;+}++pre {+ padding: 0.25em;+ margin: 0.8em 0;+ background: rgb(229,237,244);+ overflow: auto;+ border-bottom: 0.25em solid white;+ /* white border adds some space below the box to compensate+ for visual extra space that paragraphs have between baseline+ and the bounding box */+}++.src {+ background: #f0f0f0;+ padding: 0.2em 0.5em;+}++.keyword { font-weight: normal; }+.def { font-weight: bold; }+++/* @end */++/* @group Page Structure */++#content {+ margin: 0 auto;+ padding: 0 2em 6em;+}++#package-header {+ background: rgb(41,56,69);+ border-top: 5px solid rgb(78,98,114);+ color: #ddd;+ padding: 0.2em;+ position: relative;+ text-align: left;+}++#package-header .caption {+ background: url(hslogo-16.png) no-repeat 0em;+ color: white;+ margin: 0 2em;+ font-weight: normal;+ font-style: normal;+ padding-left: 2em;+}++#package-header a:link, #package-header a:visited { color: white; }+#package-header a:hover { background: rgb(78,98,114); }++#module-header .caption {+ color: rgb(78,98,114);+ font-weight: bold;+ border-bottom: 1px solid #ddd;+}++table.info {+ float: right;+ padding: 0.5em 1em;+ border: 1px solid #ddd;+ color: rgb(78,98,114);+ background-color: #fff;+ max-width: 40%;+ border-spacing: 0;+ position: relative;+ top: -0.5em;+ margin: 0 0 0 2em;+}++.info th {+ padding: 0 1em 0 0;+}++div#style-menu-holder {+ position: relative;+ z-index: 2;+ display: inline;+}++#style-menu {+ position: absolute;+ z-index: 1;+ overflow: visible;+ background: #374c5e;+ margin: 0;+ text-align: center;+ right: 0;+ padding: 0;+ top: 1.25em;+}++#style-menu li {+ display: list-item;+ border-style: none;+ margin: 0;+ padding: 0;+ color: #000;+ list-style-type: none;+}++#style-menu li + li {+ border-top: 1px solid #919191;+}++#style-menu a {+ width: 6em;+ padding: 3px;+ display: block;+}++#footer {+ background: #ddd;+ border-top: 1px solid #aaa;+ padding: 0.5em 0;+ color: #666;+ text-align: center;+ position: absolute;+ bottom: 0;+ width: 100%;+ height: 3em;+}++/* @end */++/* @group Front Matter */++#table-of-contents {+ float: right;+ clear: right;+ background: #faf9dc;+ border: 1px solid #d8d7ad;+ padding: 0.5em 1em;+ max-width: 20em;+ margin: 0.5em 0 1em 1em;+}++#table-of-contents .caption {+ text-align: center;+ margin: 0;+}++#table-of-contents ul {+ list-style: none;+ margin: 0;+}++#table-of-contents ul ul {+ margin-left: 2em;+}++#description .caption {+ display: none;+}++#synopsis {+ display: none;+}++.no-frame #synopsis {+ display: block;+ position: fixed;+ right: 0;+ height: 80%;+ top: 10%;+ padding: 0;+}++#synopsis .caption {+ float: left;+ width: 29px;+ color: rgba(255,255,255,0);+ height: 110px;+ margin: 0;+ font-size: 1px;+ padding: 0;+}++#synopsis p.caption.collapser {+ background: url(synopsis.png) no-repeat -64px -8px;+}++#synopsis p.caption.expander {+ background: url(synopsis.png) no-repeat 0px -8px;+}++#synopsis ul {+ height: 100%;+ overflow: auto;+ padding: 0.5em;+ margin: 0;+}++#synopsis ul ul {+ overflow: hidden;+}++#synopsis ul,+#synopsis ul li.src {+ background-color: #faf9dc;+ white-space: nowrap;+ list-style: none;+ margin-left: 0;+}++/* @end */++/* @group Main Content */++#interface div.top { margin: 2em 0; }+#interface h1 + div.top,+#interface h2 + div.top,+#interface h3 + div.top,+#interface h4 + div.top,+#interface h5 + div.top {+ margin-top: 1em;+}+#interface p.src .link {+ float: right;+ color: #919191;+ border-left: 1px solid #919191;+ background: #f0f0f0;+ padding: 0 0.5em 0.2em;+ margin: 0 -0.5em 0 0.5em;+}++#interface span.fixity {+ color: #919191;+ border-left: 1px solid #919191;+ padding: 0.2em 0.5em 0.2em 0.5em;+ margin: 0 -1em 0 1em;+}++#interface span.rightedge {+ border-left: 1px solid #919191;+ padding: 0.2em 0 0.2em 0;+ margin: 0 0 0 1em;+}++#interface table { border-spacing: 2px; }+#interface td {+ vertical-align: top;+ padding-left: 0.5em;+}+#interface td.src {+ white-space: nowrap;+}+#interface td.doc p {+ margin: 0;+}+#interface td.doc p + p {+ margin-top: 0.8em;+}++.subs dl {+ margin: 0;+}++.subs dt {+ float: left;+ clear: left;+ display: block;+ margin: 1px 0;+}++.subs dd {+ float: right;+ width: 90%;+ display: block;+ padding-left: 0.5em;+ margin-bottom: 0.5em;+}++.subs dd.empty {+ display: none;+}++.subs dd p {+ margin: 0;+}++/* Render short-style data instances */+.inst ul {+ height: 100%;+ padding: 0.5em;+ margin: 0;+}++.inst, .inst li {+ list-style: none;+ margin-left: 1em;+}++.top p.src {+ border-top: 1px solid #ccc;+}++.subs, .doc {+ /* use this selector for one level of indent */+ padding-left: 2em;+}++.warning {+ color: red;+}++.arguments {+ margin-top: -0.4em;+}+.arguments .caption {+ display: none;+}++.fields { padding-left: 1em; }++.fields .caption { display: none; }++.fields p { margin: 0 0; }++/* this seems bulky to me+.methods, .constructors {+ background: #f8f8f8;+ border: 1px solid #eee;+}+*/++/* @end */++/* @group Auxillary Pages */+++.extension-list {+ list-style-type: none;+ margin-left: 0;+}++#mini {+ margin: 0 auto;+ padding: 0 1em 1em;+}++#mini > * {+ font-size: 93%; /* 12pt */+}++#mini #module-list .caption,+#mini #module-header .caption {+ font-size: 125%; /* 15pt */+}++#mini #interface h1,+#mini #interface h2,+#mini #interface h3,+#mini #interface h4 {+ font-size: 109%; /* 13pt */+ margin: 1em 0 0;+}++#mini #interface .top,+#mini #interface .src {+ margin: 0;+}++#mini #module-list ul {+ list-style: none;+ margin: 0;+}++#alphabet ul {+ list-style: none;+ padding: 0;+ margin: 0.5em 0 0;+ text-align: center;+}++#alphabet li {+ display: inline;+ margin: 0 0.25em;+}++#alphabet a {+ font-weight: bold;+}++#index .caption,+#module-list .caption { font-size: 131%; /* 17pt */ }++#index table {+ margin-left: 2em;+}++#index .src {+ font-weight: bold;+}+#index .alt {+ font-size: 77%; /* 10pt */+ font-style: italic;+ padding-left: 2em;+}++#index td + td {+ padding-left: 1em;+}++#module-list ul {+ list-style: none;+ margin: 0 0 0 2em;+}++#module-list li {+ clear: right;+}++#module-list span.collapser,+#module-list span.expander {+ background-position: 0 0.3em;+}++#module-list .package {+ float: right;+}++/* @end */
+ resources/html/Ocean.std-theme/plus.gif view
binary file changed (absent → 59 bytes)
+ resources/html/Ocean.std-theme/synopsis.png view
binary file changed (absent → 11327 bytes)
+ resources/html/frames.html view
@@ -0,0 +1,30 @@+<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+<title></title>+<script src="haddock-util.js" type="text/javascript"></script>+<script type="text/javascript"><!--+/*++ The synopsis frame needs to be updated using javascript, so we hide+ it by default and only show it if javascript is enabled.++ TODO: provide some means to disable it.+*/+function load() {+ var d = document.getElementById("inner-fs");+ d.rows = "50%,50%";+ postReframe();+}+--></script>+</head>+<frameset id="outer-fs" cols="25%,75%" onload="load()">+ <frameset id="inner-fs" rows="100%,0%">+ <frame src="index-frames.html" name="modules" />+ <frame src="" name="synopsis" />+ </frameset>+ <frame src="index.html" name="main" />+</frameset>+</html>
+ resources/html/haddock-util.js view
@@ -0,0 +1,344 @@+// Haddock JavaScript utilities++var rspace = /\s\s+/g,+ rtrim = /^\s+|\s+$/g;++function spaced(s) { return (" " + s + " ").replace(rspace, " "); }+function trim(s) { return s.replace(rtrim, ""); }++function hasClass(elem, value) {+ var className = spaced(elem.className || "");+ return className.indexOf( " " + value + " " ) >= 0;+}++function addClass(elem, value) {+ var className = spaced(elem.className || "");+ if ( className.indexOf( " " + value + " " ) < 0 ) {+ elem.className = trim(className + " " + value);+ }+}++function removeClass(elem, value) {+ var className = spaced(elem.className || "");+ className = className.replace(" " + value + " ", " ");+ elem.className = trim(className);+}++function toggleClass(elem, valueOn, valueOff, bool) {+ if (bool == null) { bool = ! hasClass(elem, valueOn); }+ if (bool) {+ removeClass(elem, valueOff);+ addClass(elem, valueOn);+ }+ else {+ removeClass(elem, valueOn);+ addClass(elem, valueOff);+ }+ return bool;+}+++function makeClassToggle(valueOn, valueOff)+{+ return function(elem, bool) {+ return toggleClass(elem, valueOn, valueOff, bool);+ }+}++toggleShow = makeClassToggle("show", "hide");+toggleCollapser = makeClassToggle("collapser", "expander");++function toggleSection(id)+{+ var b = toggleShow(document.getElementById("section." + id));+ toggleCollapser(document.getElementById("control." + id), b);+ rememberCollapsed(id, b);+ return b;+}++var collapsed = {};+function rememberCollapsed(id, b)+{+ if(b)+ delete collapsed[id]+ else+ collapsed[id] = null;++ var sections = [];+ for(var i in collapsed)+ {+ if(collapsed.hasOwnProperty(i))+ sections.push(i);+ }+ // cookie specific to this page; don't use setCookie which sets path=/+ document.cookie = "collapsed=" + escape(sections.join('+'));+}++function restoreCollapsed()+{+ var cookie = getCookie("collapsed");+ if(!cookie)+ return;++ var ids = cookie.split('+');+ for(var i in ids)+ {+ if(document.getElementById("section." + ids[i]))+ toggleSection(ids[i]);+ }+}++function setCookie(name, value) {+ document.cookie = name + "=" + escape(value) + ";path=/;";+}++function clearCookie(name) {+ document.cookie = name + "=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;";+}++function getCookie(name) {+ var nameEQ = name + "=";+ var ca = document.cookie.split(';');+ for(var i=0;i < ca.length;i++) {+ var c = ca[i];+ while (c.charAt(0)==' ') c = c.substring(1,c.length);+ if (c.indexOf(nameEQ) == 0) {+ return unescape(c.substring(nameEQ.length,c.length));+ }+ }+ return null;+}++++var max_results = 75; // 50 is not enough to search for map in the base libraries+var shown_range = null;+var last_search = null;++function quick_search()+{+ perform_search(false);+}++function full_search()+{+ perform_search(true);+}+++function perform_search(full)+{+ var text = document.getElementById("searchbox").value.toLowerCase();+ if (text == last_search && !full) return;+ last_search = text;+ + var table = document.getElementById("indexlist");+ var status = document.getElementById("searchmsg");+ var children = table.firstChild.childNodes;+ + // first figure out the first node with the prefix+ var first = bisect(-1);+ var last = (first == -1 ? -1 : bisect(1));++ if (first == -1)+ {+ table.className = "";+ status.innerHTML = "No results found, displaying all";+ }+ else if (first == 0 && last == children.length - 1)+ {+ table.className = "";+ status.innerHTML = "";+ }+ else if (last - first >= max_results && !full)+ {+ table.className = "";+ status.innerHTML = "More than " + max_results + ", press Search to display";+ }+ else+ {+ // decide what you need to clear/show+ if (shown_range)+ setclass(shown_range[0], shown_range[1], "indexrow");+ setclass(first, last, "indexshow");+ shown_range = [first, last];+ table.className = "indexsearch";+ status.innerHTML = "";+ }++ + function setclass(first, last, status)+ {+ for (var i = first; i <= last; i++)+ {+ children[i].className = status;+ }+ }+ + + // do a binary search, treating 0 as ...+ // return either -1 (no 0's found) or location of most far match+ function bisect(dir)+ {+ var first = 0, finish = children.length - 1;+ var mid, success = false;++ while (finish - first > 3)+ {+ mid = Math.floor((finish + first) / 2);++ var i = checkitem(mid);+ if (i == 0) i = dir;+ if (i == -1)+ finish = mid;+ else+ first = mid;+ }+ var a = (dir == 1 ? first : finish);+ var b = (dir == 1 ? finish : first);+ for (var i = b; i != a - dir; i -= dir)+ {+ if (checkitem(i) == 0) return i;+ }+ return -1;+ } + + + // from an index, decide what the result is+ // 0 = match, -1 is lower, 1 is higher+ function checkitem(i)+ {+ var s = getitem(i).toLowerCase().substr(0, text.length);+ if (s == text) return 0;+ else return (s > text ? -1 : 1);+ }+ + + // from an index, get its string+ // this abstracts over alternates+ function getitem(i)+ {+ for ( ; i >= 0; i--)+ {+ var s = children[i].firstChild.firstChild.data;+ if (s.indexOf(' ') == -1)+ return s;+ }+ return ""; // should never be reached+ }+}++function setSynopsis(filename) {+ if (parent.window.synopsis) {+ if (parent.window.synopsis.location.replace) {+ // In Firefox this avoids adding the change to the history.+ parent.window.synopsis.location.replace(filename);+ } else {+ parent.window.synopsis.location = filename;+ }+ }+}++function addMenuItem(html) {+ var menu = document.getElementById("page-menu");+ if (menu) {+ var btn = menu.firstChild.cloneNode(false);+ btn.innerHTML = html;+ menu.appendChild(btn);+ }+}++function adjustForFrames() {+ var bodyCls;+ + if (parent.location.href == window.location.href) {+ // not in frames, so add Frames button+ addMenuItem("<a href='#' onclick='reframe();return true;'>Frames</a>");+ bodyCls = "no-frame";+ }+ else {+ bodyCls = "in-frame";+ }+ addClass(document.body, bodyCls);+}++function reframe() {+ setCookie("haddock-reframe", document.URL);+ window.location = "frames.html";+}++function postReframe() {+ var s = getCookie("haddock-reframe");+ if (s) {+ parent.window.main.location = s;+ clearCookie("haddock-reframe");+ }+}++function styles() {+ var i, a, es = document.getElementsByTagName("link"), rs = [];+ for (i = 0; a = es[i]; i++) {+ if(a.rel.indexOf("style") != -1 && a.title) {+ rs.push(a);+ }+ }+ return rs;+}++function addStyleMenu() {+ var as = styles();+ var i, a, btns = "";+ for(i=0; a = as[i]; i++) {+ btns += "<li><a href='#' onclick=\"setActiveStyleSheet('"+ + a.title + "'); return false;\">"+ + a.title + "</a></li>"+ }+ if (as.length > 1) {+ var h = "<div id='style-menu-holder'>"+ + "<a href='#' onclick='styleMenu(); return false;'>Style ▾</a>"+ + "<ul id='style-menu' class='hide'>" + btns + "</ul>"+ + "</div>";+ addMenuItem(h);+ }+}++function setActiveStyleSheet(title) {+ var as = styles();+ var i, a, found;+ for(i=0; a = as[i]; i++) {+ a.disabled = true;+ // need to do this always, some browsers are edge triggered+ if(a.title == title) {+ found = a;+ }+ }+ if (found) {+ found.disabled = false;+ setCookie("haddock-style", title);+ }+ else {+ as[0].disabled = false;+ clearCookie("haddock-style");+ }+ styleMenu(false);+}++function resetStyle() {+ var s = getCookie("haddock-style");+ if (s) setActiveStyleSheet(s);+}+++function styleMenu(show) {+ var m = document.getElementById('style-menu');+ if (m) toggleShow(m, show);+}+++function pageLoad() {+ addStyleMenu();+ adjustForFrames();+ resetStyle();+ restoreCollapsed();+}+
+ resources/latex/haddock.sty view
@@ -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}
+ src/Documentation/Haddock.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module : Documentation.Haddock+-- Copyright : (c) David Waern 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskellorg+-- Stability : experimental+-- Portability : portable+--+-- The Haddock API: A rudimentory, highly experimental API exposing some of+-- the internals of Haddock. Don't expect it to be stable.+-----------------------------------------------------------------------------+module Documentation.Haddock (++ -- * Interface+ Interface(..),+ InstalledInterface(..),+ createInterfaces,+ processModules,++ -- * Export items & declarations+ ExportItem(..),+ DocForDecl,+ FnArgsDoc,++ -- * Cross-referencing+ LinkEnv,+ DocName(..),++ -- * Instances+ DocInstance,+ InstHead,++ -- * Documentation comments+ Doc,+ DocH(..),+ Example(..),+ Hyperlink(..),+ DocMarkup(..),+ Documentation(..),+ ArgMap,+ AliasMap,+ WarningMap,+ DocMap,+ HaddockModInfo(..),+ markup,++ -- * Interface files+ InterfaceFile(..),+ readInterfaceFile,+ nameCacheFromGhc,+ freshNameCache,+ NameCacheAccessor,++ -- * Flags and options+ Flag(..),+ DocOption(..),++ -- * Error handling+ HaddockException(..),++ -- * Program entry point+ haddock,+ haddockWithGhc,+ getGhcDirs,+ withGhc+) where+++import Haddock.InterfaceFile+import Haddock.Interface+import Haddock.Types+import Haddock.Options+import Haddock.Utils+import Haddock+++-- | Create 'Interface' structures from a given list of Haddock command-line+-- flags and file or module names (as accepted by 'haddock' executable). Flags+-- that control documentation generation or show help or version information+-- are ignored.+createInterfaces+ :: [Flag] -- ^ A list of command-line flags+ -> [String] -- ^ File or module names+ -> IO [Interface] -- ^ Resulting list of interfaces+createInterfaces flags modules = do+ (_, ifaces, _) <- withGhc flags (readPackagesAndProcessModules flags modules)+ return ifaces
+ src/Haddock.hs view
@@ -0,0 +1,488 @@+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2010,+-- Mateusz Kowalczyk 2014+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Haddock - A Haskell Documentation Tool+--+-- Program entry point and top-level code.+-----------------------------------------------------------------------------+module Haddock (+ haddock,+ haddockWithGhc,+ getGhcDirs,+ readPackagesAndProcessModules,+ withGhc+) where++import Haddock.Backends.Xhtml+import Haddock.Backends.Xhtml.Themes (getThemes)+import Haddock.Backends.LaTeX+import Haddock.Backends.Hoogle+import Haddock.Interface+import Haddock.Parser+import Haddock.Types+import Haddock.Version+import Haddock.InterfaceFile+import Haddock.Options+import Haddock.Utils+import Haddock.GhcUtils hiding (pretty)++import Control.Monad hiding (forM_)+import Data.Foldable (forM_)+import Data.List (isPrefixOf)+import Control.Exception+import Data.Maybe+import Data.IORef+import qualified Data.Map as Map+import System.IO+import System.Exit+import System.Directory++#if defined(mingw32_HOST_OS)+import Foreign+import Foreign.C+import Data.Int+#endif++#ifdef IN_GHC_TREE+import System.FilePath+#else+import qualified GHC.Paths as GhcPaths+import Paths_haddock_api (getDataDir)+#endif++import GHC hiding (verbosity)+import Config+import DynFlags hiding (verbosity)+import StaticFlags (discardStaticFlags)+import Panic (handleGhcException)+import Module++--------------------------------------------------------------------------------+-- * Exception handling+--------------------------------------------------------------------------------+++handleTopExceptions :: IO a -> IO a+handleTopExceptions =+ handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions+++-- | Either returns normally or throws an ExitCode exception;+-- all other exceptions are turned into exit exceptions.+handleNormalExceptions :: IO a -> IO a+handleNormalExceptions inner =+ (inner `onException` hFlush stdout)+ `catches`+ [ Handler (\(code :: ExitCode) -> exitWith code)++ , Handler (\(ex :: AsyncException) ->+ case ex of+ StackOverflow -> do+ putStrLn "stack overflow: use -g +RTS -K<size> to increase it"+ exitFailure+ _ -> do+ putStrLn ("haddock: " ++ show ex)+ exitFailure)++ , Handler (\(ex :: SomeException) -> do+ putStrLn ("haddock: internal error: " ++ show ex)+ exitFailure)+ ]+++handleHaddockExceptions :: IO a -> IO a+handleHaddockExceptions inner =+ catches inner [Handler handler]+ where+ handler (e::HaddockException) = do+ putStrLn $ "haddock: " ++ show e+ exitFailure+++handleGhcExceptions :: IO a -> IO a+handleGhcExceptions =+ -- error messages propagated as exceptions+ handleGhcException $ \e -> do+ hFlush stdout+ case e of+ PhaseFailed _ code -> exitWith code+ _ -> do+ print (e :: GhcException)+ exitFailure+++-------------------------------------------------------------------------------+-- * Top level+-------------------------------------------------------------------------------+++-- | Run Haddock with given list of arguments.+--+-- Haddock's own main function is defined in terms of this:+--+-- > main = getArgs >>= haddock+haddock :: [String] -> IO ()+haddock args = haddockWithGhc withGhc args++haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()+haddockWithGhc ghc args = handleTopExceptions $ do++ -- Parse command-line flags and handle some of them initially.+ -- TODO: unify all of this (and some of what's in the 'render' function),+ -- into one function that returns a record with a field for each option,+ -- or which exits with an error or help message.+ (flags, files) <- parseHaddockOpts args+ shortcutFlags flags+ qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}++ -- inject dynamic-too into flags before we proceed+ flags' <- ghc flags $ do+ df <- getDynFlags+ case lookup "GHC Dynamic" (compilerInfo df) of+ Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags+ _ -> return flags++ unless (Flag_NoWarnings `elem` flags) $ do+ forM_ (warnings args) $ \warning -> do+ hPutStrLn stderr warning++ ghc flags' $ do++ dflags <- getDynFlags++ if not (null files) then do+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files++ -- Dump an "interface file" (.haddock file), if requested.+ forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do+ writeInterfaceFile path InterfaceFile {+ ifInstalledIfaces = map toInstalledIface ifaces+ , ifLinkEnv = homeLinks+ }++ -- Render the interfaces.+ liftIO $ renderStep dflags flags qual packages ifaces++ else do+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $+ throwE "No input file(s)."++ -- Get packages supplied with --read-interface.+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)++ -- Render even though there are no input files (usually contents/index).+ liftIO $ renderStep dflags flags qual packages []++-- | Create warnings about potential misuse of -optghc+warnings :: [String] -> [String]+warnings = map format . filter (isPrefixOf "-optghc")+ where+ format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]+++withGhc :: [Flag] -> Ghc a -> IO a+withGhc flags action = do+ libDir <- fmap snd (getGhcDirs flags)++ -- Catches all GHC source errors, then prints and re-throws them.+ let handleSrcErrors action' = flip handleSourceError action' $ \err -> do+ printException err+ liftIO exitFailure++ withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)+++readPackagesAndProcessModules :: [Flag] -> [String]+ -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)+readPackagesAndProcessModules flags files = do+ -- Get packages supplied with --read-interface.+ packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)++ -- Create the interfaces -- this is the core part of Haddock.+ let ifaceFiles = map snd packages+ (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles++ return (packages, ifaces, homeLinks)+++renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()+renderStep dflags flags qual pkgs interfaces = do+ updateHTMLXRefs pkgs+ let+ ifaceFiles = map snd pkgs+ installedIfaces = concatMap ifInstalledIfaces ifaceFiles+ srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]+ render dflags flags qual interfaces installedIfaces srcMap+++-- | Render the interfaces with whatever backend is specified in the flags.+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()+render dflags flags qual ifaces installedIfaces srcMap = do++ let+ title = fromMaybe "" (optTitle flags)+ unicode = Flag_UseUnicode `elem` flags+ pretty = Flag_PrettyHtml `elem` flags+ opt_wiki_urls = wikiUrls flags+ opt_contents_url = optContentsUrl flags+ opt_index_url = optIndexUrl flags+ odir = outputDir flags+ opt_latex_style = optLaTeXStyle flags++ visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]++ -- /All/ visible interfaces including external package modules.+ allIfaces = map toInstalledIface ifaces ++ installedIfaces+ allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]++ pkgMod = ifaceMod (head ifaces)+ pkgId = modulePackageId pkgMod+ pkgStr = Just (packageIdString pkgId)+ (pkgName,pkgVer) = modulePackageInfo pkgMod++ (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags+ srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity+ -- TODO: Get these from the interface files as with srcMap+ srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity+ sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')++ libDir <- getHaddockLibDir flags+ prologue <- getPrologue dflags flags+ themes <- getThemes libDir flags >>= either bye return++ when (Flag_GenIndex `elem` flags) $ do+ ppHtmlIndex odir title pkgStr+ themes opt_contents_url sourceUrls' opt_wiki_urls+ allVisibleIfaces pretty+ copyHtmlBits odir libDir themes++ when (Flag_GenContents `elem` flags) $ do+ ppHtmlContents odir title pkgStr+ themes opt_index_url sourceUrls' opt_wiki_urls+ allVisibleIfaces True prologue pretty+ (makeContentsQual qual)+ copyHtmlBits odir libDir themes++ when (Flag_Html `elem` flags) $ do+ ppHtml title pkgStr visibleIfaces odir+ prologue+ themes sourceUrls' opt_wiki_urls+ opt_contents_url opt_index_url unicode qual+ pretty+ copyHtmlBits odir libDir themes++ when (Flag_Hoogle `elem` flags) $ do+ let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName+ ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir++ when (Flag_LaTeX `elem` flags) $ do+ ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style+ libDir+++-------------------------------------------------------------------------------+-- * Reading and dumping interface files+-------------------------------------------------------------------------------+++readInterfaceFiles :: MonadIO m+ => NameCacheAccessor m+ -> [(DocPaths, FilePath)]+ -> m [(DocPaths, InterfaceFile)]+readInterfaceFiles name_cache_accessor pairs = do+ catMaybes `liftM` mapM tryReadIface pairs+ where+ -- try to read an interface, warn if we can't+ tryReadIface (paths, file) =+ readInterfaceFile name_cache_accessor file >>= \case+ Left err -> liftIO $ do+ putStrLn ("Warning: Cannot read " ++ file ++ ":")+ putStrLn (" " ++ err)+ putStrLn "Skipping this interface."+ return Nothing+ Right f -> return $ Just (paths, f)+++-------------------------------------------------------------------------------+-- * Creating a GHC session+-------------------------------------------------------------------------------+++-- | Start a GHC session with the -haddock flag set. Also turn off+-- compilation and linking. Then run the given 'Ghc' action.+withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a+withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do+ dynflags <- getSessionDynFlags+ dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {+ hscTarget = HscNothing,+ ghcMode = CompManager,+ ghcLink = NoLink+ }+ let dynflags'' = gopt_unset dynflags' Opt_SplitObjs+ defaultCleanupHandler dynflags'' $ do+ -- ignore the following return-value, which is a list of packages+ -- that may need to be re-linked: Haddock doesn't do any+ -- dynamic or static linking at all!+ _ <- setSessionDynFlags dynflags''+ ghcActs dynflags''+ where+ parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags+ parseGhcFlags dynflags = do+ -- TODO: handle warnings?++ -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot+ -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if+ -- we pass any, Haddock will fail. Since StaticFlags are global to the+ -- GHC invocation, there's also no way to reparse/save them to set them+ -- again properly.+ --+ -- This is a bit of a hack until we get rid of the rest of the remaining+ -- StaticFlags. See GHC issue #8276.+ let flags' = discardStaticFlags flags+ (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')+ if not (null rest)+ then throwE ("Couldn't parse GHC options: " ++ unwords flags')+ else return dynflags'++-------------------------------------------------------------------------------+-- * Misc+-------------------------------------------------------------------------------+++getHaddockLibDir :: [Flag] -> IO String+getHaddockLibDir flags =+ case [str | Flag_Lib str <- flags] of+ [] -> do+#ifdef IN_GHC_TREE+ getInTreeDir+#else+ d <- getDataDir -- provided by Cabal+ doesDirectoryExist d >>= \exists -> case exists of+ True -> return d+ False -> do+ -- If directory does not exist then we are probably invoking from+ -- ./dist/build/haddock/haddock so we use ./resources as a fallback.+ doesDirectoryExist "resources" >>= \exists_ -> case exists_ of+ True -> return "resources"+ False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")+#endif+ fs -> return (last fs)+++getGhcDirs :: [Flag] -> IO (String, String)+getGhcDirs flags = do+ case [ dir | Flag_GhcLibDir dir <- flags ] of+ [] -> do+#ifdef IN_GHC_TREE+ libDir <- getInTreeDir+ return (ghcPath, libDir)+#else+ return (ghcPath, GhcPaths.libdir)+#endif+ xs -> return (ghcPath, last xs)+ where+#ifdef IN_GHC_TREE+ ghcPath = "not available"+#else+ ghcPath = GhcPaths.ghc+#endif+++shortcutFlags :: [Flag] -> IO ()+shortcutFlags flags = do+ usage <- getUsage++ when (Flag_Help `elem` flags) (bye usage)+ when (Flag_Version `elem` flags) byeVersion+ when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n"))+ when (Flag_CompatibleInterfaceVersions `elem` flags)+ (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\n"))+ when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n"))++ when (Flag_PrintGhcPath `elem` flags) $ do+ dir <- fmap fst (getGhcDirs flags)+ bye $ dir ++ "\n"++ when (Flag_PrintGhcLibDir `elem` flags) $ do+ dir <- fmap snd (getGhcDirs flags)+ bye $ dir ++ "\n"++ when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $+ throwE "Unicode can only be enabled for HTML output."++ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)+ && Flag_Html `elem` flags) $+ throwE "-h cannot be used with --gen-index or --gen-contents"++ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)+ && Flag_Hoogle `elem` flags) $+ throwE "--hoogle cannot be used with --gen-index or --gen-contents"++ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)+ && Flag_LaTeX `elem` flags) $+ throwE "--latex cannot be used with --gen-index or --gen-contents"+ where+ byeVersion = bye $+ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"+ ++ "Ported to use the GHC API by David Waern 2006-2008\n"+++updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()+updateHTMLXRefs packages = do+ writeIORef html_xrefs_ref (Map.fromList mapping)+ writeIORef html_xrefs_ref' (Map.fromList mapping')+ where+ mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages+ , iface <- ifInstalledIfaces ifaces ]+ mapping' = [ (moduleName m, html) | (m, html) <- mapping ]+++getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))+getPrologue dflags flags =+ case [filename | Flag_Prologue filename <- flags ] of+ [] -> return Nothing+ [filename] -> withFile filename ReadMode $ \h -> do+ hSetEncoding h utf8+ str <- hGetContents h+ return . Just $ parseParas dflags str+ _ -> throwE "multiple -p/--prologue options"+++#ifdef IN_GHC_TREE++getInTreeDir :: IO String+getInTreeDir = getExecDir >>= \case+ Nothing -> error "No GhcDir found"+ Just d -> return (d </> ".." </> "lib")+++getExecDir :: IO (Maybe String)+#if defined(mingw32_HOST_OS)+getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.+ where+ try_size size = allocaArray (fromIntegral size) $ \buf -> do+ ret <- c_GetModuleFileName nullPtr buf size+ case ret of+ 0 -> return Nothing+ _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf+ | otherwise -> try_size (size * 2)++foreign import stdcall unsafe "windows.h GetModuleFileNameW"+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32+#else+getExecDir = return Nothing+#endif++#endif
+ src/Haddock/Backends/HaddockDB.hs view
@@ -0,0 +1,170 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.HaddockDB+-- Copyright : (c) Simon Marlow 2003+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.HaddockDB (ppDocBook) where++{-+import HaddockTypes+import HaddockUtil+import HsSyn2++import Text.PrettyPrint+-}++-----------------------------------------------------------------------------+-- Printing the results in DocBook format++ppDocBook :: a+ppDocBook = error "not working"+{-+ppDocBook :: FilePath -> [(Module, Interface)] -> String+ppDocBook odir mods = render (ppIfaces mods)++ppIfaces mods+ = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["+ $$ text "]>"+ $$ text "<book>"+ $$ text "<bookinfo>"+ $$ text "<author><othername>HaskellDoc version 0.0</othername></author>"+ $$ text "</bookinfo>"+ $$ text "<article>"+ $$ vcat (map do_mod mods)+ $$ text "</article></book>"+ where+ do_mod (Module mod, iface)+ = text "<sect1 id=\"sec-" <> text mod <> text "\">"+ $$ text "<title><literal>" + <> text mod+ <> text "</literal></title>"+ $$ text "<indexterm><primary><literal>"+ <> text mod+ <> text "</literal></primary></indexterm>"+ $$ text "<variablelist>"+ $$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))+ $$ text "</variablelist>"+ $$ text "</sect1>"+ + do_export mod decl | (nm:_) <- declBinders decl+ = text "<varlistentry id=" <> ppLinkId mod nm <> char '>'+ $$ text "<term><literal>" + <> do_decl decl+ <> text "</literal></term>"+ $$ text "<listitem>"+ $$ text "<para>"+ $$ text "</para>"+ $$ text "</listitem>"+ $$ text "</varlistentry>"+ do_export _ _ = empty++ do_decl (HsTypeSig _ [nm] ty _) + = ppHsName nm <> text " :: " <> ppHsType ty+ do_decl (HsTypeDecl _ nm args ty _)+ = hsep ([text "type", ppHsName nm ]+ ++ map ppHsName args + ++ [equals, ppHsType ty])+ do_decl (HsNewTypeDecl loc ctx nm args con drv _)+ = hsep ([text "data", ppHsName nm] -- data, not newtype+ ++ map ppHsName args+ ) <+> equals <+> ppHsConstr con -- ToDo: derivings+ do_decl (HsDataDecl loc ctx nm args cons drv _)+ = hsep ([text "data", {-ToDo: context-}ppHsName nm]+ ++ map ppHsName args)+ <+> vcat (zipWith (<+>) (equals : repeat (char '|'))+ (map ppHsConstr cons))+ do_decl (HsClassDecl loc ty fds decl _)+ = hsep [text "class", ppHsType ty]+ do_decl decl+ = empty++ppHsConstr :: HsConDecl -> Doc+ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =+ ppHsName name+ <> (braces . hsep . punctuate comma . map ppField $ fieldList)+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = + hsep (ppHsName name : map ppHsBangType typeList)++ppField (HsFieldDecl ns ty doc)+ = hsep (punctuate comma (map ppHsName ns) +++ [text "::", ppHsBangType ty])++ppHsBangType :: HsBangType -> Doc+ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty+ppHsBangType (HsUnBangedTy ty) = ppHsType ty++ppHsContext :: HsContext -> Doc+ppHsContext [] = empty+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> + hsep (map ppHsAType b)) context)++ppHsType :: HsType -> Doc+ppHsType (HsForAllType Nothing context htype) =+ hsep [ ppHsContext context, text "=>", ppHsType htype]+ppHsType (HsForAllType (Just tvs) [] htype) =+ hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])+ppHsType (HsForAllType (Just tvs) context htype) =+ hsep (text "forall" : map ppHsName tvs ++ text "." : + ppHsContext context : text "=>" : [ppHsType htype])+ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]+ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]+ppHsType t = ppHsBType t++ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )+ = brackets $ ppHsType b+ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]+ppHsBType t = ppHsAType t++ppHsAType :: HsType -> Doc+ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l+ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l+-- special case+ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )+ = brackets $ ppHsType b+ppHsAType (HsTyVar name) = ppHsName name+ppHsAType (HsTyCon name) = ppHsQName name+ppHsAType t = parens $ ppHsType t++ppHsQName :: HsQName -> Doc+ppHsQName (UnQual str) = ppHsName str+ppHsQName n@(Qual (Module mod) str)+ | n == unit_con_name = ppHsName str+ | isSpecial str = ppHsName str+ | otherwise + = text "<link linkend=" <> ppLinkId mod str <> char '>'+ <> ppHsName str+ <> text "</link>"++isSpecial (HsTyClsName id) | HsSpecial _ <- id = True+isSpecial (HsVarName id) | HsSpecial _ <- id = True+isSpecial _ = False++ppHsName :: HsName -> Doc+ppHsName (HsTyClsName id) = ppHsIdentifier id+ppHsName (HsVarName id) = ppHsIdentifier id++ppHsIdentifier :: HsIdentifier -> Doc+ppHsIdentifier (HsIdent str) = text str+ppHsIdentifier (HsSymbol str) = text str+ppHsIdentifier (HsSpecial str) = text str++ppLinkId :: String -> HsName -> Doc+ppLinkId mod str+ = hcat [char '\"', text mod, char '.', ppHsName str, char '\"']++-- -----------------------------------------------------------------------------+-- * Misc++parenList :: [Doc] -> Doc+parenList = parens . fsep . punctuate comma++ubxParenList :: [Doc] -> Doc+ubxParenList = ubxparens . fsep . punctuate comma++ubxparens p = text "(#" <> p <> text "#)"+-}
+ src/Haddock/Backends/Hoogle.hs view
@@ -0,0 +1,331 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Hoogle+-- Copyright : (c) Neil Mitchell 2006-2008+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Write out Hoogle compatible documentation+-- http://www.haskell.org/hoogle/+-----------------------------------------------------------------------------+module Haddock.Backends.Hoogle (+ ppHoogle+ ) where+++import Haddock.GhcUtils+import Haddock.Types+import Haddock.Utils hiding (out)+import GHC+import Outputable++import Data.Char+import Data.List+import Data.Maybe+import System.FilePath+import System.IO++prefix :: [String]+prefix = ["-- Hoogle documentation, generated by Haddock"+ ,"-- See Hoogle, http://www.haskell.org/hoogle/"+ ,""]+++ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()+ppHoogle dflags package version synopsis prologue ifaces odir = do+ let filename = package ++ ".txt"+ contents = prefix +++ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue +++ ["@package " ++ package] +++ ["@version " ++ version | version /= ""] +++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]+ h <- openFile (odir </> filename) WriteMode+ hSetEncoding h utf8+ hPutStr h (unlines contents)+ hClose h++ppModule :: DynFlags -> Interface -> [String]+ppModule dflags iface =+ "" : ppDocumentation dflags (ifaceDoc iface) +++ ["module " ++ moduleString (ifaceMod iface)] +++ concatMap (ppExport dflags) (ifaceExportItems iface) +++ concatMap (ppInstance dflags) (ifaceInstances iface)+++---------------------------------------------------------------------+-- Utility functions++dropHsDocTy :: HsType a -> HsType a+dropHsDocTy = f+ where+ g (L src x) = L src (f x)+ f (HsForAllTy a b c d) = HsForAllTy a b c (g d)+ f (HsBangTy a b) = HsBangTy a (g b)+ f (HsAppTy a b) = HsAppTy (g a) (g b)+ f (HsFunTy a b) = HsFunTy (g a) (g b)+ f (HsListTy a) = HsListTy (g a)+ f (HsPArrTy a) = HsPArrTy (g a)+ f (HsTupleTy a b) = HsTupleTy a (map g b)+ f (HsOpTy a b c) = HsOpTy (g a) b (g c)+ f (HsParTy a) = HsParTy (g a)+ f (HsKindSig a b) = HsKindSig (g a) b+ f (HsDocTy a _) = f $ unL a+ f x = x++outHsType :: OutputableBndr a => DynFlags -> HsType a -> String+outHsType dflags = out dflags . dropHsDocTy+++makeExplicit :: HsType a -> HsType a+makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c+makeExplicit x = x++makeExplicitL :: LHsType a -> LHsType a+makeExplicitL (L src x) = L src (makeExplicit x)+++dropComment :: String -> String+dropComment (' ':'-':'-':' ':_) = []+dropComment (x:xs) = x : dropComment xs+dropComment [] = []+++out :: Outputable a => DynFlags -> a -> String+out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr+ where+ f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs+ f (x:xs) = x : f xs+ f [] = []+++operator :: String -> String+operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"+operator x = x+++---------------------------------------------------------------------+-- How to print each export++ppExport :: DynFlags -> ExportItem Name -> [String]+ppExport dflags ExportDecl { expItemDecl = L _ decl+ , expItemMbDoc = (dc, _)+ , expItemSubDocs = subdocs+ } = ppDocumentation dflags dc ++ f decl+ where+ f (TyClD d@DataDecl{}) = ppData dflags d subdocs+ f (TyClD d@SynDecl{}) = ppSynonym dflags d+ f (TyClD d@ClassDecl{}) = ppClass dflags d+ f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ+ f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ+ f (SigD sig) = ppSig dflags sig+ f _ = []+ppExport _ _ = []+++ppSig :: DynFlags -> Sig Name -> [String]+ppSig dflags (TypeSig names sig)+ = [operator prettyNames ++ " :: " ++ outHsType dflags typ]+ where+ prettyNames = intercalate ", " $ map (out dflags) names+ typ = case unL sig of+ HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c+ x -> x+ppSig _ _ = []+++-- note: does not yet output documentation for class methods+ppClass :: DynFlags -> TyClDecl Name -> [String]+ppClass dflags x = out dflags x{tcdSigs=[]} :+ concatMap (ppSig dflags . addContext . unL) (tcdSigs x)+ where+ addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)+ addContext (MinimalSig sig) = MinimalSig sig+ addContext _ = error "expected TypeSig"++ f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d+ f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)++ context = nlHsTyConApp (tcdName x)+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))+++ppInstance :: DynFlags -> ClsInst -> [String]+ppInstance dflags x = [dropComment $ out dflags x]+++ppSynonym :: DynFlags -> TyClDecl Name -> [String]+ppSynonym dflags x = [out dflags x]++ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]+ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :+ concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)+ where++ -- GHC gives out "data Bar =", we want to delete the equals+ -- also writes data : a b, when we want data (:) a b+ showData d = unwords $ map f $ if last xs == "=" then init xs else xs+ where+ xs = words $ out dflags d+ nam = out dflags $ tyClDeclLName d+ f w = if w == nam then operator nam else w+ppData _ _ _ = panic "ppData"++-- | for constructors, and named-fields...+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]+lookupCon dflags subdocs (L _ name) = case lookup name subdocs of+ Just (d, _) -> ppDocumentation dflags d+ _ -> []++ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]+ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)+ ++ f (con_details con)+ where+ f (PrefixCon args) = [typeSig name $ args ++ [resType]]+ f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]+ f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat+ [lookupCon dflags subdocs (cd_fld_name r) +++ [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]+ | r <- recs]++ funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))+ apps = foldl1 (\x y -> reL $ HsAppTy x y)++ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)+ name = out dflags $ unL $ con_name con++ resType = case con_res con of+ ResTyH98 -> apps $ map (reL . HsTyVar) $+ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]+ ResTyGADT x -> x+++---------------------------------------------------------------------+-- DOCUMENTATION++ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]+ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w+++doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]+doc dflags = docWith dflags ""+++docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]+docWith _ [] Nothing = []+docWith dflags header d+ = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $+ [header | header /= ""] ++ ["" | header /= "" && isJust d] +++ maybe [] (showTags . markup (markupTag dflags)) d+++data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String+ deriving Show++type Tags = [Tag]++box :: (a -> b) -> a -> [b]+box f x = [f x]++str :: String -> [Tag]+str a = [Str a]++-- want things like paragraph, pre etc to be handled by blank lines in the source document+-- and things like \n and \t converted away+-- much like blogger in HTML mode+-- everything else wants to be included as tags, neatly nested for some (ul,li,ol)+-- or inlne for others (a,i,tt)+-- entities (&,>,<) should always be appropriately escaped++markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]+markupTag dflags = Markup {+ markupParagraph = box TagP,+ markupEmpty = str "",+ markupString = str,+ markupAppend = (++),+ markupIdentifier = box (TagInline "a") . str . out dflags,+ markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,+ markupModule = box (TagInline "a") . str,+ markupWarning = box (TagInline "i"),+ markupEmphasis = box (TagInline "i"),+ markupBold = box (TagInline "b"),+ markupMonospaced = box (TagInline "tt"),+ markupPic = const $ str " ",+ markupUnorderedList = box (TagL 'u'),+ markupOrderedList = box (TagL 'o'),+ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),+ markupCodeBlock = box TagPre,+ markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),+ markupAName = const $ str "",+ markupProperty = box TagPre . str,+ markupExample = box TagPre . str . unlines . map exampleToString,+ markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h+ }+++showTags :: [Tag] -> [String]+showTags = intercalate [""] . map showBlock+++showBlock :: Tag -> [String]+showBlock (TagP xs) = showInline xs+showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"]+ where mid = concatMap (showInline . box (TagInline "li")) xs+showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"]+showBlock x = showInline [x]+++asInline :: Tag -> Tags+asInline (TagP xs) = xs+asInline (TagPre xs) = [TagInline "pre" xs]+asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs]+asInline x = [x]+++showInline :: [Tag] -> [String]+showInline = unwordsWrap 70 . words . concatMap f+ where+ fs = concatMap f+ f (Str x) = escape x+ f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">"+ f x = fs $ asInline x++ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse+++showPre :: [Tag] -> [String]+showPre = trimFront . trimLines . lines . concatMap f+ where+ trimLines = dropWhile null . reverse . dropWhile null . reverse+ trimFront xs = map (drop i) xs+ where+ ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""]+ i = if null ns then 0 else minimum ns++ fs = concatMap f+ f (Str x) = escape x+ f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">"+ f x = fs $ asInline x+++unwordsWrap :: Int -> [String] -> [String]+unwordsWrap n = f n []+ where+ f _ s [] = [g s | s /= []]+ f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs+ | otherwise = f (i - nx - 1) (x:s) xs+ where nx = length x++ g = unwords . reverse+++escape :: String -> String+escape = concatMap f+ where+ f '<' = "<"+ f '>' = ">"+ f '&' = "&"+ f x = [x]
+ src/Haddock/Backends/LaTeX.hs view
@@ -0,0 +1,1221 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.LaTeX+-- Copyright : (c) Simon Marlow 2010,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.LaTeX (+ ppLaTeX+) where+++import Haddock.Types+import Haddock.Utils+import Haddock.GhcUtils+import Pretty hiding (Doc, quote)+import qualified Pretty++import GHC+import OccName+import Name ( nameOccName )+import RdrName ( rdrNameOcc )+import FastString ( unpackFS, unpackLitString, zString )++import qualified Data.Map as Map+import System.Directory+import System.FilePath+import Data.Char+import Control.Monad+import Data.Maybe+import Data.List++import Haddock.Doc (combineDocumentation)++-- import Debug.Trace++{- SAMPLE OUTPUT++\haddockmoduleheading{\texttt{Data.List}}+\hrulefill+{\haddockverb\begin{verbatim}+module Data.List (+ (++), head, last, tail, init, null, length, map, reverse,+ ) where\end{verbatim}}+\hrulefill++\section{Basic functions}+\begin{haddockdesc}+\item[\begin{tabular}{@{}l}+head\ ::\ {\char 91}a{\char 93}\ ->\ a+\end{tabular}]\haddockbegindoc+Extract the first element of a list, which must be non-empty.+\par++\end{haddockdesc}+\begin{haddockdesc}+\item[\begin{tabular}{@{}l}+last\ ::\ {\char 91}a{\char 93}\ ->\ a+\end{tabular}]\haddockbegindoc+Extract the last element of a list, which must be finite and non-empty.+\par++\end{haddockdesc}+-}+++{- TODO+ * don't forget fixity!!+-}++ppLaTeX :: String -- Title+ -> Maybe String -- Package name+ -> [Interface]+ -> FilePath -- destination directory+ -> Maybe (Doc GHC.RdrName) -- prologue text, maybe+ -> Maybe String -- style file+ -> FilePath+ -> IO ()++ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir+ = do+ createDirectoryIfMissing True odir+ when (isNothing maybe_style) $+ copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)+ ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces+ mapM_ (ppLaTeXModule title odir) visible_ifaces+++haddockSty :: FilePath+haddockSty = "haddock.sty"+++type LaTeX = Pretty.Doc+++ppLaTeXTop+ :: String+ -> Maybe String+ -> FilePath+ -> Maybe (Doc GHC.RdrName)+ -> Maybe String+ -> [Interface]+ -> IO ()++ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do++ let tex = vcat [+ text "\\documentclass{book}",+ text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),+ text "\\begin{document}",+ text "\\begin{titlepage}",+ text "\\begin{haddocktitle}",+ text doctitle,+ text "\\end{haddocktitle}",+ case prologue of+ Nothing -> empty+ Just d -> vcat [text "\\begin{haddockprologue}",+ rdrDocToLaTeX d,+ text "\\end{haddockprologue}"],+ text "\\end{titlepage}",+ text "\\tableofcontents",+ vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],+ text "\\end{document}"+ ]++ mods = sort (map (moduleBasename.ifaceMod) ifaces)++ filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")++ writeFile filename (show tex)+++ppLaTeXModule :: String -> FilePath -> Interface -> IO ()+ppLaTeXModule _title odir iface = do+ createDirectoryIfMissing True odir+ let+ mdl = ifaceMod iface+ mdl_str = moduleString mdl++ exports = ifaceRnExportItems iface++ tex = vcat [+ text "\\haddockmoduleheading" <> braces (text mdl_str),+ text "\\label{module:" <> text mdl_str <> char '}',+ text "\\haddockbeginheader",+ verb $ vcat [+ text "module" <+> text mdl_str <+> lparen,+ text " " <> fsep (punctuate (text ", ") $+ map exportListItem $+ filter forSummary exports),+ text " ) where"+ ],+ text "\\haddockendheader" $$ text "",+ description,+ body+ ]++ description+ = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface++ body = processExports exports+ --+ writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex)+++string_txt :: TextDetails -> String -> String+string_txt (Chr c) s = c:s+string_txt (Str s1) s2 = s1 ++ s2+string_txt (PStr s1) s2 = unpackFS s1 ++ s2+string_txt (ZStr s1) s2 = zString s1 ++ s2+string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2+++exportListItem :: ExportItem DocName -> LaTeX+exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }+ = sep (punctuate comma . map ppDocBinder $ declNames decl) <>+ case subdocs of+ [] -> empty+ _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))+exportListItem (ExportNoDecl y [])+ = ppDocBinder y+exportListItem (ExportNoDecl y subs)+ = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))+exportListItem (ExportModule mdl)+ = text "module" <+> text (moduleString mdl)+exportListItem _+ = error "exportListItem"+++-- Deal with a group of undocumented exports together, to avoid lots+-- of blank vertical space between them.+processExports :: [ExportItem DocName] -> LaTeX+processExports [] = empty+processExports (decl : es)+ | Just sig <- isSimpleSig decl+ = multiDecl [ ppTypeSig (map getName names) typ False+ | (names,typ) <- sig:sigs ] $$+ processExports es'+ where (sigs, es') = spanWith isSimpleSig es+processExports (ExportModule mdl : es)+ = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$+ processExports es'+ where (mdls, es') = spanWith isExportModule es+processExports (e : es) =+ processExport e $$ processExports es+++isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t)))+ , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }+ | Map.null argDocs = Just (map unLoc lnames, t)+isSimpleSig _ = Nothing+++isExportModule :: ExportItem DocName -> Maybe Module+isExportModule (ExportModule m) = Just m+isExportModule _ = Nothing+++processExport :: ExportItem DocName -> LaTeX+processExport (ExportGroup lev _id0 doc)+ = ppDocGroup lev (docToLaTeX doc)+processExport (ExportDecl decl doc subdocs insts fixities _splice)+ = ppDecl decl doc insts subdocs fixities+processExport (ExportNoDecl y [])+ = ppDocName y+processExport (ExportNoDecl y subs)+ = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))+processExport (ExportModule mdl)+ = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing+processExport (ExportDoc doc)+ = docToLaTeX doc+++ppDocGroup :: Int -> LaTeX -> LaTeX+ppDocGroup lev doc = sec lev <> braces doc+ where sec 1 = text "\\section"+ sec 2 = text "\\subsection"+ sec 3 = text "\\subsubsection"+ sec _ = text "\\paragraph"+++declNames :: LHsDecl DocName -> [DocName]+declNames (L _ decl) = case decl of+ TyClD d -> [tcdName d]+ SigD (TypeSig lnames _) -> map unLoc lnames+ SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]+ ForD (ForeignImport (L _ n) _ _ _) -> [n]+ ForD (ForeignExport (L _ n) _ _ _) -> [n]+ _ -> error "declaration not supported by declNames"+++forSummary :: (ExportItem DocName) -> Bool+forSummary (ExportGroup _ _ _) = False+forSummary (ExportDoc _) = False+forSummary _ = True+++moduleLaTeXFile :: Module -> FilePath+moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"+++moduleBasename :: Module -> FilePath+moduleBasename mdl = map (\c -> if c == '.' then '-' else c)+ (moduleNameString (moduleName mdl))+++-------------------------------------------------------------------------------+-- * Decls+-------------------------------------------------------------------------------+++ppDecl :: LHsDecl DocName+ -> DocForDecl DocName+ -> [DocInstance DocName]+ -> [(DocName, DocForDecl DocName)]+ -> [(DocName, Fixity)]+ -> LaTeX++ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of+ TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode+ TyClD d@(DataDecl {})+ -> ppDataDecl instances subdocs loc (Just doc) d unicode+ TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode+-- Family instances happen via FamInst now+-- TyClD d@(TySynonym {})+-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode+-- Family instances happen via FamInst now+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode+ SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode+ SigD (PatSynSig lname args ty prov req) ->+ ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode+ ForD d -> ppFor loc (doc, fnArgsDoc) d unicode+ InstD _ -> empty+ _ -> error "declaration not supported by ppDecl"+ where+ unicode = False+++ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->+ TyClDecl DocName -> Bool -> LaTeX+ppTyFam _ _ _ _ _ =+ error "type family declarations are currently not supported by --latex"+++ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX+ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =+ ppFunSig loc doc [name] typ unicode+ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"+-- error "foreign declarations are currently not supported by --latex"+++-------------------------------------------------------------------------------+-- * Type Synonyms+-------------------------------------------------------------------------------+++-- we skip type patterns for now+ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX++ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars+ , tcdRhs = ltype }) unicode+ = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode+ where+ hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)+ full = hdr <+> char '=' <+> ppLType unicode ltype++ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"+++-------------------------------------------------------------------------------+-- * Function signatures+-------------------------------------------------------------------------------+++ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName+ -> Bool -> LaTeX+ppFunSig loc doc docnames typ unicode =+ ppTypeOrFunSig loc docnames typ doc+ ( ppTypeSig names typ False+ , hsep . punctuate comma $ map ppSymName names+ , dcolon unicode)+ unicode+ where+ names = map getName docnames++ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName+ -> HsPatSynDetails (LHsType DocName) -> LHsType DocName+ -> LHsContext DocName -> LHsContext DocName+ -> Bool -> LaTeX+ppLPatSig loc doc docname args typ prov req unicode =+ ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode++ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName+ -> HsPatSynDetails (HsType DocName) -> HsType DocName+ -> HsContext DocName -> HsContext DocName+ -> Bool -> LaTeX+ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)+ where+ pref1 = hsep [ keyword "pattern"+ , pp_ctx prov+ , pp_head+ , dcolon unicode+ , pp_ctx req+ , ppType unicode typ+ ]++ pp_head = case args of+ PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs+ InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]++ pp_type = ppParendType unicode+ pp_ctx ctx = ppContext ctx unicode++ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName+ -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)+ -> Bool -> LaTeX+ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)+ unicode+ | Map.null argDocs =+ declWithDoc pref1 (documentationToLaTeX doc)+ | otherwise =+ declWithDoc pref2 $ Just $+ text "\\haddockbeginargs" $$+ do_args 0 sep0 typ $$+ text "\\end{tabulary}\\par" $$+ fromMaybe empty (documentationToLaTeX doc)+ where+ do_largs n leader (L _ t) = do_args n leader t++ arg_doc n = rDoc (Map.lookup n argDocs)++ do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX+ do_args n leader (HsForAllTy Explicit tvs lctxt ltype)+ = decltt leader <->+ decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>+ ppLContextNoArrow lctxt unicode) <+> nl $$+ do_largs n (darrow unicode) ltype++ do_args n leader (HsForAllTy Implicit _ lctxt ltype)+ | not (null (unLoc lctxt))+ = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$+ do_largs n (darrow unicode) ltype+ -- if we're not showing any 'forall' or class constraints or+ -- anything, skip having an empty line for the context.+ | otherwise+ = do_largs n leader ltype+ do_args n leader (HsFunTy lt r)+ = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$+ do_largs (n+1) (arrow unicode) r+ do_args n leader t+ = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl+++ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX+ppTypeSig nms ty unicode =+ hsep (punctuate comma $ map ppSymName nms)+ <+> dcolon unicode+ <+> ppType unicode ty+++ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]+ppTyVars tvs = map ppSymName (tyvarNames tvs)+++tyvarNames :: LHsTyVarBndrs DocName -> [Name]+tyvarNames = map getName . hsLTyVarNames+++declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX+declWithDoc decl doc =+ text "\\begin{haddockdesc}" $$+ text "\\item[\\begin{tabular}{@{}l}" $$+ text (latexMonoFilter (show decl)) $$+ text "\\end{tabular}]" <>+ (if isNothing doc then empty else text "\\haddockbegindoc") $$+ maybe empty id doc $$+ text "\\end{haddockdesc}"+++-- in a group of decls, we don't put them all in the same tabular,+-- because that would prevent the group being broken over a page+-- boundary (breaks Foreign.C.Error for example).+multiDecl :: [LaTeX] -> LaTeX+multiDecl decls =+ text "\\begin{haddockdesc}" $$+ vcat [+ text "\\item[" $$+ text (latexMonoFilter (show decl)) $$+ text "]"+ | decl <- decls ] $$+ text "\\end{haddockdesc}"+++-------------------------------------------------------------------------------+-- * Rendering Doc+-------------------------------------------------------------------------------+++maybeDoc :: Maybe (Doc DocName) -> LaTeX+maybeDoc = maybe empty docToLaTeX+++-- for table cells, we strip paragraphs out to avoid extra vertical space+-- and don't add a quote environment.+rDoc :: Maybe (Doc DocName) -> LaTeX+rDoc = maybeDoc . fmap latexStripTrailingWhitespace+++-------------------------------------------------------------------------------+-- * Class declarations+-------------------------------------------------------------------------------+++ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]+ -> Bool -> LaTeX+ppClassHdr summ lctxt n tvs fds unicode =+ keyword "class"+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)+ <+> ppAppDocNameNames summ n (tyvarNames $ tvs)+ <+> ppFds fds unicode+++ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX+ppFds fds unicode =+ if null fds then empty else+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))+ where+ fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>+ hsep (map ppDocName vars2)+++ppClassDecl :: [DocInstance DocName] -> SrcSpan+ -> Documentation DocName -> [(DocName, DocForDecl DocName)]+ -> TyClDecl DocName -> Bool -> LaTeX+ppClassDecl instances loc doc subdocs+ (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds+ , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode+ = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$+ instancesBit+ where+ classheader+ | null lsigs = hdr unicode+ | otherwise = hdr unicode <+> keyword "where"++ hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds++ body = catMaybes [documentationToLaTeX doc, body_]++ body_+ | null lsigs, null ats, null at_defs = Nothing+ | null ats, null at_defs = Just methodTable+--- | otherwise = atTable $$ methodTable+ | otherwise = error "LaTeX.ppClassDecl"++ methodTable =+ text "\\haddockpremethods{}\\textbf{Methods}" $$+ vcat [ ppFunSig loc doc names typ unicode+ | L _ (TypeSig lnames (L _ typ)) <- lsigs+ , let doc = lookupAnySubdoc (head names) subdocs+ names = map unLoc lnames ]+ -- FIXME: is taking just the first name ok? Is it possible that+ -- there are different subdocs for different names in a single+ -- type signature?++ instancesBit = ppDocInstances unicode instances++ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"++ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX+ppDocInstances _unicode [] = empty+ppDocInstances unicode (i : rest)+ | Just ihead <- isUndocdInstance i+ = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$+ ppDocInstances unicode rest'+ | otherwise+ = ppDocInstance unicode i $$ ppDocInstances unicode rest+ where+ (is, rest') = spanWith isUndocdInstance rest++isUndocdInstance :: DocInstance a -> Maybe (InstHead a)+isUndocdInstance (i,Nothing) = Just i+isUndocdInstance _ = Nothing++-- | Print a possibly commented instance. The instance header is printed inside+-- an 'argBox'. The comment is printed to the right of the box in normal comment+-- style.+ppDocInstance :: Bool -> DocInstance DocName -> LaTeX+ppDocInstance unicode (instHead, doc) =+ declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)+++ppInstDecl :: Bool -> InstHead DocName -> LaTeX+ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead+++ppInstHead :: Bool -> InstHead DocName -> LaTeX+ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode+ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"+ <+> ppAppNameTypes n ks ts unicode+ <+> maybe empty (\t -> equals <+> ppType unicode t) rhs+ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =+ error "data instances not supported by --latex yet"++lookupAnySubdoc :: (Eq name1) =>+ name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2+lookupAnySubdoc n subdocs = case lookup n subdocs of+ Nothing -> noDocForDecl+ Just docs -> docs+++-------------------------------------------------------------------------------+-- * Data & newtype declarations+-------------------------------------------------------------------------------+++ppDataDecl :: [DocInstance DocName] ->+ [(DocName, DocForDecl DocName)] -> SrcSpan ->+ Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->+ LaTeX+ppDataDecl instances subdocs _loc doc dataDecl unicode++ = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)+ (if null body then Nothing else Just (vcat body))+ $$ instancesBit++ where+ cons = dd_cons (tcdDataDefn dataDecl)+ resTy = (con_res . unLoc . head) cons++ body = catMaybes [constrBit, doc >>= documentationToLaTeX]++ (whereBit, leaders)+ | null cons = (empty,[])+ | otherwise = case resTy of+ ResTyGADT _ -> (decltt (keyword "where"), repeat empty)+ _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))++ constrBit+ | null cons = Nothing+ | otherwise = Just $+ text "\\haddockbeginconstrs" $$+ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$+ text "\\end{tabulary}\\par"++ instancesBit = ppDocInstances unicode instances+++-- ppConstrHdr is for (non-GADT) existentials constructors' syntax+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX+ppConstrHdr forall tvs ctxt unicode+ = (if null tvs then empty else ppForall)+ <+>+ (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")+ where+ ppForall = case forall of+ Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "+ Implicit -> empty+++ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX+ -> LConDecl DocName -> LaTeX+ppSideBySideConstr subdocs unicode leader (L _ con) =+ leader <->+ case con_res con of+ ResTyH98 -> case con_details con of++ PrefixCon args ->+ decltt (hsep ((header_ unicode <+> ppBinder occ) :+ map (ppLParendType unicode) args))+ <-> rDoc mbDoc <+> nl++ RecCon fields ->+ (decltt (header_ unicode <+> ppBinder occ)+ <-> rDoc mbDoc <+> nl)+ $$+ doRecordFields fields++ InfixCon arg1 arg2 ->+ decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,+ ppBinder occ,+ ppLParendType unicode arg2 ])+ <-> rDoc mbDoc <+> nl++ ResTyGADT resTy -> case con_details con of+ -- prefix & infix could also use hsConDeclArgTys if it seemed to+ -- simplify the code.+ PrefixCon args -> doGADTCon args resTy+ cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$+ doRecordFields fields+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy++ where+ doRecordFields fields =+ vcat (map (ppSideBySideField subdocs unicode) fields)++ doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [+ ppForAll forall ltvs (con_cxt con) unicode,+ ppLType unicode (foldr mkFunTy resTy args) ]+ ) <-> rDoc mbDoc+++ header_ = ppConstrHdr forall tyVars context+ occ = nameOccName . getName . unLoc . con_name $ con+ ltvs = con_qvars con+ tyVars = tyvarNames (con_qvars con)+ context = unLoc (con_cxt con)+ forall = con_explicit con+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,+ -- or also because we want Haddock to do the doc-parsing, not GHC.+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst+ mkFunTy a b = noLoc (HsFunTy a b)+++ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =+ decltt (ppBinder (nameOccName . getName $ name)+ <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc+ where+ -- don't use cd_fld_doc for same reason we don't use con_doc above+ mbDoc = lookup name subdocs >>= combineDocumentation . fst++-- {-+-- ppHsFullConstr :: HsConDecl -> LaTeX+-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =+-- declWithDoc False doc (+-- hsep ((ppHsConstrHdr tvs ctxt ++++-- ppHsBinder False nm) : map ppHsBangType typeList)+-- )+-- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =+-- td << vanillaTable << (+-- case doc of+-- Nothing -> aboves [hdr, fields_html]+-- Just _ -> aboves [hdr, constr_doc, fields_html]+-- )+--+-- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)+--+-- constr_doc+-- | isJust doc = docBox (docToLaTeX (fromJust doc))+-- | otherwise = LaTeX.emptyTable+--+-- fields_html =+-- td <<+-- table ! [width "100%", cellpadding 0, cellspacing 8] << (+-- aboves (map ppFullField (concat (map expandField fields)))+-- )+-- -}+--+-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX+-- ppShortField summary unicode (ConDeclField (L _ name) ltype _)+-- = tda [theclass "recfield"] << (+-- ppBinder summary (docNameOcc name)+-- <+> dcolon unicode <+> ppLType unicode ltype+-- )+--+-- {-+-- ppFullField :: HsFieldDecl -> LaTeX+-- ppFullField (HsFieldDecl [n] ty doc)+-- = declWithDoc False doc (+-- ppHsBinder False n <+> dcolon <+> ppHsBangType ty+-- )+-- ppFullField _ = error "ppFullField"+--+-- expandField :: HsFieldDecl -> [HsFieldDecl]+-- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]+-- -}+++-- | Print the LHS of a data\/newtype declaration.+-- Currently doesn't handle 'data instance' decls or kind signatures+ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX+ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars+ , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode+ = -- newtype or data+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>+ -- context+ ppLContext ctxt unicode <+>+ -- T a b c ..., or a :+: b+ ppAppDocNameNames False name (tyvarNames tyvars)+ppDataHeader _ _ = error "ppDataHeader: illegal argument"++--------------------------------------------------------------------------------+-- * Type applications+--------------------------------------------------------------------------------+++-- | Print an application of a DocName and two lists of HsTypes (kinds, types)+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX+ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)+++-- | Print an application of a DocName and a list of Names+ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX+ppAppDocNameNames _summ n ns =+ ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName+++-- | General printing of type applications+ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX+ppTypeApp n [] (t1:t2:rest) ppDN ppT+ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)+ | operator = opApp+ where+ operator = isNameSym . getName $ n+ opApp = ppT t1 <+> ppDN n <+> ppT t2++ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)+++-------------------------------------------------------------------------------+-- * Contexts+-------------------------------------------------------------------------------+++ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX+ppLContext = ppContext . unLoc+ppLContextNoArrow = ppContextNoArrow . unLoc+++ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX+ppContextNoArrow [] _ = empty+ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode+++ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX+ppContextNoLocs [] _ = empty+ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode+++ppContext :: HsContext DocName -> Bool -> LaTeX+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode+++pp_hs_context :: [HsType DocName] -> Bool -> LaTeX+pp_hs_context [] _ = empty+pp_hs_context [p] unicode = ppType unicode p+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)+++-------------------------------------------------------------------------------+-- * Types and contexts+-------------------------------------------------------------------------------+++ppBang :: HsBang -> LaTeX+ppBang HsNoBang = empty+ppBang _ = char '!' -- Unpacked args is an implementation detail,+++tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX+tupleParens HsUnboxedTuple = ubxParenList+tupleParens _ = parenList+++-------------------------------------------------------------------------------+-- * Rendering of HsType+--+-- Stolen from Html and tweaked for LaTeX generation+-------------------------------------------------------------------------------+++pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int++pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC+pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC+ -- Used for LH arg of (->)+pREC_OP = (2 :: Int) -- Used for arg of any infix operator+ -- (we don't keep their fixities around)+pREC_CON = (3 :: Int) -- Used for arg of type applicn:+ -- always parenthesise unless atomic++maybeParen :: Int -- Precedence of context+ -> Int -- Precedence of top-level operator+ -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op)+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p+ | otherwise = p+++ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX+ppLType unicode y = ppType unicode (unLoc y)+ppLParendType unicode y = ppParendType unicode (unLoc y)+ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)+++ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX+ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode+ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode+ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode++ppLKind :: Bool -> LHsKind DocName -> LaTeX+ppLKind unicode y = ppKind unicode (unLoc y)++ppKind :: Bool -> HsKind DocName -> LaTeX+ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode+++-- Drop top-level for-all type variables in user style+-- since they are implicit in Haskell++ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName+ -> Located (HsContext DocName) -> Bool -> LaTeX+ppForAll expl tvs cxt unicode+ | show_forall = forall_part <+> ppLContext cxt unicode+ | otherwise = ppLContext cxt unicode+ where+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit+ is_explicit = case expl of {Explicit -> True; Implicit -> False}+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot+++ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode+++ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode+ = maybeParen ctxt_prec pREC_FUN $+ hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]++ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty+ppr_mono_ty _ (HsTyVar name) _ = ppDocName name+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u+ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)+ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)+ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)+ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)+ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"+ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"+ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys+ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy"++ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode+ = maybeParen ctxt_prec pREC_OP $+ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode++ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode+ = maybeParen ctxt_prec pREC_CON $+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]++ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode+ = maybeParen ctxt_prec pREC_FUN $+ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode+ where+ ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op+ occName = nameOccName . getName . unLoc $ op++ppr_mono_ty ctxt_prec (HsParTy ty) unicode+-- = parens (ppr_mono_lty pREC_TOP ty)+ = ppr_mono_lty ctxt_prec ty unicode++ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode+ = ppr_mono_lty ctxt_prec ty unicode++ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u+++ppr_tylit :: HsTyLit -> Bool -> LaTeX+ppr_tylit (HsNumTy n) _ = integer n+ppr_tylit (HsStrTy s) _ = text (show s)+ -- XXX: Ok in verbatim, but not otherwise+ -- XXX: Do something with Unicode parameter?+++ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX+ppr_fun_ty ctxt_prec ty1 ty2 unicode+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode+ p2 = ppr_mono_lty pREC_TOP ty2 unicode+ in+ maybeParen ctxt_prec pREC_FUN $+ sep [p1, arrow unicode <+> p2]+++-------------------------------------------------------------------------------+-- * Names+-------------------------------------------------------------------------------+++ppBinder :: OccName -> LaTeX+ppBinder n+ | isInfixName n = parens $ ppOccName n+ | otherwise = ppOccName n++ppBinderInfix :: OccName -> LaTeX+ppBinderInfix n+ | isInfixName n = ppOccName n+ | otherwise = quotes $ ppOccName n++isInfixName :: OccName -> Bool+isInfixName n = isVarSym n || isConSym n++ppSymName :: Name -> LaTeX+ppSymName name+ | isNameSym name = parens $ ppName name+ | otherwise = ppName name+++ppVerbOccName :: OccName -> LaTeX+ppVerbOccName = text . latexFilter . occNameString++ppIPName :: HsIPName -> LaTeX+ppIPName ip = text $ unpackFS $ hsIPNameFS ip++ppOccName :: OccName -> LaTeX+ppOccName = text . occNameString+++ppVerbDocName :: DocName -> LaTeX+ppVerbDocName = ppVerbOccName . nameOccName . getName+++ppVerbRdrName :: RdrName -> LaTeX+ppVerbRdrName = ppVerbOccName . rdrNameOcc+++ppDocName :: DocName -> LaTeX+ppDocName = ppOccName . nameOccName . getName+++ppLDocName :: Located DocName -> LaTeX+ppLDocName (L _ d) = ppDocName d+++ppDocBinder :: DocName -> LaTeX+ppDocBinder = ppBinder . nameOccName . getName++ppDocBinderInfix :: DocName -> LaTeX+ppDocBinderInfix = ppBinderInfix . nameOccName . getName+++ppName :: Name -> LaTeX+ppName = ppOccName . nameOccName+++latexFilter :: String -> String+latexFilter = foldr latexMunge ""+++latexMonoFilter :: String -> String+latexMonoFilter = foldr latexMonoMunge ""+++latexMunge :: Char -> String -> String+latexMunge '#' s = "{\\char '43}" ++ s+latexMunge '$' s = "{\\char '44}" ++ s+latexMunge '%' s = "{\\char '45}" ++ s+latexMunge '&' s = "{\\char '46}" ++ s+latexMunge '~' s = "{\\char '176}" ++ s+latexMunge '_' s = "{\\char '137}" ++ s+latexMunge '^' s = "{\\char '136}" ++ s+latexMunge '\\' s = "{\\char '134}" ++ s+latexMunge '{' s = "{\\char '173}" ++ s+latexMunge '}' s = "{\\char '175}" ++ s+latexMunge '[' s = "{\\char 91}" ++ s+latexMunge ']' s = "{\\char 93}" ++ s+latexMunge c s = c : s+++latexMonoMunge :: Char -> String -> String+latexMonoMunge ' ' s = '\\' : ' ' : s+latexMonoMunge '\n' s = '\\' : '\\' : s+latexMonoMunge c s = latexMunge c s+++-------------------------------------------------------------------------------+-- * Doc Markup+-------------------------------------------------------------------------------+++parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)+parLatexMarkup ppId = Markup {+ markupParagraph = \p v -> p v <> text "\\par" $$ text "",+ markupEmpty = \_ -> empty,+ markupString = \s v -> text (fixString v s),+ markupAppend = \l r v -> l v <> r v,+ markupIdentifier = markupId ppId,+ markupIdentifierUnchecked = markupId (ppVerbOccName . snd),+ markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),+ markupWarning = \p v -> emph (p v),+ markupEmphasis = \p v -> emph (p v),+ markupBold = \p v -> bold (p v),+ markupMonospaced = \p _ -> tt (p Mono),+ markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",+ markupPic = \p _ -> markupPic p,+ markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",+ markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),+ markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",+ markupHyperlink = \l _ -> markupLink l,+ markupAName = \_ _ -> empty,+ markupProperty = \p _ -> quote $ verb $ text p,+ markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,+ markupHeader = \(Header l h) p -> header l (h p)+ }+ where+ header 1 d = text "\\section*" <> braces d+ header 2 d = text "\\subsection*" <> braces d+ header l d+ | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d+ header l _ = error $ "impossible header level in LaTeX generation: " ++ show l++ fixString Plain s = latexFilter s+ fixString Verb s = s+ fixString Mono s = latexMonoFilter s++ markupLink (Hyperlink url mLabel) = case mLabel of+ Just label -> text "\\href" <> braces (text url) <> braces (text label)+ Nothing -> text "\\url" <> braces (text url)++ -- Is there a better way of doing this? Just a space is an aribtrary choice.+ markupPic (Picture uri title) = parens (imageText title)+ where+ imageText Nothing = beg+ imageText (Just t) = beg <> text " " <> text t++ beg = text "image: " <> text uri++ markupId ppId_ id v =+ case v of+ Verb -> theid+ Mono -> theid+ Plain -> text "\\haddockid" <> braces theid+ where theid = ppId_ id+++latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)+latexMarkup = parLatexMarkup ppVerbDocName+++rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)+rdrLatexMarkup = parLatexMarkup ppVerbRdrName+++docToLaTeX :: Doc DocName -> LaTeX+docToLaTeX doc = markup latexMarkup doc Plain+++documentationToLaTeX :: Documentation DocName -> Maybe LaTeX+documentationToLaTeX = fmap docToLaTeX . combineDocumentation+++rdrDocToLaTeX :: Doc RdrName -> LaTeX+rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain+++data StringContext = Plain | Verb | Mono+++latexStripTrailingWhitespace :: Doc a -> Doc a+latexStripTrailingWhitespace (DocString s)+ | null s' = DocEmpty+ | otherwise = DocString s+ where s' = reverse (dropWhile isSpace (reverse s))+latexStripTrailingWhitespace (DocAppend l r)+ | DocEmpty <- r' = latexStripTrailingWhitespace l+ | otherwise = DocAppend l r'+ where+ r' = latexStripTrailingWhitespace r+latexStripTrailingWhitespace (DocParagraph p) =+ latexStripTrailingWhitespace p+latexStripTrailingWhitespace other = other+++-------------------------------------------------------------------------------+-- * LaTeX utils+-------------------------------------------------------------------------------+++itemizedList :: [LaTeX] -> LaTeX+itemizedList items =+ text "\\begin{itemize}" $$+ vcat (map (text "\\item" $$) items) $$+ text "\\end{itemize}"+++enumeratedList :: [LaTeX] -> LaTeX+enumeratedList items =+ text "\\begin{enumerate}" $$+ vcat (map (text "\\item " $$) items) $$+ text "\\end{enumerate}"+++descriptionList :: [(LaTeX,LaTeX)] -> LaTeX+descriptionList items =+ text "\\begin{description}" $$+ vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$+ text "\\end{description}"+++tt :: LaTeX -> LaTeX+tt ltx = text "\\haddocktt" <> braces ltx+++decltt :: LaTeX -> LaTeX+decltt ltx = text "\\haddockdecltt" <> braces ltx+++emph :: LaTeX -> LaTeX+emph ltx = text "\\emph" <> braces ltx++bold :: LaTeX -> LaTeX+bold ltx = text "\\textbf" <> braces ltx++verb :: LaTeX -> LaTeX+verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"+ -- NB. swallow a trailing \n in the verbatim text by appending the+ -- \end{verbatim} directly, otherwise we get spurious blank lines at the+ -- end of code blocks.+++quote :: LaTeX -> LaTeX+quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"+++dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX+dcolon unicode = text (if unicode then "∷" else "::")+arrow unicode = text (if unicode then "→" else "->")+darrow unicode = text (if unicode then "⇒" else "=>")+forallSymbol unicode = text (if unicode then "∀" else "forall")+++dot :: LaTeX+dot = char '.'+++parenList :: [LaTeX] -> LaTeX+parenList = parens . hsep . punctuate comma+++ubxParenList :: [LaTeX] -> LaTeX+ubxParenList = ubxparens . hsep . punctuate comma+++ubxparens :: LaTeX -> LaTeX+ubxparens h = text "(#" <> h <> text "#)"+++pabrackets :: LaTeX -> LaTeX+pabrackets h = text "[:" <> h <> text ":]"+++nl :: LaTeX+nl = text "\\\\"+++keyword :: String -> LaTeX+keyword = text+++infixr 4 <-> -- combining table cells+(<->) :: LaTeX -> LaTeX -> LaTeX+a <-> b = a <+> char '&' <+> b
+ src/Haddock/Backends/Xhtml.hs view
@@ -0,0 +1,690 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+module Haddock.Backends.Xhtml (+ ppHtml, copyHtmlBits,+ ppHtmlIndex, ppHtmlContents,+) where+++import Prelude hiding (div)++import Haddock.Backends.Xhtml.Decl+import Haddock.Backends.Xhtml.DocMarkup+import Haddock.Backends.Xhtml.Layout+import Haddock.Backends.Xhtml.Names+import Haddock.Backends.Xhtml.Themes+import Haddock.Backends.Xhtml.Types+import Haddock.Backends.Xhtml.Utils+import Haddock.ModuleTree+import Haddock.Types+import Haddock.Version+import Haddock.Utils+import Text.XHtml hiding ( name, title, p, quote )+import Haddock.GhcUtils++import Control.Monad ( when, unless )+#if !MIN_VERSION_base(4,7,0)+import Control.Monad.Instances ( ) -- for Functor Either a+#endif+import Data.Char ( toUpper )+import Data.Functor ( (<$>) )+import Data.List ( sortBy, groupBy, intercalate, isPrefixOf )+import Data.Maybe+import System.FilePath hiding ( (</>) )+import System.Directory+import Data.Map ( Map )+import qualified Data.Map as Map hiding ( Map )+import qualified Data.Set as Set hiding ( Set )+import Data.Function+import Data.Ord ( comparing )++import DynFlags (Language(..))+import GHC hiding ( NoLink, moduleInfo )+import Name+import Module++--------------------------------------------------------------------------------+-- * Generating HTML documentation+--------------------------------------------------------------------------------+++ppHtml :: String+ -> Maybe String -- ^ Package+ -> [Interface]+ -> FilePath -- ^ Destination directory+ -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe+ -> Themes -- ^ Themes+ -> SourceURLs -- ^ The source URL (--source)+ -> WikiURLs -- ^ The wiki URL (--wiki)+ -> Maybe String -- ^ The contents URL (--use-contents)+ -> Maybe String -- ^ The index URL (--use-index)+ -> Bool -- ^ Whether to use unicode in output (--use-unicode)+ -> QualOption -- ^ How to qualify names+ -> Bool -- ^ Output pretty html (newlines and indenting)+ -> IO ()++ppHtml doctitle maybe_package ifaces odir prologue+ themes maybe_source_url maybe_wiki_url+ maybe_contents_url maybe_index_url unicode+ qual debug = do+ let+ visible_ifaces = filter visible ifaces+ visible i = OptHide `notElem` ifaceOptions i++ when (isNothing maybe_contents_url) $+ ppHtmlContents odir doctitle maybe_package+ themes maybe_index_url maybe_source_url maybe_wiki_url+ (map toInstalledIface visible_ifaces)+ False -- we don't want to display the packages in a single-package contents+ prologue debug (makeContentsQual qual)++ when (isNothing maybe_index_url) $+ ppHtmlIndex odir doctitle maybe_package+ themes maybe_contents_url maybe_source_url maybe_wiki_url+ (map toInstalledIface visible_ifaces) debug++ mapM_ (ppHtmlModule odir doctitle themes+ maybe_source_url maybe_wiki_url+ maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces+++copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()+copyHtmlBits odir libdir themes = do+ let+ libhtmldir = joinPath [libdir, "html"]+ copyCssFile f = copyFile f (combine odir (takeFileName f))+ copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])+ mapM_ copyCssFile (cssFiles themes)+ mapM_ copyLibFile [ jsFile, framesFile ]+++headHtml :: String -> Maybe String -> Themes -> Html+headHtml docTitle miniPage themes =+ header << [+ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],+ thetitle << docTitle,+ styleSheet themes,+ script ! [src jsFile, thetype "text/javascript"] << noHtml,+ script ! [thetype "text/javascript"]+ -- NB: Within XHTML, the content of script tags needs to be+ -- a <![CDATA[ section. Will break if the miniPage name could+ -- have "]]>" in it!+ << primHtml (+ "//<![CDATA[\nwindow.onload = function () {pageLoad();"+ ++ setSynopsis ++ "};\n//]]>\n")+ ]+ where+ setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage+++srcButton :: SourceURLs -> Maybe Interface -> Maybe Html+srcButton (Just src_base_url, _, _, _) Nothing =+ Just (anchor ! [href src_base_url] << "Source")+srcButton (_, Just src_module_url, _, _) (Just iface) =+ let url = spliceURL (Just $ ifaceOrigFilename iface)+ (Just $ ifaceMod iface) Nothing Nothing src_module_url+ in Just (anchor ! [href url] << "Source")+srcButton _ _ =+ Nothing+++wikiButton :: WikiURLs -> Maybe Module -> Maybe Html+wikiButton (Just wiki_base_url, _, _) Nothing =+ Just (anchor ! [href wiki_base_url] << "User Comments")++wikiButton (_, Just wiki_module_url, _) (Just mdl) =+ let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url+ in Just (anchor ! [href url] << "User Comments")++wikiButton _ _ =+ Nothing+++contentsButton :: Maybe String -> Maybe Html+contentsButton maybe_contents_url+ = Just (anchor ! [href url] << "Contents")+ where url = fromMaybe contentsHtmlFile maybe_contents_url+++indexButton :: Maybe String -> Maybe Html+indexButton maybe_index_url+ = Just (anchor ! [href url] << "Index")+ where url = fromMaybe indexHtmlFile maybe_index_url+++bodyHtml :: String -> Maybe Interface+ -> SourceURLs -> WikiURLs+ -> Maybe String -> Maybe String+ -> Html -> Html+bodyHtml doctitle iface+ maybe_source_url maybe_wiki_url+ maybe_contents_url maybe_index_url+ pageContent =+ body << [+ divPackageHeader << [+ unordList (catMaybes [+ srcButton maybe_source_url iface,+ wikiButton maybe_wiki_url (ifaceMod <$> iface),+ contentsButton maybe_contents_url,+ indexButton maybe_index_url])+ ! [theclass "links", identifier "page-menu"],+ nonEmptySectionName << doctitle+ ],+ divContent << pageContent,+ divFooter << paragraph << (+ "Produced by " ++++ (anchor ! [href projectUrl] << toHtml projectName) ++++ (" version " ++ projectVersion)+ )+ ]+++moduleInfo :: Interface -> Html+moduleInfo iface =+ let+ info = ifaceInfo iface++ doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable+ doOneEntry (fieldName, field) =+ field info >>= \a -> return (th << fieldName <-> td << a)++ entries :: [HtmlTable]+ entries = mapMaybe doOneEntry [+ ("Copyright",hmi_copyright),+ ("License",hmi_license),+ ("Maintainer",hmi_maintainer),+ ("Stability",hmi_stability),+ ("Portability",hmi_portability),+ ("Safe Haskell",hmi_safety),+ ("Language", lg)+ ] ++ extsForm+ where+ lg inf = case hmi_language inf of+ Nothing -> Nothing+ Just Haskell98 -> Just "Haskell98"+ Just Haskell2010 -> Just "Haskell2010"++ extsForm+ | OptShowExtensions `elem` ifaceOptions iface =+ let fs = map (dropOpt . show) (hmi_extensions info)+ in case map stringToHtml fs of+ [] -> []+ [x] -> extField x -- don't use a list for a single extension+ xs -> extField $ unordList xs ! [theclass "extension-list"]+ | otherwise = []+ where+ extField x = return $ th << "Extensions" <-> td << x+ dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x+ in+ case entries of+ [] -> noHtml+ _ -> table ! [theclass "info"] << aboves entries+++--------------------------------------------------------------------------------+-- * Generate the module contents+--------------------------------------------------------------------------------+++ppHtmlContents+ :: FilePath+ -> String+ -> Maybe String+ -> Themes+ -> Maybe String+ -> SourceURLs+ -> WikiURLs+ -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)+ -> Bool+ -> Qualification -- ^ How to qualify names+ -> IO ()+ppHtmlContents odir doctitle _maybe_package+ themes maybe_index_url+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do+ let tree = mkModuleTree showPkgs+ [(instMod iface, toInstalledDescription iface) | iface <- ifaces]+ html =+ headHtml doctitle Nothing themes ++++ bodyHtml doctitle Nothing+ maybe_source_url maybe_wiki_url+ Nothing maybe_index_url << [+ ppPrologue qual doctitle prologue,+ ppModuleTree qual tree+ ]+ createDirectoryIfMissing True odir+ writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)++ -- XXX: think of a better place for this?+ ppHtmlContentsFrame odir doctitle themes ifaces debug+++ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html+ppPrologue _ _ Nothing = noHtml+ppPrologue qual title (Just doc) =+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))+++ppModuleTree :: Qualification -> [ModuleTree] -> Html+ppModuleTree qual ts =+ divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)+++mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html+mkNodeList qual ss p ts = case ts of+ [] -> noHtml+ _ -> unordList (zipWith (mkNode qual ss) ps ts)+ where+ ps = [ p ++ '.' : show i | i <- [(1::Int)..]]+++mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html+mkNode qual ss p (Node s leaf pkg short ts) =+ htmlModule <+> shortDescr +++ htmlPkg +++ subtree+ where+ modAttrs = case (ts, leaf) of+ (_:_, False) -> collapseControl p True "module"+ (_, _ ) -> [theclass "module"]++ cBtn = case (ts, leaf) of+ (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml+ (_, _ ) -> noHtml+ -- We only need an explicit collapser button when the module name+ -- is also a leaf, and so is a link to a module page. Indeed, the+ -- spaceHtml is a minor hack and does upset the layout a fraction.++ htmlModule = thespan ! modAttrs << (cBtn ++++ if leaf+ then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))+ (mkModuleName mdl))+ else toHtml s+ )++ mdl = intercalate "." (reverse (s:ss))++ shortDescr = maybe noHtml (origDocToHtml qual) short+ htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg++ subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""+++-- | Turn a module tree into a flat list of full module names. E.g.,+-- @+-- A+-- +-B+-- +-C+-- @+-- becomes+-- @["A", "A.B", "A.B.C"]@+flatModuleTree :: [InstalledInterface] -> [Html]+flatModuleTree ifaces =+ map (uncurry ppModule' . head)+ . groupBy ((==) `on` fst)+ . sortBy (comparing fst)+ $ mods+ where+ mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]+ ppModule' txt mdl =+ anchor ! [href (moduleHtmlFile mdl), target mainFrameName]+ << toHtml txt+++ppHtmlContentsFrame :: FilePath -> String -> Themes+ -> [InstalledInterface] -> Bool -> IO ()+ppHtmlContentsFrame odir doctitle themes ifaces debug = do+ let mods = flatModuleTree ifaces+ html =+ headHtml doctitle Nothing themes ++++ miniBody << divModuleList <<+ (sectionName << "Modules" ++++ ulist << [ li ! [theclass "module"] << m | m <- mods ])+ createDirectoryIfMissing True odir+ writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)+++--------------------------------------------------------------------------------+-- * Generate the index+--------------------------------------------------------------------------------+++ppHtmlIndex :: FilePath+ -> String+ -> Maybe String+ -> Themes+ -> Maybe String+ -> SourceURLs+ -> WikiURLs+ -> [InstalledInterface]+ -> Bool+ -> IO ()+ppHtmlIndex odir doctitle _maybe_package themes+ maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do+ let html = indexPage split_indices Nothing+ (if split_indices then [] else index)++ createDirectoryIfMissing True odir++ when split_indices $ do+ mapM_ (do_sub_index index) initialChars+ -- Let's add a single large index as well for those who don't know exactly what they're looking for:+ let mergedhtml = indexPage False Nothing index+ writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)++ writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)++ where+ indexPage showLetters ch items =+ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes ++++ bodyHtml doctitle Nothing+ maybe_source_url maybe_wiki_url+ maybe_contents_url Nothing << [+ if showLetters then indexInitialLetterLinks else noHtml,+ if null items then noHtml else+ divIndex << [sectionName << indexName ch, buildIndex items]+ ]++ indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch+ merged_name = "All"++ buildIndex items = table << aboves (map indexElt items)++ -- an arbitrary heuristic:+ -- too large, and a single-page will be slow to load+ -- too small, and we'll have lots of letter-indexes with only one+ -- or two members in them, which seems inefficient or+ -- unnecessarily hard to use.+ split_indices = length index > 150++ indexInitialLetterLinks =+ divAlphabet <<+ unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $+ [ [c] | c <- initialChars+ , any ((==c) . toUpper . head . fst) index ] +++ [merged_name])++ -- todo: what about names/operators that start with Unicode+ -- characters?+ -- Exports beginning with '_' can be listed near the end,+ -- presumably they're not as important... but would be listed+ -- with non-split index!+ initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"++ do_sub_index this_ix c+ = unless (null index_part) $+ writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)+ where+ html = indexPage True (Just c) index_part+ index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]+++ index :: [(String, Map GHC.Name [(Module,Bool)])]+ index = sortBy cmp (Map.toAscList full_index)+ where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2++ -- for each name (a plain string), we have a number of original HsNames that+ -- it can refer to, and for each of those we have a list of modules+ -- that export that entity. Each of the modules exports the entity+ -- in a visible or invisible way (hence the Bool).+ full_index :: Map String (Map GHC.Name [(Module,Bool)])+ full_index = Map.fromListWith (flip (Map.unionWith (++)))+ (concatMap getIfaceIndex ifaces)++ getIfaceIndex iface =+ [ (getOccString name+ , Map.fromList [(name, [(mdl, name `Set.member` visible)])])+ | name <- instExports iface ]+ where+ mdl = instMod iface+ visible = Set.fromList (instVisibleExports iface)++ indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable+ indexElt (str, entities) =+ case Map.toAscList entities of+ [(nm,entries)] ->+ td ! [ theclass "src" ] << toHtml str <->+ indexLinks nm entries+ many_entities ->+ td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>+ aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)++ doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable+ doAnnotatedEntity (j,(nm,entries))+ = td ! [ theclass "alt" ] <<+ toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->+ indexLinks nm entries++ ppAnnot n | not (isValOcc n) = toHtml "Type/Class"+ | isDataOcc n = toHtml "Data Constructor"+ | otherwise = toHtml "Function"++ indexLinks nm entries =+ td ! [ theclass "module" ] <<+ hsep (punctuate comma+ [ if visible then+ linkId mdl (Just nm) << toHtml (moduleString mdl)+ else+ toHtml (moduleString mdl)+ | (mdl, visible) <- entries ])+++--------------------------------------------------------------------------------+-- * Generate the HTML page for a module+--------------------------------------------------------------------------------+++ppHtmlModule+ :: FilePath -> String -> Themes+ -> SourceURLs -> WikiURLs+ -> Maybe String -> Maybe String -> Bool -> QualOption+ -> Bool -> Interface -> IO ()+ppHtmlModule odir doctitle themes+ maybe_source_url maybe_wiki_url+ maybe_contents_url maybe_index_url unicode qual debug iface = do+ let+ mdl = ifaceMod iface+ aliases = ifaceModuleAliases iface+ mdl_str = moduleString mdl+ real_qual = makeModuleQual qual aliases mdl+ html =+ headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes ++++ bodyHtml doctitle (Just iface)+ maybe_source_url maybe_wiki_url+ maybe_contents_url maybe_index_url << [+ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual+ ]++ createDirectoryIfMissing True odir+ writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug++ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes+ -> Interface -> Bool -> Qualification -> Bool -> IO ()+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do+ let mdl = ifaceMod iface+ html =+ headHtml (moduleString mdl) Nothing themes ++++ miniBody <<+ (divModuleHeader << sectionName << moduleString mdl ++++ miniSynopsis mdl iface unicode qual)+ createDirectoryIfMissing True odir+ writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)+++ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual+ = ppModuleContents qual exports ++++ description ++++ synopsis ++++ divInterface (maybe_doc_hdr +++ bdy)+ where+ exports = numberSectionHeadings (ifaceRnExportItems iface)++ -- todo: if something has only sub-docs, or fn-args-docs, should+ -- it be measured here and thus prevent omitting the synopsis?+ has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning+ has_doc (ExportNoDecl _ _) = False+ has_doc (ExportModule _) = False+ has_doc _ = True++ no_doc_at_all = not (any has_doc exports)++ description | isNoHtml doc = doc+ | otherwise = divDescription $ sectionName << "Description" +++ doc+ where doc = docSection qual (ifaceRnDoc iface)++ -- omit the synopsis if there are no documentation annotations at all+ synopsis+ | no_doc_at_all = noHtml+ | otherwise+ = divSynposis $+ paragraph ! collapseControl "syn" False "caption" << "Synopsis" ++++ shortDeclList (+ mapMaybe (processExport True linksInfo unicode qual) exports+ ) ! (collapseSection "syn" False "" ++ collapseToggle "syn")++ -- if the documentation doesn't begin with a section header, then+ -- add one ("Documentation").+ maybe_doc_hdr+ = case exports of+ [] -> noHtml+ ExportGroup {} : _ -> noHtml+ _ -> h1 << "Documentation"++ bdy =+ foldr (+++) noHtml $+ mapMaybe (processExport False linksInfo unicode qual) exports++ linksInfo = (maybe_source_url, maybe_wiki_url)+++miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html+miniSynopsis mdl iface unicode qual =+ divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports+ where+ exports = numberSectionHeadings (ifaceRnExportItems iface)+++processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName+ -> [Html]+processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =+ ((divTopDecl <<).(declElem <<)) <$> case decl0 of+ TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of+ (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]+ (DataDecl{}) -> [keyword "data" <+> b]+ (SynDecl{}) -> [keyword "type" <+> b]+ (ClassDecl {}) -> [keyword "class" <+> b]+ _ -> []+ SigD (TypeSig lnames (L _ _)) ->+ map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames+ _ -> []+processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =+ [groupTag lvl << docToHtml qual txt]+processForMiniSynopsis _ _ _ _ = []+++ppNameMini :: Notation -> Module -> OccName -> Html+ppNameMini notation mdl nm =+ anchor ! [ href (moduleNameUrl mdl nm)+ , target mainFrameName ]+ << ppBinder' notation nm+++ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html+ppTyClBinderWithVarsMini mdl decl =+ let n = tcdName decl+ ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above+ in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName+++ppModuleContents :: Qualification -> [ExportItem DocName] -> Html+ppModuleContents qual exports+ | null sections = noHtml+ | otherwise = contentsDiv+ where+ contentsDiv = divTableOfContents << (+ sectionName << "Contents" ++++ unordList sections)++ (sections, _leftovers{-should be []-}) = process 0 exports++ process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])+ process _ [] = ([], [])+ process n items@(ExportGroup lev id0 doc : rest)+ | lev <= n = ( [], items )+ | otherwise = ( html:secs, rest2 )+ where+ html = linkedAnchor (groupId id0)+ << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs+ (ssecs, rest1) = process lev rest+ (secs, rest2) = process n rest1+ process n (_ : rest) = process n rest++ mk_subsections [] = noHtml+ mk_subsections ss = unordList ss++-- we need to assign a unique id to each section heading so we can hyperlink+-- them from the contents:+numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]+numberSectionHeadings = go 1+ where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]+ go _ [] = []+ go n (ExportGroup lev _ doc : es)+ = ExportGroup lev (show n) doc : go (n+1) es+ go n (other:es)+ = other : go n es+++processExport :: Bool -> LinksInfo -> Bool -> Qualification+ -> ExportItem DocName -> Maybe Html+processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances+processExport summary _ _ qual (ExportGroup lev id0 doc)+ = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc+processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)+ = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual+processExport summary _ _ qual (ExportNoDecl y [])+ = processDeclOneLiner summary $ ppDocName qual Prefix True y+processExport summary _ _ qual (ExportNoDecl y subs)+ = processDeclOneLiner summary $+ ppDocName qual Prefix True y+ +++ parenList (map (ppDocName qual Prefix True) subs)+processExport summary _ _ qual (ExportDoc doc)+ = nothingIf summary $ docSection_ qual doc+processExport summary _ _ _ (ExportModule mdl)+ = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl+++nothingIf :: Bool -> a -> Maybe a+nothingIf True _ = Nothing+nothingIf False a = Just a+++processDecl :: Bool -> Html -> Maybe Html+processDecl True = Just+processDecl False = Just . divTopDecl+++processDeclOneLiner :: Bool -> Html -> Maybe Html+processDeclOneLiner True = Just+processDeclOneLiner False = Just . divTopDecl . declElem++groupHeading :: Int -> String -> Html -> Html+groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]++groupTag :: Int -> Html -> Html+groupTag lev+ | lev == 1 = h1+ | lev == 2 = h2+ | lev == 3 = h3+ | otherwise = h4
+ src/Haddock/Backends/Xhtml/Decl.hs view
@@ -0,0 +1,884 @@+{-# LANGUAGE TransformListComp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.Decl+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Decl (+ ppDecl,++ ppTyName, ppTyFamHeader, ppTypeApp,+ tyvarNames+) where+++import Haddock.Backends.Xhtml.DocMarkup+import Haddock.Backends.Xhtml.Layout+import Haddock.Backends.Xhtml.Names+import Haddock.Backends.Xhtml.Types+import Haddock.Backends.Xhtml.Utils+import Haddock.GhcUtils+import Haddock.Types+import Haddock.Doc (combineDocumentation)++import Data.List ( intersperse, sort )+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid ( mempty )+import Text.XHtml hiding ( name, title, p, quote )++import GHC+import GHC.Exts+import Name+import BooleanFormula++ppDecl :: Bool -> LinksInfo -> LHsDecl DocName+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]+ -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual+ SigD (PatSynSig lname args ty prov req) ->+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual+ InstD _ -> noHtml+ _ -> error "declaration not supported by ppDecl"+++ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->+ [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->+ Splice -> Unicode -> Qualification -> Html+ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities+ splice unicode qual++ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->+ [DocName] -> HsType DocName -> [(DocName, Fixity)] ->+ Splice -> Unicode -> Qualification -> Html+ppFunSig summary links loc doc docnames typ fixities splice unicode qual =+ ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)+ splice unicode qual+ where+ pp_typ = ppType unicode qual typ++ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->+ Located DocName ->+ HsPatSynDetails (LHsType DocName) -> LHsType DocName ->+ LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->+ Splice -> Unicode -> Qualification -> Html+ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)+ (unLoc prov) (unLoc req) fixities splice unicode qual++ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->+ DocName ->+ HsPatSynDetails (HsType DocName) -> HsType DocName ->+ HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->+ Splice -> Unicode -> Qualification -> Html+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities+ splice unicode qual+ | summary = pref1+ | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)+ +++ docSection qual doc+ where+ pref1 = hsep [ toHtml "pattern"+ , pp_cxt prov+ , pp_head+ , dcolon unicode+ , pp_cxt req+ , ppType unicode qual typ+ ]+ pp_head = case args of+ PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs+ InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]++ pp_cxt cxt = ppContext cxt unicode qual+ pp_type = ppParendType unicode qual++ occname = nameOccName . getName $ docname++ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->+ [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->+ Splice -> Unicode -> Qualification -> Html+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)+ splice unicode qual =+ ppTypeOrFunSig summary links loc docnames typ doc+ ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode+ , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames+ , dcolon unicode+ )+ splice unicode qual+ where+ occnames = map (nameOccName . getName) docnames+ addFixities html+ | summary = html+ | otherwise = html <+> ppFixities fixities qual+++ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName+ -> DocForDecl DocName -> (Html, Html, Html)+ -> Splice -> Unicode -> Qualification -> Html+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual+ | summary = pref1+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc+ | otherwise = topDeclElem links loc splice docnames pref2 ++++ subArguments qual (do_args 0 sep typ) +++ docSection qual doc+ where+ argDoc n = Map.lookup n argDocs++ do_largs n leader (L _ t) = do_args n leader t+ do_args :: Int -> Html -> HsType DocName -> [SubDecl]+ do_args n leader (HsForAllTy _ tvs lctxt ltype)+ = case unLoc lctxt of+ [] -> do_largs n leader' ltype+ _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])+ : do_largs n (darrow unicode) ltype+ where leader' = leader <+> ppForAll tvs unicode qual+ do_args n leader (HsFunTy lt r)+ = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])+ : do_largs (n+1) (arrow unicode) r+ do_args n leader t+ = [(leader <+> ppType unicode qual t, argDoc n, [])]++ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html+ppForAll tvs unicode qual =+ case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of+ [] -> noHtml+ ts -> forallSymbol unicode <+> hsep ts +++ dot+ where ppKTv n k = parens $+ ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k++ppFixities :: [(DocName, Fixity)] -> Qualification -> Html+ppFixities [] _ = noHtml+ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge+ where+ ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<+ (toHtml d <+> toHtml (show p) <+> ppNames ns)++ ppDir InfixR = "infixr"+ ppDir InfixL = "infixl"+ ppDir InfixN = "infix"++ ppNames = case fs of+ _:[] -> const noHtml -- Don't display names for fixities on single names+ _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)++ uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs+ , let d' = ppDir d+ , then group by Down (p,d') using groupWith ]++ rightEdge = thespan ! [theclass "rightedge"] << noHtml+++ppTyVars :: LHsTyVarBndrs DocName -> [Html]+ppTyVars tvs = map ppTyName (tyvarNames tvs)+++tyvarNames :: LHsTyVarBndrs DocName -> [Name]+tyvarNames = map getName . hsLTyVarNames+++ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName+ -> ForeignDecl DocName -> [(DocName, Fixity)]+ -> Splice -> Unicode -> Qualification -> Html+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities+ splice unicode qual+ = ppFunSig summary links loc doc [name] typ fixities splice unicode qual+ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"+++-- we skip type patterns for now+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan+ -> DocForDecl DocName -> TyClDecl DocName+ -> Splice -> Unicode -> Qualification -> Html+ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars+ , tcdRhs = ltype })+ splice unicode qual+ = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc+ (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)+ splice unicode qual+ where+ hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)+ full = hdr <+> equals <+> ppLType unicode qual ltype+ occ = nameOccName . getName $ name+ fixs+ | summary = noHtml+ | otherwise = ppFixities fixities qual+ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"+++ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html+ppTypeSig summary nms pp_ty unicode =+ concatHtml htmlNames <+> dcolon unicode <+> pp_ty+ where+ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms+++ppTyName :: Name -> Html+ppTyName = ppName Prefix+++--------------------------------------------------------------------------------+-- * Type families+--------------------------------------------------------------------------------+++ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName+ -> Unicode -> Qualification -> Html+ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info+ , fdKindSig = mkind })+ unicode qual =+ (case info of+ OpenTypeFamily+ | associated -> keyword "type"+ | otherwise -> keyword "type family"+ DataFamily+ | associated -> keyword "data"+ | otherwise -> keyword "data family"+ ClosedTypeFamily _+ -> keyword "type family"+ ) <+>++ ppFamDeclBinderWithVars summary d <+>++ (case mkind of+ Just kind -> dcolon unicode <+> ppLKind unicode qual kind+ Nothing -> noHtml+ )++ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->+ [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->+ FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html+ppTyFam summary associated links instances fixities loc doc decl splice unicode qual++ | summary = ppTyFamHeader True associated decl unicode qual+ | otherwise = header_ +++ docSection qual doc +++ instancesBit++ where+ docname = unLoc $ fdLName decl++ header_ = topDeclElem links loc splice [docname] $+ ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual++ instancesBit+ | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl+ , not summary+ = subEquations qual $ map (ppTyFamEqn . unLoc) eqns++ | otherwise+ = ppInstances instances docname unicode qual++ -- Individual equation of a closed type family+ ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs+ , tfie_pats = HsWB { hswb_cts = ts }}+ = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual+ <+> equals <+> ppType unicode qual (unLoc rhs)+ , Nothing, [] )++--------------------------------------------------------------------------------+-- * Associated Types+--------------------------------------------------------------------------------+++ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html+ppAssocType summ links doc (L loc decl) fixities splice unicode qual =+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual+++--------------------------------------------------------------------------------+-- * TyClDecl helpers+--------------------------------------------------------------------------------++-- | Print a type family and its variables+ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html+ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =+ ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)++-- | Print a newtype / data binder and its variables+ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html+ppDataBinderWithVars summ decl =+ ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)++--------------------------------------------------------------------------------+-- * Type applications+--------------------------------------------------------------------------------+++-- | Print an application of a DocName and two lists of HsTypes (kinds, types)+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]+ -> Unicode -> Qualification -> Html+ppAppNameTypes n ks ts unicode qual =+ ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)+++-- | Print an application of a DocName and a list of Names+ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html+ppAppDocNameNames summ n ns =+ ppTypeApp n [] ns ppDN ppTyName+ where+ ppDN notation = ppBinderFixity notation summ . nameOccName . getName+ ppBinderFixity Infix = ppBinderInfix+ ppBinderFixity _ = ppBinder++-- | General printing of type applications+ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html+ppTypeApp n [] (t1:t2:rest) ppDN ppT+ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)+ | operator = opApp+ where+ operator = isNameSym . getName $ n+ opApp = ppT t1 <+> ppDN Infix n <+> ppT t2++ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)+++-------------------------------------------------------------------------------+-- * Contexts+-------------------------------------------------------------------------------+++ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode+ -> Qualification -> Html+ppLContext = ppContext . unLoc+ppLContextNoArrow = ppContextNoArrow . unLoc+++ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html+ppContextNoArrow [] _ _ = noHtml+ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual+++ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html+ppContextNoLocs [] _ _ = noHtml+ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual+ <+> darrow unicode+++ppContext :: HsContext DocName -> Unicode -> Qualification -> Html+ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual+++ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html+ppHsContext [] _ _ = noHtml+ppHsContext [p] unicode qual = ppCtxType unicode qual p+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)+++-------------------------------------------------------------------------------+-- * Class declarations+-------------------------------------------------------------------------------+++ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]+ -> Unicode -> Qualification -> Html+ppClassHdr summ lctxt n tvs fds unicode qual =+ keyword "class"+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)+ <+> ppAppDocNameNames summ n (tyvarNames tvs)+ <+> ppFds fds unicode qual+++ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html+ppFds fds unicode qual =+ if null fds then noHtml else+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))+ where+ fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2+ ppVars = hsep . map (ppDocName qual Prefix True)++ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan+ -> [(DocName, DocForDecl DocName)]+ -> Splice -> Unicode -> Qualification -> Html+ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs+ , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc+ subdocs splice unicode qual =+ if not (any isVanillaLSig sigs) && null ats+ then (if summary then id else topDeclElem links loc splice [nm]) hdr+ else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")+ +++ shortSubDecls False+ (+ [ ppAssocType summary links doc at [] splice unicode qual | at <- ats+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++++ -- ToDo: add associated type defaults++ [ ppFunSig summary links loc doc names typ [] splice unicode qual+ | L _ (TypeSig lnames (L _ typ)) <- sigs+ , let doc = lookupAnySubdoc (head names) subdocs+ names = map unLoc lnames ]+ -- FIXME: is taking just the first name ok? Is it possible that+ -- there are different subdocs for different names in a single+ -- type signature?+ )+ where+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual+ nm = unLoc lname+ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"++++ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]+ -> SrcSpan -> Documentation DocName+ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName+ -> Splice -> Unicode -> Qualification -> Html+ppClassDecl summary links instances fixities loc d subdocs+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })+ splice unicode qual+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual+ | otherwise = classheader +++ docSection qual d+ +++ minimalBit +++ atBit +++ methodBit +++ instancesBit+ where+ classheader+ | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)+ | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)++ -- Only the fixity relevant to the class header+ fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual++ nm = tcdName decl++ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds++ -- ToDo: add assocatied typ defaults+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual+ | at <- ats+ , let n = unL . fdLName $ unL at+ doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs+ subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]++ methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual+ | L _ (TypeSig lnames (L _ typ)) <- lsigs+ , let doc = lookupAnySubdoc (head names) subdocs+ subfixs = [ f | n <- names+ , f@(n',_) <- fixities+ , n == n' ]+ names = map unLoc lnames ]+ -- FIXME: is taking just the first name ok? Is it possible that+ -- there are different subdocs for different names in a single+ -- type signature?++ minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of+ -- Miminal complete definition = every shown method+ And xs : _ | sort [getName n | Var (L _ n) <- xs] ==+ sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]+ -> noHtml++ -- Minimal complete definition = the only shown method+ Var (L _ n) : _ | [getName n] ==+ [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]+ -> noHtml++ -- Minimal complete definition = nothing+ And [] : _ -> subMinimal $ toHtml "Nothing"++ m : _ -> subMinimal $ ppMinimal False m+ _ -> noHtml++ ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n+ ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs+ where wrap | p = parens | otherwise = id++ instancesBit = ppInstances instances nm unicode qual++ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+++ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html+ppInstances instances baseName unicode qual+ = subInstances qual instName (map instDecl instances)+ where+ instName = getOccString $ getName baseName+ instDecl :: DocInstance DocName -> SubDecl+ instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])+ instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual+ <+> ppAppNameTypes n ks ts unicode qual+ instHead (n, ks, ts, TypeInst rhs) = keyword "type"+ <+> ppAppNameTypes n ks ts unicode qual+ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs+ instHead (n, ks, ts, DataInst dd) = keyword "data"+ <+> ppAppNameTypes n ks ts unicode qual+ <+> ppShortDataDecl False True dd unicode qual++lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n+++-------------------------------------------------------------------------------+-- * Data & newtype declarations+-------------------------------------------------------------------------------+++-- TODO: print contexts+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html+ppShortDataDecl summary dataInst dataDecl unicode qual++ | [] <- cons = dataHeader++ | [lcon] <- cons, ResTyH98 <- resTy,+ (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual+ = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot++ | ResTyH98 <- resTy = dataHeader+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)++ | otherwise = (dataHeader <+> keyword "where")+ +++ shortSubDecls dataInst (map doGADTConstr cons)++ where+ dataHeader+ | dataInst = noHtml+ | otherwise = ppDataHeader summary dataDecl unicode qual+ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual+ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual++ cons = dd_cons (tcdDataDefn dataDecl)+ resTy = (con_res . unLoc . head) cons+++ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->+ [(DocName, DocForDecl DocName)] ->+ SrcSpan -> Documentation DocName -> TyClDecl DocName ->+ Splice -> Unicode -> Qualification -> Html+ppDataDecl summary links instances fixities subdocs loc doc dataDecl+ splice unicode qual++ | summary = ppShortDataDecl summary False dataDecl unicode qual+ | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit++ where+ docname = tcdName dataDecl+ cons = dd_cons (tcdDataDefn dataDecl)+ resTy = (con_res . unLoc . head) cons++ header_ = topDeclElem links loc splice [docname] $+ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix++ fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual++ whereBit+ | null cons = noHtml+ | otherwise = case resTy of+ ResTyGADT _ -> keyword "where"+ _ -> noHtml++ constrBit = subConstructors qual+ [ ppSideBySideConstr subdocs subfixs unicode qual c+ | c <- cons+ , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities+ ]++ instancesBit = ppInstances instances docname unicode qual++++ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot+ where+ (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual+++-- returns three pieces: header, body, footer so that header & footer can be+-- incorporated into the declaration+ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)+ppShortConstrParts summary dataInst con unicode qual = case con_res con of+ ResTyH98 -> case con_details con of+ PrefixCon args ->+ (header_ unicode qual +++ hsep (ppBinder summary occ+ : map (ppLParendType unicode qual) args), noHtml, noHtml)+ RecCon fields ->+ (header_ unicode qual +++ ppBinder summary occ <+> char '{',+ doRecordFields fields,+ char '}')+ InfixCon arg1 arg2 ->+ (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,+ ppBinderInfix summary occ, ppLParendType unicode qual arg2],+ noHtml, noHtml)++ ResTyGADT resTy -> case con_details con of+ -- prefix & infix could use hsConDeclArgTys if it seemed to+ -- simplify the code.+ PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)+ -- display GADT records with the new syntax,+ -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)+ -- (except each field gets its own line in docs, to match+ -- non-GADT records)+ RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>+ ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{',+ doRecordFields fields,+ char '}' <+> arrow unicode <+> ppLType unicode qual resTy)+ InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)++ where+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)+ doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [+ ppForAllCon forall_ ltvs lcontext unicode qual,+ ppLType unicode qual (foldr mkFunTy resTy args) ]++ header_ = ppConstrHdr forall_ tyVars context+ occ = nameOccName . getName . unLoc . con_name $ con+ ltvs = con_qvars con+ tyVars = tyvarNames ltvs+ lcontext = con_cxt con+ context = unLoc (con_cxt con)+ forall_ = con_explicit con+ mkFunTy a b = noLoc (HsFunTy a b)+++-- ppConstrHdr is for (non-GADT) existentials constructors' syntax+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode+ -> Qualification -> Html+ppConstrHdr forall_ tvs ctxt unicode qual+ = (if null tvs then noHtml else ppForall)+ ++++ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual+ <+> darrow unicode +++ toHtml " ")+ where+ ppForall = case forall_ of+ Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "+ Implicit -> noHtml+++ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]+ -> Unicode -> Qualification -> LConDecl DocName -> SubDecl+ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)+ where+ decl = case con_res con of+ ResTyH98 -> case con_details con of+ PrefixCon args ->+ hsep ((header_ +++ ppBinder False occ)+ : map (ppLParendType unicode qual) args)+ <+> fixity++ RecCon _ -> header_ +++ ppBinder False occ <+> fixity++ InfixCon arg1 arg2 ->+ hsep [header_ +++ ppLParendType unicode qual arg1,+ ppBinderInfix False occ,+ ppLParendType unicode qual arg2]+ <+> fixity++ ResTyGADT resTy -> case con_details con of+ -- prefix & infix could also use hsConDeclArgTys if it seemed to+ -- simplify the code.+ PrefixCon args -> doGADTCon args resTy+ cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy++ fieldPart = case con_details con of+ RecCon fields -> [doRecordFields fields]+ _ -> []++ doRecordFields fields = subFields qual+ (map (ppSideBySideField subdocs unicode qual) fields)+ doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html+ doGADTCon args resTy = ppBinder False occ <+> dcolon unicode+ <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual,+ ppLType unicode qual (foldr mkFunTy resTy args) ]+ <+> fixity++ fixity = ppFixities fixities qual+ header_ = ppConstrHdr forall_ tyVars context unicode qual+ occ = nameOccName . getName . unLoc . con_name $ con+ ltvs = con_qvars con+ tyVars = tyvarNames (con_qvars con)+ context = unLoc (con_cxt con)+ forall_ = con_explicit con+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,+ -- or also because we want Haddock to do the doc-parsing, not GHC.+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst+ mkFunTy a b = noLoc (HsFunTy a b)+++ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification+ -> ConDeclField DocName -> SubDecl+ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =+ (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,+ mbDoc,+ [])+ where+ -- don't use cd_fld_doc for same reason we don't use con_doc above+ mbDoc = lookup name subdocs >>= combineDocumentation . fst+++ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html+ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)+ = ppBinder summary (nameOccName . getName $ name)+ <+> dcolon unicode <+> ppLType unicode qual ltype+++-- | Print the LHS of a data\/newtype declaration.+-- Currently doesn't handle 'data instance' decls or kind signatures+ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html+ppDataHeader summary decl@(DataDecl { tcdDataDefn =+ HsDataDefn { dd_ND = nd+ , dd_ctxt = ctxt+ , dd_kindSig = ks } })+ unicode qual+ = -- newtype or data+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })+ <+>+ -- context+ ppLContext ctxt unicode qual <+>+ -- T a b c ..., or a :+: b+ ppDataBinderWithVars summary decl+ <+> case ks of+ Nothing -> mempty+ Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x++ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"++--------------------------------------------------------------------------------+-- * Types and contexts+--------------------------------------------------------------------------------+++ppBang :: HsBang -> Html+ppBang HsNoBang = noHtml+ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,+ -- so we just show the strictness annotation+++tupleParens :: HsTupleSort -> [Html] -> Html+tupleParens HsUnboxedTuple = ubxParenList+tupleParens _ = parenList+++--------------------------------------------------------------------------------+-- * Rendering of HsType+--------------------------------------------------------------------------------+++pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int++pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC+pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type+ -- (as opposed to (ctx1, ctx2) => type)+pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC+ -- Used for LH arg of (->)+pREC_OP = 3 :: Int -- Used for arg of any infix operator+ -- (we don't keep their fixities around)+pREC_CON = 4 :: Int -- Used for arg of type applicn:+ -- always parenthesise unless atomic++maybeParen :: Int -- Precedence of context+ -> Int -- Precedence of top-level operator+ -> Html -> Html -- Wrap in parens if (ctxt >= op)+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p+ | otherwise = p+++ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification+ -> Located (HsType DocName) -> Html+ppLType unicode qual y = ppType unicode qual (unLoc y)+ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)+ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)+++ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification+ -> HsType DocName -> Html+ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual+ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual+ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual++ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html+ppLKind unicode qual y = ppKind unicode qual (unLoc y)++ppKind :: Unicode -> Qualification -> HsKind DocName -> Html+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual++-- Drop top-level for-all type variables in user style+-- since they are implicit in Haskell++ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName+ -> Located (HsContext DocName) -> Unicode -> Qualification -> Html+ppForAllCon expl tvs cxt unicode qual+ | show_forall = forall_part <+> ppLContext cxt unicode qual+ | otherwise = ppLContext cxt unicode qual+ where+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit+ is_explicit = case expl of {Explicit -> True; Implicit -> False}+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot+++ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)+++ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual+ = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt unicode qual+ <+> ppr_mono_lty pREC_TOP ty unicode qual++-- UnicodeSyntax alternatives+ppr_mono_ty _ (HsTyVar name) True _+ | getOccString (getName name) == "*" = toHtml "★"+ | getOccString (getName name) == "(->)" = toHtml "(→)"++ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty+ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q+ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)+ppr_mono_ty _ (HsKindSig ty kind) u q =+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)+ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)+ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)+ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =+ maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q+ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"+ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"+ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys+ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy"++ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual+ = maybeParen ctxt_prec pREC_CTX $+ ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual++ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual+ = maybeParen ctxt_prec pREC_CON $+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]++ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual+ = maybeParen ctxt_prec pREC_FUN $+ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual+ where+ ppr_op = ppLDocName qual Infix op++ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual+-- = parens (ppr_mono_lty pREC_TOP ty)+ = ppr_mono_lty ctxt_prec ty unicode qual++ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual+ = ppr_mono_lty ctxt_prec ty unicode qual++ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n++ppr_tylit :: HsTyLit -> Html+ppr_tylit (HsNumTy n) = toHtml (show n)+ppr_tylit (HsStrTy s) = toHtml (show s)+++ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual+ in+ maybeParen ctxt_prec pREC_FUN $+ hsep [p1, arrow unicode <+> p2]
+ src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -0,0 +1,143 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.DocMarkup+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.DocMarkup (+ docToHtml,+ rdrDocToHtml,+ origDocToHtml,+ docToHtmlNoAnchors,++ docElement, docSection, docSection_,+) where++import Control.Applicative ((<$>))++import Haddock.Backends.Xhtml.Names+import Haddock.Backends.Xhtml.Utils+import Haddock.Types+import Haddock.Utils+import Haddock.Doc (combineDocumentation)++import Text.XHtml hiding ( name, p, quote )+import Data.Maybe (fromMaybe)++import GHC++parHtmlMarkup :: Qualification -> Bool+ -> (Bool -> a -> Html) -> DocMarkup a Html+parHtmlMarkup qual insertAnchors ppId = Markup {+ markupEmpty = noHtml,+ markupString = toHtml,+ markupParagraph = paragraph,+ markupAppend = (+++),+ markupIdentifier = thecode . ppId insertAnchors,+ markupIdentifierUnchecked = thecode . ppUncheckedLink qual,+ markupModule = \m -> let (mdl,ref) = break (=='#') m+ -- Accomodate for old style+ -- foo\#bar anchors+ mdl' = case reverse mdl of+ '\\':_ -> init mdl+ _ -> mdl+ in ppModuleRef (mkModuleName mdl') ref,+ markupWarning = thediv ! [theclass "warning"],+ markupEmphasis = emphasize,+ markupBold = strong,+ markupMonospaced = thecode,+ markupUnorderedList = unordList,+ markupOrderedList = ordList,+ markupDefList = defList,+ markupCodeBlock = pre,+ markupHyperlink = \(Hyperlink url mLabel)+ -> if insertAnchors+ then anchor ! [href url]+ << fromMaybe url mLabel+ else toHtml $ fromMaybe url mLabel,+ markupAName = \aname -> namedAnchor aname << "",+ markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),+ markupProperty = pre . toHtml,+ markupExample = examplesToHtml,+ markupHeader = \(Header l t) -> makeHeader l t+ }+ where+ makeHeader :: Int -> Html -> Html+ makeHeader 1 mkup = h1 mkup+ makeHeader 2 mkup = h2 mkup+ makeHeader 3 mkup = h3 mkup+ makeHeader 4 mkup = h4 mkup+ makeHeader 5 mkup = h5 mkup+ makeHeader 6 mkup = h6 mkup+ makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"+++ examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]++ exampleToHtml (Example expression result) = htmlExample+ where+ htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)+ htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]+ htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]+++-- If the doc is a single paragraph, don't surround it with <P> (this causes+-- ugly extra whitespace with some browsers). FIXME: Does this still apply?+docToHtml :: Qualification -> Doc DocName -> Html+docToHtml qual = markup fmt . cleanup+ where fmt = parHtmlMarkup qual True (ppDocName qual Raw)++-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element+-- in links. This is used to generate the Contents box elements.+docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html+docToHtmlNoAnchors qual = markup fmt . cleanup+ where fmt = parHtmlMarkup qual False (ppDocName qual Raw)++origDocToHtml :: Qualification -> Doc Name -> Html+origDocToHtml qual = markup fmt . cleanup+ where fmt = parHtmlMarkup qual True (const $ ppName Raw)+++rdrDocToHtml :: Qualification -> Doc RdrName -> Html+rdrDocToHtml qual = markup fmt . cleanup+ where fmt = parHtmlMarkup qual True (const ppRdrName)+++docElement :: (Html -> Html) -> Html -> Html+docElement el content_ =+ if isNoHtml content_+ then el ! [theclass "doc empty"] << spaceHtml+ else el ! [theclass "doc"] << content_+++docSection :: Qualification -> Documentation DocName -> Html+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation+++docSection_ :: Qualification -> Doc DocName -> Html+docSection_ qual = (docElement thediv <<) . docToHtml qual+++cleanup :: Doc a -> Doc a+cleanup = markup fmtUnParagraphLists+ where+ -- If there is a single paragraph, then surrounding it with <P>..</P>+ -- can add too much whitespace in some browsers (eg. IE). However if+ -- we have multiple paragraphs, then we want the extra whitespace to+ -- separate them. So we catch the single paragraph case and transform it+ -- here. We don't do this in code blocks as it eliminates line breaks.+ unParagraph :: Doc a -> Doc a+ unParagraph (DocParagraph d) = d+ unParagraph doc = doc++ fmtUnParagraphLists :: DocMarkup a (Doc a)+ fmtUnParagraphLists = idMarkup {+ markupUnorderedList = DocUnorderedList . map unParagraph,+ markupOrderedList = DocOrderedList . map unParagraph+ }
+ src/Haddock/Backends/Xhtml/Layout.hs view
@@ -0,0 +1,235 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.Layout+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Layout (+ miniBody,++ divPackageHeader, divContent, divModuleHeader, divFooter,+ divTableOfContents, divDescription, divSynposis, divInterface,+ divIndex, divAlphabet, divModuleList,++ sectionName,+ nonEmptySectionName,++ shortDeclList,+ shortSubDecls,++ divTopDecl,++ SubDecl,+ subArguments,+ subAssociatedTypes,+ subConstructors,+ subEquations,+ subFields,+ subInstances,+ subMethods,+ subMinimal,++ topDeclElem, declElem,+) where+++import Haddock.Backends.Xhtml.DocMarkup+import Haddock.Backends.Xhtml.Types+import Haddock.Backends.Xhtml.Utils+import Haddock.Types+import Haddock.Utils (makeAnchorId)++import qualified Data.Map as Map+import Text.XHtml hiding ( name, title, p, quote )++import FastString ( unpackFS )+import GHC+++--------------------------------------------------------------------------------+-- * Sections of the document+--------------------------------------------------------------------------------+++miniBody :: Html -> Html+miniBody = body ! [identifier "mini"]+++sectionDiv :: String -> Html -> Html+sectionDiv i = thediv ! [identifier i]+++sectionName :: Html -> Html+sectionName = paragraph ! [theclass "caption"]+++-- | Make an element that always has at least something (a non-breaking space).+-- If it would have otherwise been empty, then give it the class ".empty".+nonEmptySectionName :: Html -> Html+nonEmptySectionName c+ | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml+ | otherwise = paragraph ! [theclass "caption"] $ c+++divPackageHeader, divContent, divModuleHeader, divFooter,+ divTableOfContents, divDescription, divSynposis, divInterface,+ divIndex, divAlphabet, divModuleList+ :: Html -> Html++divPackageHeader = sectionDiv "package-header"+divContent = sectionDiv "content"+divModuleHeader = sectionDiv "module-header"+divFooter = sectionDiv "footer"+divTableOfContents = sectionDiv "table-of-contents"+divDescription = sectionDiv "description"+divSynposis = sectionDiv "synopsis"+divInterface = sectionDiv "interface"+divIndex = sectionDiv "index"+divAlphabet = sectionDiv "alphabet"+divModuleList = sectionDiv "module-list"+++--------------------------------------------------------------------------------+-- * Declaration containers+--------------------------------------------------------------------------------+++shortDeclList :: [Html] -> Html+shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items+++shortSubDecls :: Bool -> [Html] -> Html+shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items+ where i | inst = li ! [theclass "inst"]+ | otherwise = li+ c | inst = "inst"+ | otherwise = "subs"+++divTopDecl :: Html -> Html+divTopDecl = thediv ! [theclass "top"]+++type SubDecl = (Html, Maybe (Doc DocName), [Html])+++divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html+divSubDecls cssClass captionName = maybe noHtml wrap+ where+ wrap = (subSection <<) . (subCaption +++)+ subSection = thediv ! [theclass $ unwords ["subs", cssClass]]+ subCaption = paragraph ! [theclass "caption"] << captionName+++subDlist :: Qualification -> [SubDecl] -> Maybe Html+subDlist _ [] = Nothing+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv+ where+ subEntry (decl, mdoc, subs) =+ dterm ! [theclass "src"] << decl+ ++++ docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)++ clearDiv = thediv ! [ theclass "clear" ] << noHtml+++subTable :: Qualification -> [SubDecl] -> Maybe Html+subTable _ [] = Nothing+subTable qual decls = Just $ table << aboves (concatMap subRow decls)+ where+ subRow (decl, mdoc, subs) =+ (td ! [theclass "src"] << decl+ <->+ docElement td << fmap (docToHtml qual) mdoc)+ : map (cell . (td <<)) subs+++subBlock :: [Html] -> Maybe Html+subBlock [] = Nothing+subBlock hs = Just $ toHtml hs+++subArguments :: Qualification -> [SubDecl] -> Html+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual+++subAssociatedTypes :: [Html] -> Html+subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock+++subConstructors :: Qualification -> [SubDecl] -> Html+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual+++subFields :: Qualification -> [SubDecl] -> Html+subFields qual = divSubDecls "fields" "Fields" . subDlist qual+++subEquations :: Qualification -> [SubDecl] -> Html+subEquations qual = divSubDecls "equations" "Equations" . subTable qual+++subInstances :: Qualification -> String -> [SubDecl] -> Html+subInstances qual nm = maybe noHtml wrap . instTable+ where+ wrap = (subSection <<) . (subCaption +++)+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual+ subSection = thediv ! [theclass "subs instances"]+ subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"+ id_ = makeAnchorId $ "i:" ++ nm++subMethods :: [Html] -> Html+subMethods = divSubDecls "methods" "Methods" . subBlock++subMinimal :: Html -> Html+subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem+++-- a box for displaying code+declElem :: Html -> Html+declElem = paragraph ! [theclass "src"]+++-- a box for top level documented names+-- it adds a source and wiki link at the right hand side of the box+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html+topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =+ declElem << (html <+> srcLink <+> wikiLink)+ where srcLink = let nameUrl = Map.lookup origPkg sourceMap+ lineUrl = Map.lookup origPkg lineMap+ mUrl | splice = lineUrl+ -- Use the lineUrl as a backup+ | otherwise = maybe lineUrl Just nameUrl in+ case mUrl of+ Nothing -> noHtml+ Just url -> let url' = spliceURL (Just fname) (Just origMod)+ (Just n) (Just loc) url+ in anchor ! [href url', theclass "link"] << "Source"++ wikiLink =+ case maybe_wiki_url of+ Nothing -> noHtml+ Just url -> let url' = spliceURL (Just fname) (Just mdl)+ (Just n) (Just loc) url+ in anchor ! [href url', theclass "link"] << "Comments"++ -- For source links, we want to point to the original module,+ -- because only that will have the source.+ -- TODO: do something about type instances. They will point to+ -- the module defining the type family, which is wrong.+ origMod = nameModule n+ origPkg = modulePackageId origMod++ -- Name must be documented, otherwise we wouldn't get here+ Documented n mdl = head names+ -- FIXME: is it ok to simply take the first name?++ fname = case loc of+ RealSrcSpan l -> unpackFS (srcSpanFile l)+ UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
+ src/Haddock/Backends/Xhtml/Names.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.Names+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Names (+ ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,+ ppBinder, ppBinderInfix, ppBinder',+ ppModule, ppModuleRef, ppIPName, linkId, Notation(..)+) where+++import Haddock.Backends.Xhtml.Utils+import Haddock.GhcUtils+import Haddock.Types+import Haddock.Utils++import Text.XHtml hiding ( name, title, p, quote )+import qualified Data.Map as M+import qualified Data.List as List++import GHC+import Name+import RdrName+import FastString (unpackFS)+++-- | Indicator of how to render a 'DocName' into 'Html'+data Notation = Raw -- ^ Render as-is.+ | Infix -- ^ Render using infix notation.+ | Prefix -- ^ Render using prefix notation.+ deriving (Eq, Show)++ppOccName :: OccName -> Html+ppOccName = toHtml . occNameString+++ppRdrName :: RdrName -> Html+ppRdrName = ppOccName . rdrNameOcc++ppIPName :: HsIPName -> Html+ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS+++ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName+++-- The Bool indicates if it is to be rendered in infix notation+ppLDocName :: Qualification -> Notation -> Located DocName -> Html+ppLDocName qual notation (L _ d) = ppDocName qual notation True d++ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html+ppDocName qual notation insertAnchors docName =+ case docName of+ Documented name mdl ->+ linkIdOcc mdl (Just (nameOccName name)) insertAnchors+ << ppQualifyName qual notation name mdl+ Undocumented name+ | isExternalName name || isWiredInName name ->+ ppQualifyName qual notation name (nameModule name)+ | otherwise -> ppName notation name++-- | Render a name depending on the selected qualification mode+ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html+ppQualifyName qual notation name mdl =+ case qual of+ NoQual -> ppName notation name+ FullQual -> ppFullQualName notation mdl name+ LocalQual localmdl ->+ if moduleString mdl == moduleString localmdl+ then ppName notation name+ else ppFullQualName notation mdl name+ RelativeQual localmdl ->+ case List.stripPrefix (moduleString localmdl) (moduleString mdl) of+ -- local, A.x -> x+ Just [] -> ppName notation name+ -- sub-module, A.B.x -> B.x+ Just ('.':m) -> toHtml $ m ++ '.' : getOccString name+ -- some module with same prefix, ABC.x -> ABC.x+ Just _ -> ppFullQualName notation mdl name+ -- some other module, D.x -> D.x+ Nothing -> ppFullQualName notation mdl name+ AliasedQual aliases localmdl ->+ case (moduleString mdl == moduleString localmdl,+ M.lookup mdl aliases) of+ (False, Just alias) -> ppQualName notation alias name+ _ -> ppName notation name+++ppFullQualName :: Notation -> Module -> Name -> Html+ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname+ where+ qname = toHtml $ moduleString mdl ++ '.' : getOccString name++ppQualName :: Notation -> ModuleName -> Name -> Html+ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname+ where+ qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name++ppName :: Notation -> Name -> Html+ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)+++ppBinder :: Bool -> OccName -> Html+-- The Bool indicates whether we are generating the summary, in which case+-- the binder will be a link to the full definition.+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n+ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]+ << ppBinder' Prefix n++ppBinderInfix :: Bool -> OccName -> Html+ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n+ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]+ << ppBinder' Infix n++ppBinder' :: Notation -> OccName -> Html+ppBinder' notation n = wrapInfix notation n $ ppOccName n++wrapInfix :: Notation -> OccName -> Html -> Html+wrapInfix notation n = case notation of+ Infix | is_star_kind -> id+ | not is_sym -> quote+ Prefix | is_star_kind -> id+ | is_sym -> parens+ _ -> id+ where+ is_sym = isSymOcc n+ is_star_kind = isTcOcc n && occNameString n == "*"++linkId :: Module -> Maybe Name -> Html -> Html+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True+++linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html+linkIdOcc mdl mbName insertAnchors =+ if insertAnchors+ then anchor ! [href url]+ else id+ where+ url = case mbName of+ Nothing -> moduleUrl mdl+ Just name -> moduleNameUrl mdl name+++linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html+linkIdOcc' mdl mbName = anchor ! [href url]+ where+ url = case mbName of+ Nothing -> moduleHtmlFile' mdl+ Just name -> moduleNameUrl' mdl name+++ppModule :: Module -> Html+ppModule mdl = anchor ! [href (moduleUrl mdl)]+ << toHtml (moduleString mdl)+++ppModuleRef :: ModuleName -> String -> Html+ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]+ << toHtml (moduleNameString mdl)+ -- NB: The ref parameter already includes the '#'.+ -- This function is only called from markupModule expanding a+ -- DocModule, which doesn't seem to be ever be used.
+ src/Haddock/Backends/Xhtml/Themes.hs view
@@ -0,0 +1,209 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.Themes+-- Copyright : (c) Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Themes (+ Themes,+ getThemes,++ cssFiles, styleSheet+ )+ where++import Haddock.Options++import Control.Applicative+import Control.Monad (liftM)+import Data.Char (toLower)+import Data.Either (lefts, rights)+import Data.List (nub)+import Data.Maybe (isJust, listToMaybe)++import System.Directory+import System.FilePath+import Text.XHtml hiding ( name, title, p, quote, (</>) )+import qualified Text.XHtml as XHtml+++--------------------------------------------------------------------------------+-- * CSS Themes+--------------------------------------------------------------------------------++data Theme = Theme {+ themeName :: String,+ themeHref :: String,+ themeFiles :: [FilePath]+ }++type Themes = [Theme]++type PossibleTheme = Either String Theme+type PossibleThemes = Either String Themes+++-- | Find a theme by name (case insensitive match)+findTheme :: String -> Themes -> Maybe Theme+findTheme s = listToMaybe . filter ((== ls).lower.themeName)+ where lower = map toLower+ ls = lower s+++-- | Standard theme used by default+standardTheme :: FilePath -> IO PossibleThemes+standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)+++-- | Default themes that are part of Haddock; added with --default-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.+-- The later is, obviously, the standard theme.+defaultThemes :: FilePath -> IO PossibleThemes+defaultThemes libDir = do+ themeDirs <- getDirectoryItems (libDir </> "html")+ themes <- mapM directoryTheme $ discoverThemes themeDirs+ return $ sequenceEither themes+ where+ discoverThemes paths =+ filterExt ".std-theme" paths ++ filterExt ".theme" paths+ filterExt ext = filter ((== ext).takeExtension)+++-- | Build a theme from a single .css file+singleFileTheme :: FilePath -> IO PossibleTheme+singleFileTheme path =+ if isCssFilePath path+ then retRight $ Theme name file [path]+ else errMessage "File extension isn't .css" path+ where+ name = takeBaseName path+ file = takeFileName path+++-- | Build a theme from a directory+directoryTheme :: FilePath -> IO PossibleTheme+directoryTheme path = do+ items <- getDirectoryItems path+ case filter isCssFilePath items of+ [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items+ [] -> errMessage "No .css file in theme directory" path+ _ -> errMessage "More than one .css file in theme directory" path+++-- | Check if we have a built in theme+doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool+doesBuiltInExist pts s = fmap (either (const False) test) pts+ where test = isJust . findTheme s+++-- | Find a built in theme+builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme+builtInTheme pts s = either Left fetch <$> pts+ where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s+++--------------------------------------------------------------------------------+-- * CSS Theme Arguments+--------------------------------------------------------------------------------++-- | Process input flags for CSS Theme arguments+getThemes :: FilePath -> [Flag] -> IO PossibleThemes+getThemes libDir flags =+ liftM concatEither (mapM themeFlag flags) >>= someTheme+ where+ themeFlag :: Flag -> IO (Either String Themes)+ themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)+ themeFlag (Flag_BuiltInThemes) = builtIns+ themeFlag _ = retRight []++ theme :: FilePath -> IO PossibleTheme+ theme path = pick path+ [(doesFileExist, singleFileTheme),+ (doesDirectoryExist, directoryTheme),+ (doesBuiltInExist builtIns, builtInTheme builtIns)]+ "Theme not found"++ pick :: FilePath+ -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String+ -> IO PossibleTheme+ pick path [] msg = errMessage msg path+ pick path ((test,build):opts) msg = do+ pass <- test path+ if pass then build path else pick path opts msg+++ someTheme :: Either String Themes -> IO (Either String Themes)+ someTheme (Right []) = standardTheme libDir+ someTheme est = return est++ builtIns = defaultThemes libDir+++errMessage :: String -> FilePath -> IO (Either String a)+errMessage msg path = return (Left msg')+ where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"+++retRight :: a -> IO (Either String a)+retRight = return . Right+++--------------------------------------------------------------------------------+-- * File Utilities+--------------------------------------------------------------------------------+++getDirectoryItems :: FilePath -> IO [FilePath]+getDirectoryItems path =+ map (combine path) . filter notDot <$> getDirectoryContents path+ where notDot s = s /= "." && s /= ".."+++isCssFilePath :: FilePath -> Bool+isCssFilePath path = takeExtension path == ".css"+++--------------------------------------------------------------------------------+-- * Style Sheet Utilities+--------------------------------------------------------------------------------++cssFiles :: Themes -> [String]+cssFiles ts = nub $ concatMap themeFiles ts+++styleSheet :: Themes -> Html+styleSheet ts = toHtml $ zipWith mkLink rels ts+ where+ rels = "stylesheet" : repeat "alternate stylesheet"+ mkLink aRel t =+ thelink+ ! [ href (themeHref t), rel aRel, thetype "text/css",+ XHtml.title (themeName t)+ ]+ << noHtml++--------------------------------------------------------------------------------+-- * Either Utilities+--------------------------------------------------------------------------------++-- These three routines are here because Haddock does not have access to the+-- Control.Monad.Error module which supplies the Functor and Monad instances+-- for Either String.++sequenceEither :: [Either a b] -> Either a [b]+sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es))+++liftEither :: (b -> c) -> Either a b -> Either a c+liftEither f = either Left (Right . f)+++concatEither :: [Either a [b]] -> Either a [b]+concatEither = liftEither concat . sequenceEither+
+ src/Haddock/Backends/Xhtml/Types.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.Types+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Types (+ SourceURLs, WikiURLs,+ LinksInfo,+ Splice,+ Unicode,+) where+++import Data.Map+import GHC+++-- the base, module and entity URLs for the source code and wiki links.+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)+type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)+++-- The URL for source and wiki links+type LinksInfo = (SourceURLs, WikiURLs)++-- Whether something is a splice or not+type Splice = Bool++-- Whether unicode syntax is to be used+type Unicode = Bool
+ src/Haddock/Backends/Xhtml/Utils.hs view
@@ -0,0 +1,218 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html.Util+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mark Lentczner 2010+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Backends.Xhtml.Utils (+ renderToString,++ namedAnchor, linkedAnchor,+ spliceURL,+ groupId,++ (<+>), (<=>), char,+ keyword, punctuate,++ braces, brackets, pabrackets, parens, parenList, ubxParenList,+ arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,++ hsep, vcat,++ collapseSection, collapseToggle, collapseControl,+) where+++import Haddock.GhcUtils+import Haddock.Utils++import Data.Maybe++import Text.XHtml hiding ( name, title, p, quote )+import qualified Text.XHtml as XHtml++import GHC ( SrcSpan(..), srcSpanStartLine, Name )+import Module ( Module )+import Name ( getOccString, nameOccName, isValOcc )+++spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->+ Maybe SrcSpan -> String -> String+spliceURL maybe_file maybe_mod maybe_name maybe_loc = run+ where+ file = fromMaybe "" maybe_file+ mdl = case maybe_mod of+ Nothing -> ""+ Just m -> moduleString m++ (name, kind) =+ case maybe_name of+ Nothing -> ("","")+ Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")+ | otherwise -> (escapeStr (getOccString n), "t")++ line = case maybe_loc of+ Nothing -> ""+ Just span_ ->+ case span_ of+ RealSrcSpan span__ ->+ show $ srcSpanStartLine span__+ UnhelpfulSpan _ ->+ error "spliceURL UnhelpfulSpan"++ run "" = ""+ run ('%':'M':rest) = mdl ++ run rest+ run ('%':'F':rest) = file ++ run rest+ run ('%':'N':rest) = name ++ run rest+ run ('%':'K':rest) = kind ++ run rest+ run ('%':'L':rest) = line ++ run rest+ run ('%':'%':rest) = '%' : run rest++ run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest+ run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest+ run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest+ run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest++ run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =+ map (\x -> if x == '.' then c else x) mdl ++ run rest++ run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =+ map (\x -> if x == '/' then c else x) file ++ run rest++ run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest++ run (c:rest) = c : run rest+++renderToString :: Bool -> Html -> String+renderToString debug html+ | debug = renderHtml html+ | otherwise = showHtml html+++hsep :: [Html] -> Html+hsep [] = noHtml+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls++-- | Concatenate a series of 'Html' values vertically, with linebreaks in between.+vcat :: [Html] -> Html+vcat [] = noHtml+vcat htmls = foldr1 (\a b -> a+++br+++b) htmls+++infixr 8 <+>+(<+>) :: Html -> Html -> Html+a <+> b = a +++ sep +++ b+ where+ sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " "++-- | Join two 'Html' values together with a linebreak in between.+-- Has 'noHtml' as left identity.+infixr 8 <=>+(<=>) :: Html -> Html -> Html+a <=> b = a +++ sep +++ b+ where+ sep = if isNoHtml a then noHtml else br+++keyword :: String -> Html+keyword s = thespan ! [theclass "keyword"] << toHtml s+++equals, comma :: Html+equals = char '='+comma = char ','+++char :: Char -> Html+char c = toHtml [c]+++quote :: Html -> Html+quote h = char '`' +++ h +++ '`'+++parens, brackets, pabrackets, braces :: Html -> Html+parens h = char '(' +++ h +++ char ')'+brackets h = char '[' +++ h +++ char ']'+pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"+braces h = char '{' +++ h +++ char '}'+++punctuate :: Html -> [Html] -> [Html]+punctuate _ [] = []+punctuate h (d0:ds) = go d0 ds+ where+ go d [] = [d]+ go d (e:es) = (d +++ h) : go e es+++parenList :: [Html] -> Html+parenList = parens . hsep . punctuate comma+++ubxParenList :: [Html] -> Html+ubxParenList = ubxparens . hsep . punctuate comma+++ubxparens :: Html -> Html+ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"+++dcolon, arrow, darrow, forallSymbol :: Bool -> Html+dcolon unicode = toHtml (if unicode then "∷" else "::")+arrow unicode = toHtml (if unicode then "→" else "->")+darrow unicode = toHtml (if unicode then "⇒" else "=>")+forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"+++dot :: Html+dot = toHtml "."+++-- | Generate a named anchor+namedAnchor :: String -> Html -> Html+namedAnchor n = anchor ! [XHtml.name n]+++linkedAnchor :: String -> Html -> Html+linkedAnchor n = anchor ! [href ('#':n)]+++-- | generate an anchor identifier for a group+groupId :: String -> String+groupId g = makeAnchorId ("g:" ++ g)++--+-- A section of HTML which is collapsible.+--++-- | Attributes for an area that can be collapsed+collapseSection :: String -> Bool -> String -> [HtmlAttr]+collapseSection id_ state classes = [ identifier sid, theclass cs ]+ where cs = unwords (words classes ++ [pick state "show" "hide"])+ sid = "section." ++ id_++-- | Attributes for an area that toggles a collapsed area+collapseToggle :: String -> [HtmlAttr]+collapseToggle id_ = [ strAttr "onclick" js ]+ where js = "toggleSection('" ++ id_ ++ "')";+ +-- | Attributes for an area that toggles a collapsed area,+-- and displays a control.+collapseControl :: String -> Bool -> String -> [HtmlAttr]+collapseControl id_ state classes =+ [ identifier cid, theclass cs ] ++ collapseToggle id_+ where cs = unwords (words classes ++ [pick state "collapser" "expander"])+ cid = "control." ++ id_+++pick :: Bool -> a -> a -> a+pick True t _ = t+pick False _ f = f
+ src/Haddock/Convert.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE CPP, PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Convert+-- Copyright : (c) Isaac Dupree 2009,+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Conversion between TyThing and HsDecl. This functionality may be moved into+-- GHC at some point.+-----------------------------------------------------------------------------+module Haddock.Convert where+-- Some other functions turned out to be useful for converting+-- instance heads, which aren't TyThings, so just export everything.+++import HsSyn+import TcType ( tcSplitSigmaTy )+import TypeRep+import Type(isStrLitTy)+import Kind ( splitKindFunTys, synTyConResKind, isKind )+import Name+import Var+import Class+import TyCon+import CoAxiom+import ConLike+import DataCon+import PatSyn+import FamInstEnv+import BasicTypes ( TupleSort(..) )+import TysPrim ( alphaTyVars )+import TysWiredIn ( listTyConName, eqTyCon )+import PrelNames (ipClassName)+import Bag ( emptyBag )+import Unique ( getUnique )+import SrcLoc ( Located, noLoc, unLoc )+import Data.List( partition )+import Haddock.Types+++-- the main function here! yay!+tyThingToLHsDecl :: TyThing -> LHsDecl Name+tyThingToLHsDecl t = noLoc $ case t of+ -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.+ -- Including built-in functions like seq.+ -- foreign-imported functions could be represented with ForD+ -- instead of SigD if we wanted...+ --+ -- in a future code version we could turn idVarDetails = foreign-call+ -- into a ForD instead of a SigD if we wanted. Haddock doesn't+ -- need to care.+ AnId i -> SigD (synifyIdSig ImplicitizeForAll i)++ -- type-constructors (e.g. Maybe) are complicated, put the definition+ -- later in the file (also it's used for class associated-types too.)+ ATyCon tc+ | Just cl <- tyConClass_maybe tc -- classes are just a little tedious+ -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a+ extractFamilyDecl (FamDecl d) = noLoc d+ extractFamilyDecl _ =+ error "tyThingToLHsDecl: impossible associated tycon"++ atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]+ atFamDecls = map extractFamilyDecl atTyClDecls in+ TyClD $ ClassDecl+ { tcdCtxt = synifyCtx (classSCTheta cl)+ , tcdLName = synifyName cl+ , tcdTyVars = synifyTyVars (classTyVars cl)+ , tcdFDs = map (\ (l,r) -> noLoc+ (map getName l, map getName r) ) $+ snd $ classTvsFds cl+ , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :+ map (noLoc . synifyIdSig DeleteTopLevelQuantification)+ (classMethods cl)+ , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature+ -- class associated-types are a subset of TyCon:+ , tcdATs = atFamDecls+ , tcdATDefs = [] --ignore associated type defaults+ , tcdDocs = [] --we don't have any docs at this point+ , tcdFVs = placeHolderNames }+ | otherwise+ -> TyClD (synifyTyCon Nothing tc)++ -- type-constructors (e.g. Maybe) are complicated, put the definition+ -- later in the file (also it's used for class associated-types too.)+ ACoAxiom ax -> synifyAxiom ax++ -- a data-constructor alone just gets rendered as a function:+ AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]+ (synifyType ImplicitizeForAll (dataConUserType dc)))++ AConLike (PatSynCon ps) ->+#if MIN_VERSION_ghc(7,8,3)+ let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps+#else+ let (_, _, (req_theta, prov_theta)) = patSynSig ps+#endif+ in SigD $ PatSynSig (synifyName ps)+#if MIN_VERSION_ghc(7,8,3)+ (fmap (synifyType WithinType) (patSynTyDetails ps))+ (synifyType WithinType res_ty)+#else+ (fmap (synifyType WithinType) (patSynTyDetails ps))+ (synifyType WithinType (patSynType ps))+#endif+ (synifyCtx req_theta)+ (synifyCtx prov_theta)++synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name+synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })+ = let name = synifyName tc+ typats = map (synifyType WithinType) args+ hs_rhs = synifyType WithinType rhs+ (kvs, tvs) = partition isKindVar tkvs+ in TyFamInstEqn { tfie_tycon = name+ , tfie_pats = HsWB { hswb_cts = typats+ , hswb_kvs = map tyVarName kvs+ , hswb_tvs = map tyVarName tvs }+ , tfie_rhs = hs_rhs }++synifyAxiom :: CoAxiom br -> HsDecl Name+synifyAxiom ax@(CoAxiom { co_ax_tc = tc })+ | isOpenSynFamilyTyCon tc+ , Just branch <- coAxiomSingleBranch_maybe ax+ = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch+ , tfid_fvs = placeHolderNames }))++ | Just ax' <- isClosedSynFamilyTyCon_maybe tc+ , getUnique ax' == getUnique ax -- without the getUniques, type error+ = TyClD (synifyTyCon (Just ax) tc)++ | otherwise+ = error "synifyAxiom: closed/open family confusion"++synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name+synifyTyCon coax tc+ | isFunTyCon tc || isPrimTyCon tc + = DataDecl { tcdLName = synifyName tc+ , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:+ let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind)+ in HsQTvs { hsq_kvs = [] -- No kind polymorphism+ , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))+ alphaTyVars --a, b, c... which are unfortunately all kind *+ }+ + , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + -- algebraic data nor newtype:+ , dd_ctxt = noLoc []+ , dd_cType = Nothing+ , dd_kindSig = Just (synifyKindSig (tyConKind tc))+ -- we have their kind accurately:+ , dd_cons = [] -- No constructors+ , dd_derivs = Nothing }+ , tcdFVs = placeHolderNames }++ | isSynFamilyTyCon tc + = case synTyConRhs_maybe tc of+ Just rhs ->+ let info = case rhs of+ OpenSynFamilyTyCon -> OpenTypeFamily+ ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->+ ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)+ _ -> error "synifyTyCon: type/data family confusion"+ in FamDecl (FamilyDecl { fdInfo = info+ , fdLName = synifyName tc+ , fdTyVars = synifyTyVars (tyConTyVars tc)+ , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })+ Nothing -> error "synifyTyCon: impossible open type synonym?"++ | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?)+ case algTyConRhs tc of+ DataFamilyTyCon ->+ FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))+ Nothing) --always kind '*'+ _ -> error "synifyTyCon: impossible open data type?"+ | isSynTyCon tc+ = case synTyConRhs_maybe tc of+ Just (SynonymTyCon ty) ->+ SynDecl { tcdLName = synifyName tc+ , tcdTyVars = synifyTyVars (tyConTyVars tc)+ , tcdRhs = synifyType WithinType ty+ , tcdFVs = placeHolderNames }+ _ -> error "synifyTyCon: impossible synTyCon"+ | otherwise =+ -- (closed) newtype and data+ let+ alg_nd = if isNewTyCon tc then NewType else DataType+ alg_ctx = synifyCtx (tyConStupidTheta tc)+ name = case coax of+ Just a -> synifyName a -- Data families are named according to their+ -- CoAxioms, not their TyCons+ _ -> synifyName tc+ tyvars = synifyTyVars (tyConTyVars tc)+ kindSig = Just (tyConKind tc)+ -- The data constructors.+ --+ -- Any data-constructors not exported from the module that *defines* the+ -- type will not (cannot) be included.+ --+ -- Very simple constructors, Haskell98 with no existentials or anything,+ -- probably look nicer in non-GADT syntax. In source code, all constructors+ -- must be declared with the same (GADT vs. not) syntax, and it probably+ -- is less confusing to follow that principle for the documentation as well.+ --+ -- There is no sensible infix-representation for GADT-syntax constructor+ -- declarations. They cannot be made in source code, but we could end up+ -- with some here in the case where some constructors use existentials.+ -- That seems like an acceptable compromise (they'll just be documented+ -- in prefix position), since, otherwise, the logic (at best) gets much more+ -- complicated. (would use dataConIsInfix.)+ use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)+ cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)+ -- "deriving" doesn't affect the signature, no need to specify any.+ alg_deriv = Nothing+ defn = HsDataDefn { dd_ND = alg_nd+ , dd_ctxt = alg_ctx+ , dd_cType = Nothing+ , dd_kindSig = fmap synifyKindSig kindSig+ , dd_cons = cons + , dd_derivs = alg_deriv }+ in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn+ , tcdFVs = placeHolderNames }++-- User beware: it is your responsibility to pass True (use_gadt_syntax)+-- for any constructor that would be misrepresented by omitting its+-- result-type.+-- But you might want pass False in simple enough cases,+-- if you think it looks better.+synifyDataCon :: Bool -> DataCon -> LConDecl Name+synifyDataCon use_gadt_syntax dc = noLoc $+ let+ -- dataConIsInfix allegedly tells us whether it was declared with+ -- infix *syntax*.+ use_infix_syntax = dataConIsInfix dc+ use_named_field_syntax = not (null field_tys)+ name = synifyName dc+ -- con_qvars means a different thing depending on gadt-syntax+ (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc++ qvars = if use_gadt_syntax+ then synifyTyVars (univ_tvs ++ ex_tvs)+ else synifyTyVars ex_tvs++ -- skip any EqTheta, use 'orig'inal syntax+ ctx = synifyCtx theta++ linear_tys = zipWith (\ty bang ->+ let tySyn = synifyType WithinType ty+ src_bang = case bang of+ HsUnpack {} -> HsUserBang (Just True) True+ HsStrict -> HsUserBang (Just False) True+ _ -> bang+ in case src_bang of+ HsNoBang -> tySyn+ _ -> noLoc $ HsBangTy bang tySyn+ -- HsNoBang never appears, it's implied instead.+ )+ arg_tys (dataConStrictMarks dc)+ field_tys = zipWith (\field synTy -> ConDeclField+ (synifyName field) synTy Nothing)+ (dataConFieldLabels dc) linear_tys+ hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of+ (True,True) -> error "synifyDataCon: contradiction!"+ (True,False) -> RecCon field_tys+ (False,False) -> PrefixCon linear_tys+ (False,True) -> case linear_tys of+ [a,b] -> InfixCon a b+ _ -> error "synifyDataCon: infix with non-2 args?"+ hs_res_ty = if use_gadt_syntax+ then ResTyGADT (synifyType WithinType res_ty)+ else ResTyH98+ -- finally we get synifyDataCon's result!+ in ConDecl name Implicit{-we don't know nor care-}+ qvars ctx hs_arg_tys hs_res_ty Nothing+ False --we don't want any "deprecated GADT syntax" warnings!+++synifyName :: NamedThing n => n -> Located Name+synifyName = noLoc . getName+++synifyIdSig :: SynifyTypeState -> Id -> Sig Name+synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))+++synifyCtx :: [PredType] -> LHsContext Name+synifyCtx = noLoc . map (synifyType WithinType)+++synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name+synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs+ , hsq_tvs = map synifyTyVar tvs }+ where+ (kvs, tvs) = partition isKindVar ktvs+ synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name)+ | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))+ where+ kind = tyVarKind tv+ name = getName tv++--states of what to do with foralls:+data SynifyTypeState+ = WithinType+ -- ^ normal situation. This is the safe one to use if you don't+ -- quite understand what's going on.+ | ImplicitizeForAll+ -- ^ beginning of a function definition, in which, to make it look+ -- less ugly, those rank-1 foralls are made implicit.+ | DeleteTopLevelQuantification+ -- ^ because in class methods the context is added to the type+ -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)+ -- which is rather sensible,+ -- but we want to restore things to the source-syntax situation where+ -- the defining class gets to quantify all its functions for free!+++synifyType :: SynifyTypeState -> Type -> LHsType Name+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)+synifyType _ (TyConApp tc tys)+ -- Use non-prefix tuple syntax where possible, because it looks nicer.+ | isTupleTyCon tc, tyConArity tc == length tys =+ noLoc $ HsTupleTy (case tupleTyConSort tc of+ BoxedTuple -> HsBoxedTuple+ ConstraintTuple -> HsConstraintTuple+ UnboxedTuple -> HsUnboxedTuple)+ (map (synifyType WithinType) tys)+ -- ditto for lists+ | getName tc == listTyConName, [ty] <- tys =+ noLoc $ HsListTy (synifyType WithinType ty)+ -- ditto for implicit parameter tycons+ | tyConName tc == ipClassName+ , [name, ty] <- tys+ , Just x <- isStrLitTy name+ = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)+ -- and equalities+ | tc == eqTyCon+ , [ty1, ty2] <- tys+ = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)+ -- Most TyCons:+ | otherwise =+ foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))+ (noLoc $ HsTyVar (getName tc))+ (map (synifyType WithinType) tys)+synifyType _ (AppTy t1 t2) = let+ s1 = synifyType WithinType t1+ s2 = synifyType WithinType t2+ in noLoc $ HsAppTy s1 s2+synifyType _ (FunTy t1 t2) = let+ s1 = synifyType WithinType t1+ s2 = synifyType WithinType t2+ in noLoc $ HsFunTy s1 s2+synifyType s forallty@(ForAllTy _tv _ty) =+ let (tvs, ctx, tau) = tcSplitSigmaTy forallty+ in case s of+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau+ _ -> let+ forallPlicitness = case s of+ WithinType -> Explicit+ ImplicitizeForAll -> Implicit+ _ -> error "synifyType: impossible case!!!"+ sTvs = synifyTyVars tvs+ sCtx = synifyCtx ctx+ sTau = synifyType WithinType tau+ in noLoc $+ HsForAllTy forallPlicitness sTvs sCtx sTau+synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t++synifyTyLit :: TyLit -> HsTyLit+synifyTyLit (NumTyLit n) = HsNumTy n+synifyTyLit (StrTyLit s) = HsStrTy s++synifyKindSig :: Kind -> LHsKind Name+synifyKindSig k = synifyType WithinType k++synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name+synifyInstHead (_, preds, cls, types) =+ ( getName cls+ , map (unLoc . synifyType WithinType) ks+ , map (unLoc . synifyType WithinType) ts+ , ClassInst $ map (unLoc . synifyType WithinType) preds+ )+ where (ks,ts) = break (not . isKind) types++-- Convert a family instance, this could be a type family or data family+synifyFamInst :: FamInst -> Bool -> InstHead Name+synifyFamInst fi opaque =+ ( fi_fam fi+ , map (unLoc . synifyType WithinType) ks+ , map (unLoc . synifyType WithinType) ts+ , case fi_flavor fi of+ SynFamilyInst | opaque -> TypeInst Nothing+ SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi+ DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c+ )+ where (ks,ts) = break (not . isKind) $ fi_tys fi
+ src/Haddock/Doc.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Haddock.Doc ( module Documentation.Haddock.Doc+ , docCodeBlock+ , combineDocumentation+ ) where++import Data.Maybe+import Documentation.Haddock.Doc+import Haddock.Types++combineDocumentation :: Documentation name -> Maybe (Doc name)+combineDocumentation (Documentation Nothing Nothing) = Nothing+combineDocumentation (Documentation mDoc mWarning) =+ Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc)++-- Drop trailing whitespace from @..@ code blocks. Otherwise this:+--+-- -- @+-- -- foo+-- -- @+--+-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML+-- gives an extra vertical space after the code block. The single space+-- on the final line seems to trigger the extra vertical space.+--+docCodeBlock :: DocH mod id -> DocH mod id+docCodeBlock (DocString s)+ = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)+docCodeBlock (DocAppend l r)+ = DocAppend l (docCodeBlock r)+docCodeBlock d = d
+ src/Haddock/GhcUtils.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE FlexibleInstances, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.GhcUtils+-- Copyright : (c) David Waern 2006-2009+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Utils for dealing with types from the GHC API+-----------------------------------------------------------------------------+module Haddock.GhcUtils where+++import Data.Version+import Control.Applicative ( (<$>) )+import Control.Arrow+import Data.Foldable hiding (concatMap)+import Data.Function+import Data.Traversable+import Distribution.Compat.ReadP+import Distribution.Text++import Exception+import Outputable+import Name+import Packages+import Module+import RdrName (GlobalRdrEnv)+import GhcMonad (withSession)+import HscTypes+import UniqFM+import GHC+import Class+++moduleString :: Module -> String+moduleString = moduleNameString . moduleName+++-- return the (name,version) of the package+modulePackageInfo :: Module -> (String, [Char])+modulePackageInfo modu = case unpackPackageId pkg of+ Nothing -> (packageIdString pkg, "")+ Just x -> (display $ pkgName x, showVersion (pkgVersion x))+ where pkg = modulePackageId modu+++-- This was removed from GHC 6.11+-- XXX we shouldn't be using it, probably++-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if+-- we could not parse it as such an object.+unpackPackageId :: PackageId -> Maybe PackageIdentifier+unpackPackageId p+ = case [ pid | (pid,"") <- readP_to_S parse str ] of+ [] -> Nothing+ (pid:_) -> Just pid+ where str = packageIdString p+++lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)+lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->+ case lookupUFM (hsc_HPT hsc_env) mod_name of+ Just mod_info -> return (mi_globals (hm_iface mod_info))+ _not_a_home_module -> return Nothing+++isNameSym :: Name -> Bool+isNameSym = isSymOcc . nameOccName+++isVarSym :: OccName -> Bool+isVarSym = isLexVarSym . occNameFS++isConSym :: OccName -> Bool+isConSym = isLexConSym . occNameFS+++getMainDeclBinder :: HsDecl name -> [name]+getMainDeclBinder (TyClD d) = [tcdName d]+getMainDeclBinder (ValD d) =+ case collectHsBindBinders d of+ [] -> []+ (name:_) -> [name]+getMainDeclBinder (SigD d) = sigNameNoLoc d+getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]+getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []+getMainDeclBinder _ = []++-- Extract the source location where an instance is defined. This is used+-- to correlate InstDecls with their Instance/CoAxiom Names, via the+-- instanceMap.+getInstLoc :: InstDecl name -> SrcSpan+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l+getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l+getInstLoc (TyFamInstD (TyFamInstDecl+ -- Since CoAxioms' Names refer to the whole line for type family instances+ -- in particular, we need to dig a bit deeper to pull out the entire+ -- equation. This does not happen for data family instances, for some reason.+ { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l++-- Useful when there is a signature with multiple names, e.g.+-- foo, bar :: Types..+-- but only one of the names is exported and we have to change the+-- type signature to only include the exported names.+filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)+filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)++filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)+filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig+filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig+filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig+filterSigNames _ orig@(MinimalSig _) = Just orig+filterSigNames p (TypeSig ns ty) =+ case filter (p . unLoc) ns of+ [] -> Nothing+ filtered -> Just (TypeSig filtered ty)+filterSigNames _ _ = Nothing++ifTrueJust :: Bool -> name -> Maybe name+ifTrueJust True = Just+ifTrueJust False = const Nothing++sigName :: LSig name -> [name]+sigName (L _ sig) = sigNameNoLoc sig++sigNameNoLoc :: Sig name -> [name]+sigNameNoLoc (TypeSig ns _) = map unLoc ns+sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]+sigNameNoLoc (SpecSig n _ _) = [unLoc n]+sigNameNoLoc (InlineSig n _) = [unLoc n]+sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]+sigNameNoLoc _ = []+++isTyClD :: HsDecl a -> Bool+isTyClD (TyClD _) = True+isTyClD _ = False+++isClassD :: HsDecl a -> Bool+isClassD (TyClD d) = isClassDecl d+isClassD _ = False+++isDocD :: HsDecl a -> Bool+isDocD (DocD _) = True+isDocD _ = False+++isInstD :: HsDecl a -> Bool+isInstD (InstD _) = True+isInstD _ = False+++isValD :: HsDecl a -> Bool+isValD (ValD _) = True+isValD _ = False+++declATs :: HsDecl a -> [a]+declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d+declATs _ = []+++pretty :: Outputable a => DynFlags -> a -> String+pretty = showPpr+++trace_ppr :: Outputable a => DynFlags -> a -> b -> b+trace_ppr dflags x y = trace (pretty dflags x) y+++-------------------------------------------------------------------------------+-- * Located+-------------------------------------------------------------------------------+++unL :: Located a -> a+unL (L _ x) = x+++reL :: a -> Located a+reL = L undefined+++before :: Located a -> Located a -> Bool+before = (<) `on` getLoc+++instance Foldable (GenLocated l) where+ foldMap f (L _ x) = f x+++instance Traversable (GenLocated l) where+ mapM f (L l x) = (return . L l) =<< f x+ traverse f (L l x) = L l <$> f x++-------------------------------------------------------------------------------+-- * NamedThing instances+-------------------------------------------------------------------------------+++instance NamedThing (TyClDecl Name) where+ getName = tcdName+++instance NamedThing (ConDecl Name) where+ getName = unL . con_name+++-------------------------------------------------------------------------------+-- * Subordinates+-------------------------------------------------------------------------------+++class Parent a where+ children :: a -> [Name]+++instance Parent (ConDecl Name) where+ children con =+ case con_details con of+ RecCon fields -> map (unL . cd_fld_name) fields+ _ -> []+++instance Parent (TyClDecl Name) where+ children d+ | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d+ | isClassDecl d =+ map (unL . fdLName . unL) (tcdATs d) +++ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]+ | otherwise = []+++-- | A parent and its children+family :: (NamedThing a, Parent a) => a -> (Name, [Name])+family = getName &&& children+++-- | A mapping from the parent (main-binder) to its children and from each+-- child to its grand-children, recursively.+families :: TyClDecl Name -> [(Name, [Name])]+families d+ | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))+ | isClassDecl d = [family d]+ | otherwise = []+++-- | A mapping from child to parent+parentMap :: TyClDecl Name -> [(Name, Name)]+parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]+++-- | The parents of a subordinate in a declaration+parents :: Name -> HsDecl Name -> [Name]+parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]+parents _ _ = []+++-------------------------------------------------------------------------------+-- * Utils that work in monads defined by GHC+-------------------------------------------------------------------------------+++modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()+modifySessionDynFlags f = do+ dflags <- getSessionDynFlags+ _ <- setSessionDynFlags (f dflags)+ return ()+++-- | A variant of 'gbracket' where the return value from the first computation+-- is not required.+gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c+gbracket_ before_ after thing = gbracket before_ (const after) (const thing)++-- Extract the minimal complete definition of a Name, if one exists+minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)+minimalDef n = do+ mty <- lookupGlobalName n+ case mty of+ Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c+ _ -> return Nothing++-------------------------------------------------------------------------------+-- * DynFlags+-------------------------------------------------------------------------------+++setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags+setObjectDir f d = d{ objectDir = Just f}+setHiDir f d = d{ hiDir = Just f}+setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }+ -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file+ -- \#included from the .hc file when compiling with -fvia-C.+setOutputDir f = setObjectDir f . setHiDir f . setStubDir f+
+ src/Haddock/Interface.hs view
@@ -0,0 +1,244 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2010,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- This module typechecks Haskell modules using the GHC API and processes+-- the result to create 'Interface's. The typechecking and the 'Interface'+-- creation is interleaved, so that when a module is processed, the+-- 'Interface's of all previously processed modules are available. The+-- creation of an 'Interface' from a typechecked module is delegated to+-- "Haddock.Interface.Create".+--+-- When all modules have been typechecked and processed, information about+-- instances are attached to each 'Interface'. This task is delegated to+-- "Haddock.Interface.AttachInstances". Note that this is done as a separate+-- step because GHC can't know about all instances until all modules have been+-- typechecked.+--+-- As a last step a link environment is built which maps names to the \"best\"+-- places to link to in the documentation, and all 'Interface's are \"renamed\"+-- using this environment.+-----------------------------------------------------------------------------+module Haddock.Interface (+ processModules+) where+++import Haddock.GhcUtils+import Haddock.InterfaceFile+import Haddock.Interface.Create+import Haddock.Interface.AttachInstances+import Haddock.Interface.Rename+import Haddock.Options hiding (verbosity)+import Haddock.Types+import Haddock.Utils++import Control.Monad+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Distribution.Verbosity+import System.Directory+import System.FilePath+import Text.Printf++import Digraph+import DynFlags hiding (verbosity)+import Exception+import GHC hiding (verbosity)+import HscTypes+import FastString (unpackFS)++-- | Create 'Interface's and a link environment by typechecking the list of+-- modules using the GHC API and processing the resulting syntax trees.+processModules+ :: Verbosity -- ^ Verbosity of logging to 'stdout'+ -> [String] -- ^ A list of file or module names sorted by+ -- module topology+ -> [Flag] -- ^ Command-line flags+ -> [InterfaceFile] -- ^ Interface files of package dependencies+ -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming+ -- environment+processModules verbosity modules flags extIfaces = do++ out verbosity verbose "Creating interfaces..."+ let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces+ , iface <- ifInstalledIfaces ext ]+ interfaces <- createIfaces0 verbosity modules flags instIfaceMap++ let exportedNames =+ Set.unions $ map (Set.fromList . ifaceExports) $+ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces+ mods = Set.fromList $ map ifaceMod interfaces+ out verbosity verbose "Attaching instances..."+ interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap++ out verbosity verbose "Building cross-linking environment..."+ -- Combine the link envs of the external packages into one+ let extLinks = Map.unions (map ifLinkEnv extIfaces)+ homeLinks = buildHomeLinks interfaces -- Build the environment for the home+ -- package+ links = homeLinks `Map.union` extLinks++ out verbosity verbose "Renaming interfaces..."+ let warnings = Flag_NoWarnings `notElem` flags+ dflags <- getDynFlags+ let (interfaces'', msgs) =+ runWriter $ mapM (renameInterface dflags links warnings) interfaces'+ liftIO $ mapM_ putStrLn msgs++ return (interfaces'', homeLinks)+++--------------------------------------------------------------------------------+-- * Module typechecking and Interface creation+--------------------------------------------------------------------------------+++createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]+createIfaces0 verbosity modules flags instIfaceMap =+ -- Output dir needs to be set before calling depanal since depanal uses it to+ -- compute output file names that are stored in the DynFlags of the+ -- resulting ModSummaries.+ (if useTempDir then withTempOutputDir else id) $ do+ modGraph <- depAnalysis+ if needsTemplateHaskell modGraph then do+ modGraph' <- enableCompilation modGraph+ createIfaces verbosity flags instIfaceMap modGraph'+ else+ createIfaces verbosity flags instIfaceMap modGraph++ where+ useTempDir :: Bool+ useTempDir = Flag_NoTmpCompDir `notElem` flags+++ withTempOutputDir :: Ghc a -> Ghc a+ withTempOutputDir action = do+ tmp <- liftIO getTemporaryDirectory+ x <- liftIO getProcessID+ let dir = tmp </> ".haddock-" ++ show x+ modifySessionDynFlags (setOutputDir dir)+ withTempDir dir action+++ depAnalysis :: Ghc ModuleGraph+ depAnalysis = do+ targets <- mapM (\f -> guessTarget f Nothing) modules+ setTargets targets+ depanal [] False+++ enableCompilation :: ModuleGraph -> Ghc ModuleGraph+ enableCompilation modGraph = do+ let enableComp d = let platform = targetPlatform d+ in d { hscTarget = defaultObjectTarget platform }+ modifySessionDynFlags enableComp+ -- We need to update the DynFlags of the ModSummaries as well.+ let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }+ let modGraph' = map upd modGraph+ return modGraph'+++createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]+createIfaces verbosity flags instIfaceMap mods = do+ let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing+ out verbosity normal "Haddock coverage:"+ (ifaces, _) <- foldM f ([], Map.empty) sortedMods+ return (reverse ifaces)+ where+ f (ifaces, ifaceMap) modSummary = do+ x <- processModule verbosity modSummary flags ifaceMap instIfaceMap+ return $ case x of+ Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)+ Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.+++processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)+processModule verbosity modsum flags modMap instIfaceMap = do+ out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."+ tm <- loadModule =<< typecheckModule =<< parseModule modsum+ if not $ isBootSummary modsum then do+ out verbosity verbose "Creating interface..."+ (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap+ liftIO $ mapM_ putStrLn msg+ dflags <- getDynFlags+ let (haddockable, haddocked) = ifaceHaddockCoverage interface+ percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int+ modString = moduleString (ifaceMod interface)+ coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString+ header = case ifaceDoc interface of+ Documentation Nothing _ -> False+ _ -> True+ undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n+ , expItemMbDoc = (Documentation Nothing _, _)+ } <- ifaceExportItems interface ]+ where+ formatName :: SrcSpan -> HsDecl Name -> String+ formatName loc n = p (getMainDeclBinder n) ++ case loc of+ RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"+ _ -> ""++ p [] = ""+ p (x:_) = let n = pretty dflags x+ ms = modString ++ "."+ in if ms `isPrefixOf` n+ then drop (length ms) n+ else n++ out verbosity normal coverageMsg+ when (Flag_PrintMissingDocs `elem` flags+ && not (null undocumentedExports && header)) $ do+ out verbosity normal " Missing documentation for:"+ unless header $ out verbosity normal " Module header"+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports+ interface' <- liftIO $ evaluate interface+ return (Just interface')+ else+ return Nothing+++--------------------------------------------------------------------------------+-- * Building of cross-linking environment+--------------------------------------------------------------------------------+++-- | Build a mapping which for each original name, points to the "best"+-- place to link to in the documentation. For the definition of+-- "best", we use "the module nearest the bottom of the dependency+-- graph which exports this name", not including hidden modules. When+-- there are multiple choices, we pick a random one.+--+-- The interfaces are passed in in topologically sorted order, but we start+-- by reversing the list so we can do a foldl.+buildHomeLinks :: [Interface] -> LinkEnv+buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)+ where+ upd old_env iface+ | OptHide `elem` ifaceOptions iface = old_env+ | OptNotHome `elem` ifaceOptions iface =+ foldl' keep_old old_env exported_names+ | otherwise = foldl' keep_new old_env exported_names+ where+ exported_names = ifaceVisibleExports iface+ mdl = ifaceMod iface+ keep_old env n = Map.insertWith (\_ old -> old) n mdl env+ keep_new env n = Map.insert n mdl env+++--------------------------------------------------------------------------------+-- * Utils+--------------------------------------------------------------------------------+++withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a+withTempDir dir = gbracket_ (liftIO $ createDirectory dir)+ (liftIO $ removeDirectoryRecursive dir)
+ src/Haddock/Interface/AttachInstances.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE CPP, MagicHash #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.AttachInstances+-- Copyright : (c) Simon Marlow 2006,+-- David Waern 2006-2009,+-- Isaac Dupree 2009+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Interface.AttachInstances (attachInstances) where+++import Haddock.Types+import Haddock.Convert+import Haddock.GhcUtils++import Control.Arrow+import Data.List+import Data.Ord (comparing)+import Data.Function (on)+import qualified Data.Map as Map+import qualified Data.Set as Set++import Class+import FamInstEnv+import FastString+import GHC+import GhcMonad (withSession)+import Id+import InstEnv+import MonadUtils (liftIO)+import Name+import PrelNames+import TcRnDriver (tcRnGetInfo)+import TcType (tcSplitSigmaTy)+import TyCon+import TypeRep+import TysPrim( funTyCon )+import Var hiding (varName)+#define FSLIT(x) (mkFastString# (x#))++type ExportedNames = Set.Set Name+type Modules = Set.Set Module+type ExportInfo = (ExportedNames, Modules)++-- Also attaches fixities+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]+attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces+ where+ -- TODO: take an IfaceMap as input+ ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]++ attach iface = do+ newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)+ (ifaceExportItems iface)+ return $ iface { ifaceExportItems = newItems }+++attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)+attachToExportItem expInfo iface ifaceMap instIfaceMap export =+ case attachFixities export of+ e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do+ mb_info <- getAllInfo (tcdName d)+ let export' =+ e {+ expItemInstances =+ case mb_info of+ Just (_, _, cls_instances, fam_instances) ->+ let fam_insts = [ (synifyFamInst i opaque, n)+ | i <- sortBy (comparing instFam) fam_instances+ , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap+ , not $ isNameHidden expInfo (fi_fam i)+ , not $ any (isTypeHidden expInfo) (fi_tys i)+ , let opaque = isTypeHidden expInfo (fi_rhs i)+ ]+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)+ | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is+ , not $ isInstanceHidden expInfo cls tys+ ]+ in cls_insts ++ fam_insts+ Nothing -> []+ }+ return export'+ e -> return e+ where+ attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =+ nubBy ((==) `on` fst) $ expItemFixities e +++ [ (n',f) | n <- getMainDeclBinder d+ , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]+ , n' <- n : subs+ , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]+ ] }++ attachFixities e = e+++instLookup :: (InstalledInterface -> Map.Map Name a) -> Name+ -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a+instLookup f name iface ifaceMap instIfaceMap =+ case Map.lookup name (f $ toInstalledIface iface) of+ res@(Just _) -> res+ Nothing -> do+ let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap+ iface' <- Map.lookup (nameModule name) ifaceMaps+ Map.lookup name (f iface')++-- | Like GHC's 'instanceHead' but drops "silent" arguments.+instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])+instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)+ where+ dfun = is_dfun ispec+ (tvs, cls, tys) = instanceHead ispec+ (_, theta, _) = tcSplitSigmaTy (idType dfun)++-- | Drop "silent" arguments. See GHC Note [Silent superclass+-- arguments].+dropSilentArgs :: DFunId -> ThetaType -> ThetaType+dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta+++-- | Like GHC's getInfo but doesn't cut things out depending on the+-- interative context, which we don't set sufficiently anyway.+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))+getAllInfo name = withSession $ \hsc_env -> do + (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name+ return r+++--------------------------------------------------------------------------------+-- Collecting and sorting instances+--------------------------------------------------------------------------------+++-- | Simplified type for sorting types, ignoring qualification (not visible+-- in Haddock output) and unifying special tycons with normal ones.+-- For the benefit of the user (looks nice and predictable) and the+-- tests (which prefer output to be deterministic).+data SimpleType = SimpleType Name [SimpleType]+ | SimpleTyLit TyLit+ deriving (Eq,Ord)+++instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])+instHead (_, _, cls, args)+ = (map argCount args, className cls, map simplify args)++argCount :: Type -> Int+argCount (AppTy t _) = argCount t + 1+argCount (TyConApp _ ts) = length ts+argCount (FunTy _ _ ) = 2+argCount (ForAllTy _ t) = argCount t+argCount _ = 0++simplify :: Type -> SimpleType+simplify (ForAllTy _ t) = simplify t+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]+simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])+ where (SimpleType s ts) = simplify t1+simplify (TyVarTy v) = SimpleType (tyVarName v) []+simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)+simplify (LitTy l) = SimpleTyLit l++-- Used for sorting+instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)+instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }+ = (map argCount ts, n, map simplify ts, argCount t, simplify t)+++funTyConName :: Name+funTyConName = mkWiredInName gHC_PRIM+ (mkOccNameFS tcName FSLIT("(->)"))+ funTyConKey+ (ATyCon funTyCon) -- Relevant TyCon+ BuiltInSyntax++--------------------------------------------------------------------------------+-- Filtering hidden instances+--------------------------------------------------------------------------------++-- | A class or data type is hidden iff+--+-- * it is defined in one of the modules that are being processed+--+-- * and it is not exported by any non-hidden module+isNameHidden :: ExportInfo -> Name -> Bool+isNameHidden (names, modules) name =+ nameModule name `Set.member` modules &&+ not (name `Set.member` names)++-- | We say that an instance is «hidden» iff its class or any (part)+-- of its type(s) is hidden.+isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool+isInstanceHidden expInfo cls tys =+ instClassHidden || instTypeHidden+ where+ instClassHidden :: Bool+ instClassHidden = isNameHidden expInfo $ getName cls++ instTypeHidden :: Bool+ instTypeHidden = any (isTypeHidden expInfo) tys++isTypeHidden :: ExportInfo -> Type -> Bool+isTypeHidden expInfo = typeHidden+ where+ typeHidden :: Type -> Bool+ typeHidden t =+ case t of+ TyVarTy {} -> False+ AppTy t1 t2 -> typeHidden t1 || typeHidden t2+ TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args+ FunTy t1 t2 -> typeHidden t1 || typeHidden t2+ ForAllTy _ ty -> typeHidden ty+ LitTy _ -> False++ nameHidden :: Name -> Bool+ nameHidden = isNameHidden expInfo
+ src/Haddock/Interface/Create.hs view
@@ -0,0 +1,867 @@+{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}+{-# OPTIONS_GHC -Wwarn #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.Create+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Interface.Create (createInterface) where++import Documentation.Haddock.Doc (docAppend)+import Haddock.Types+import Haddock.Options+import Haddock.GhcUtils+import Haddock.Utils+import Haddock.Convert+import Haddock.Interface.LexParseRn++import qualified Data.Map as M+import Data.Map (Map)+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Ord+import Control.Applicative+import Control.Arrow (second)+import Control.DeepSeq+import Control.Monad+import Data.Function (on)+import qualified Data.Foldable as F++import qualified Packages+import qualified Module+import qualified SrcLoc+import GHC+import HscTypes+import Name+import Bag+import RdrName+import TcRnTypes+import FastString (concatFS)+++-- | Use a 'TypecheckedModule' to produce an 'Interface'.+-- To do this, we need access to already processed modules in the topological+-- sort. That's what's in the 'IfaceMap'.+createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface+createInterface tm flags modMap instIfaceMap = do++ let ms = pm_mod_summary . tm_parsed_module $ tm+ mi = moduleInfo tm+ L _ hsm = parsedSource tm+ !safety = modInfoSafe mi+ mdl = ms_mod ms+ dflags = ms_hspp_opts ms+ !instances = modInfoInstances mi+ !fam_instances = md_fam_insts md+ !exportedNames = modInfoExports mi++ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm++ -- The renamed source should always be available to us, but it's best+ -- to be on the safe side.+ (group_, mayExports, mayDocHeader) <-+ case renamedSource tm of+ Nothing -> do+ liftErrMsg $ tell [ "Warning: Renamed source is not available." ]+ return (emptyRnGroup, Nothing, Nothing)+ Just (x, _, y, z) -> return (x, y, z)++ opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl+ let opts+ | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0+ | otherwise = opts0++ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader++ let declsWithDocs = topDecls group_+ fixMap = mkFixMap group_+ (decls, _) = unzip declsWithDocs+ localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances+ ++ map getName fam_instances+ -- Locations of all TH splices+ splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]++ maps@(!docMap, !argMap, !subMap, !declMap, _) =+ mkMaps dflags gre localInsts declsWithDocs++ let exports0 = fmap (reverse . map unLoc) mayExports+ exports+ | OptIgnoreExports `elem` opts = Nothing+ | otherwise = exports0+ warningMap = mkWarningMap dflags warnings gre exportedNames++ let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))++ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls+ maps fixMap splices exports instIfaceMap dflags++ let !visibleNames = mkVisibleNames maps exportItems opts++ -- Measure haddock documentation coverage.+ let prunedExportItems0 = pruneExportItems exportItems+ !haddockable = 1 + length exportItems -- module + exports+ !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0+ !coverage = (haddockable, haddocked)++ -- Prune the export list to just those declarations that have+ -- documentation, if the 'prune' option is on.+ let prunedExportItems'+ | OptPrune `elem` opts = prunedExportItems0+ | otherwise = exportItems+ !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'++ let !aliases =+ mkAliasMap dflags $ tm_renamed_source tm+ modWarn = moduleWarning dflags gre warnings++ return $! Interface {+ ifaceMod = mdl+ , ifaceOrigFilename = msHsFilePath ms+ , ifaceInfo = info+ , ifaceDoc = Documentation mbDoc modWarn+ , ifaceRnDoc = Documentation Nothing Nothing+ , ifaceOptions = opts+ , ifaceDocMap = docMap+ , ifaceArgMap = argMap+ , ifaceRnDocMap = M.empty+ , ifaceRnArgMap = M.empty+ , ifaceExportItems = prunedExportItems+ , ifaceRnExportItems = []+ , ifaceExports = exportedNames+ , ifaceVisibleExports = visibleNames+ , ifaceDeclMap = declMap+ , ifaceSubMap = subMap+ , ifaceFixMap = fixMap+ , ifaceModuleAliases = aliases+ , ifaceInstances = instances+ , ifaceFamInstances = fam_instances+ , ifaceHaddockCoverage = coverage+ , ifaceWarningMap = warningMap+ }++mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName+mkAliasMap dflags mRenamedSource =+ case mRenamedSource of+ Nothing -> M.empty+ Just (_,impDecls,_,_) ->+ M.fromList $+ mapMaybe (\(SrcLoc.L _ impDecl) -> do+ alias <- ideclAs impDecl+ return $+ (lookupModuleDyn dflags+ (fmap Module.fsToPackageId $+ ideclPkgQual impDecl)+ (case ideclName impDecl of SrcLoc.L _ name -> name),+ alias))+ impDecls++-- similar to GHC.lookupModule+lookupModuleDyn ::+ DynFlags -> Maybe PackageId -> ModuleName -> Module+lookupModuleDyn _ (Just pkgId) mdlName =+ Module.mkModule pkgId mdlName+lookupModuleDyn dflags Nothing mdlName =+ flip Module.mkModule mdlName $+ case filter snd $+ Packages.lookupModuleInAllPackages dflags mdlName of+ (pkgId,_):_ -> Packages.packageConfigId pkgId+ [] -> Module.mainPackageId+++-------------------------------------------------------------------------------+-- Warnings+-------------------------------------------------------------------------------++mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap+mkWarningMap dflags warnings gre exps = case warnings of+ NoWarnings -> M.empty+ WarnAll _ -> M.empty+ WarnSome ws ->+ let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ+ , let n = gre_name elt, n `elem` exps ]+ in M.fromList $ map (second $ parseWarning dflags gre) ws'++moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)+moduleWarning _ _ NoWarnings = Nothing+moduleWarning _ _ (WarnSome _) = Nothing+moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w++parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name+parseWarning dflags gre w = force $ case w of+ DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)+ WarningTxt msg -> format "Warning: " (concatFS msg)+ where+ format x xs = DocWarning . DocParagraph . DocAppend (DocString x)+ . processDocString dflags gre $ HsDocString xs+++-------------------------------------------------------------------------------+-- Doc options+--+-- Haddock options that are embedded in the source file+-------------------------------------------------------------------------------+++mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]+mkDocOpts mbOpts flags mdl = do+ opts <- case mbOpts of+ Just opts -> case words $ replace ',' ' ' opts of+ [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []+ xs -> liftM catMaybes (mapM parseOption xs)+ Nothing -> return []+ hm <- if Flag_HideModule (moduleString mdl) `elem` flags+ then return $ OptHide : opts+ else return opts+ if Flag_ShowExtensions (moduleString mdl) `elem` flags+ then return $ OptShowExtensions : hm+ else return hm+++parseOption :: String -> ErrMsgM (Maybe DocOption)+parseOption "hide" = return (Just OptHide)+parseOption "prune" = return (Just OptPrune)+parseOption "ignore-exports" = return (Just OptIgnoreExports)+parseOption "not-home" = return (Just OptNotHome)+parseOption "show-extensions" = return (Just OptShowExtensions)+parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing+++--------------------------------------------------------------------------------+-- Maps+--------------------------------------------------------------------------------+++type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)++-- | Create 'Maps' by looping through the declarations. For each declaration,+-- find its names, its subordinates, and its doc strings. Process doc strings+-- into 'Doc's.+mkMaps :: DynFlags+ -> GlobalRdrEnv+ -> [Name]+ -> [(LHsDecl Name, [HsDocString])]+ -> Maps+mkMaps dflags gre instances decls =+ let (a, b, c, d) = unzip4 $ map mappings decls+ in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)+ where+ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b+ f = M.fromListWith (<>) . concat++ f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)+ f' = M.fromListWith docAppend . concat++ mappings :: (LHsDecl Name, [HsDocString])+ -> ( [(Name, Doc Name)]+ , [(Name, Map Int (Doc Name))]+ , [(Name, [Name])]+ , [(Name, [LHsDecl Name])]+ )+ mappings (ldecl, docStrs) =+ let L l decl = ldecl+ declDoc :: [HsDocString] -> Map Int HsDocString+ -> (Maybe (Doc Name), Map Int (Doc Name))+ declDoc strs m =+ let doc' = processDocStrings dflags gre strs+ m' = M.map (processDocStringParas dflags gre) m+ in (doc', m')+ (doc, args) = declDoc docStrs (typeDocs decl)+ subs :: [(Name, [HsDocString], Map Int HsDocString)]+ subs = subordinates instanceMap decl+ (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs+ ns = names l decl+ subNs = [ n | (n, _, _) <- subs ]+ dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]+ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs+ sm = [ (n, subNs) | n <- ns ]+ cm = [ (n, [ldecl]) | n <- ns ++ subNs ]+ in seqList ns `seq`+ seqList subNs `seq`+ doc `seq`+ seqList subDocs `seq`+ seqList subArgs `seq`+ (dm, am, sm, cm)++ instanceMap :: Map SrcSpan Name+ instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]++ names :: SrcSpan -> HsDecl Name -> [Name]+ names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].+ where loc = case d of+ TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs+ _ -> getInstLoc d+ names _ decl = getMainDeclBinder decl++-- Note [2]:+------------+-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.+-- That should work for normal user-written instances (from looking at GHC+-- sources). We can assume that commented instances are user-written.+-- This lets us relate Names (from ClsInsts) to comments (associated+-- with InstDecls).+++--------------------------------------------------------------------------------+-- Declarations+--------------------------------------------------------------------------------+++-- | Get all subordinate declarations inside a declaration, and their docs.+subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]+subordinates instMap decl = case decl of+ InstD (ClsInstD d) -> do+ DataFamInstDecl { dfid_tycon = L l _+ , dfid_defn = def } <- unLoc <$> cid_datafam_insts d+ [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def++ InstD (DataFamInstD d) -> dataSubs (dfid_defn d)+ TyClD d | isClassDecl d -> classSubs d+ | isDataDecl d -> dataSubs (tcdDataDefn d)+ _ -> []+ where+ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd+ , name <- getMainDeclBinder d, not (isValD d)+ ]+ dataSubs dd = constrs ++ fields+ where+ cons = map unL $ (dd_cons dd)+ constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)+ | c <- cons ]+ fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)+ | RecCon flds <- map con_details cons+ , ConDeclField n _ doc <- flds ]++-- | Extract function argument docs from inside types.+typeDocs :: HsDecl Name -> Map Int HsDocString+typeDocs d =+ let docs = go 0 in+ case d of+ SigD (TypeSig _ ty) -> docs (unLoc ty)+ SigD (PatSynSig _ arg_tys ty req prov) ->+ let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]+ in F.foldMap (docs . unLoc) allTys+ ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)+ TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)+ _ -> M.empty+ where+ go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)+ go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty+ go n (HsFunTy _ ty) = go (n+1) (unLoc ty)+ go n (HsDocTy _ (L _ doc)) = M.singleton n doc+ go _ _ = M.empty+++-- | All the sub declarations of a class (that we handle), ordered by+-- source location, with documentation attached if it exists.+classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls+ where+ decls = docs ++ defs ++ sigs ++ ats+ docs = mkDecls tcdDocs DocD class_+#if MIN_VERSION_ghc(7,8,3)+ defs = mkDecls (bagToList . tcdMeths) ValD class_+#else+ defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_+#endif+ sigs = mkDecls tcdSigs SigD class_+ ats = mkDecls tcdATs (TyClD . FamDecl) class_+++-- | The top-level declarations of a module that we care about,+-- ordered by source location, with documentation attached if it exists.+topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup++-- | Extract a map of fixity declarations only+mkFixMap :: HsGroup Name -> FixMap+mkFixMap group_ = M.fromList [ (n,f)+ | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]+++-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.+ungroup :: HsGroup Name -> [LHsDecl Name]+ungroup group_ =+ mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ +++ mkDecls hs_derivds DerivD group_ +++ mkDecls hs_defds DefD group_ +++ mkDecls hs_fords ForD group_ +++ mkDecls hs_docs DocD group_ +++ mkDecls hs_instds InstD group_ +++ mkDecls (typesigs . hs_valds) SigD group_ +++#if MIN_VERSION_ghc(7,8,3)+ mkDecls (valbinds . hs_valds) ValD group_+#else+ mkDecls (map snd . valbinds . hs_valds) ValD group_+#endif+ where+ typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs+ typesigs _ = error "expected ValBindsOut"++ valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds+ valbinds _ = error "expected ValBindsOut"+++-- | Take a field of declarations from a data structure and create HsDecls+-- using the given constructor+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]+mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]+++-- | Sort by source location+sortByLoc :: [Located a] -> [Located a]+sortByLoc = sortBy (comparing getLoc)+++--------------------------------------------------------------------------------+-- Filtering of declarations+--+-- We filter out declarations that we don't intend to handle later.+--------------------------------------------------------------------------------+++-- | Filter out declarations that we don't handle in Haddock+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]+filterDecls = filter (isHandled . unL . fst)+ where+ isHandled (ForD (ForeignImport {})) = True+ isHandled (TyClD {}) = True+ isHandled (InstD {}) = True+ isHandled (SigD d) = isVanillaLSig (reL d)+ isHandled (ValD _) = True+ -- we keep doc declarations to be able to get at named docs+ isHandled (DocD _) = True+ isHandled _ = False+++-- | Go through all class declarations and filter their sub-declarations+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]+filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x+ | x@(L loc d, doc) <- decls ]+ where+ filterClass (TyClD c) =+ TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }+ filterClass _ = error "expected TyClD"+++--------------------------------------------------------------------------------+-- Collect docs+--+-- To be able to attach the right Haddock comment to the right declaration,+-- we sort the declarations by their SrcLoc and "collect" the docs for each+-- declaration.+--------------------------------------------------------------------------------+++-- | Collect docs and attach them to the right declarations.+collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]+collectDocs = go Nothing []+ where+ go Nothing _ [] = []+ go (Just prev) docs [] = finished prev docs []+ go prev docs (L _ (DocD (DocCommentNext str)) : ds)+ | Nothing <- prev = go Nothing (str:docs) ds+ | Just decl <- prev = finished decl docs (go Nothing [str] ds)+ go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds+ go Nothing docs (d:ds) = go (Just d) docs ds+ go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)++ finished decl docs rest = (decl, reverse docs) : rest+++-- | Build the list of items that will become the documentation, from the+-- export list. At this point, the list of ExportItems is in terms of+-- original names.+--+-- We create the export items even if the module is hidden, since they+-- might be useful when creating the export items for other modules.+mkExportItems+ :: IfaceMap+ -> Module -- this module+ -> WarningMap+ -> GlobalRdrEnv+ -> [Name] -- exported names (orig)+ -> [LHsDecl Name]+ -> Maps+ -> FixMap+ -> [SrcSpan] -- splice locations+ -> Maybe [IE Name]+ -> InstIfaceMap+ -> DynFlags+ -> ErrMsgGhc [ExportItem Name]+mkExportItems+ modMap thisMod warnings gre exportedNames decls+ maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =+ case optExports of+ Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls+ Just exports -> liftM concat $ mapM lookupExport exports+ where+ lookupExport (IEVar x) = declWith x+ lookupExport (IEThingAbs t) = declWith t+ lookupExport (IEThingAll t) = declWith t+ lookupExport (IEThingWith t _) = declWith t+ lookupExport (IEModuleContents m) =+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices+ lookupExport (IEGroup lev docStr) = return $+ return . ExportGroup lev "" $ processDocString dflags gre docStr++ lookupExport (IEDoc docStr) = return $+ return . ExportDoc $ processDocStringParas dflags gre docStr++ lookupExport (IEDocNamed str) = liftErrMsg $+ findNamedDoc str [ unL d | d <- decls ] >>= return . \case+ Nothing -> []+ Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc++ declWith :: Name -> ErrMsgGhc [ ExportItem Name ]+ declWith t =+ case findDecl t of+ ([L l (ValD _)], (doc, _)) -> do+ -- Top-level binding without type signature+ export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap+ return [export]+ (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->+ let declNames = getMainDeclBinder (unL decl)+ in case () of+ _+ -- temp hack: we filter out separately exported ATs, since we haven't decided how+ -- to handle them yet. We should really give an warning message also, and filter the+ -- name out in mkVisibleNames...+ | t `elem` declATs (unL decl) -> return []++ -- We should not show a subordinate by itself if any of its+ -- parents is also exported. See note [1].+ | t `notElem` declNames,+ Just p <- find isExported (parents t $ unL decl) ->+ do liftErrMsg $ tell [+ "Warning: " ++ moduleString thisMod ++ ": " +++ pretty dflags (nameOccName t) ++ " is exported separately but " +++ "will be documented under " ++ pretty dflags (nameOccName p) +++ ". Consider exporting it together with its parent(s)" +++ " for code clarity." ]+ return []++ -- normal case+ | otherwise -> case decl of+ -- A single signature might refer to many names, but we+ -- create an export item for a single name only. So we+ -- modify the signature to contain only that single name.+ L loc (SigD sig) ->+ -- fromJust is safe since we already checked in guards+ -- that 't' is a name declared in this declaration.+ let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig+ in return [ mkExportDecl t newDecl docs_ ]++ L loc (TyClD cl@ClassDecl{}) -> do+ mdef <- liftGhcToErrMsgGhc $ minimalDef t+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef+ return [ mkExportDecl t+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]++ _ -> return [ mkExportDecl t decl docs_ ]++ -- Declaration from another package+ ([], _) -> do+ mayDecl <- hiDecl dflags t+ case mayDecl of+ Nothing -> return [ ExportNoDecl t [] ]+ Just decl ->+ -- We try to get the subs and docs+ -- from the installed .haddock file for that package.+ case M.lookup (nameModule t) instIfaceMap of+ Nothing -> do+ liftErrMsg $ tell+ ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]+ let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]+ return [ mkExportDecl t decl (noDocForDecl, subs_) ]+ Just iface ->+ return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]++ _ -> return []+++ mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name+ mkExportDecl name decl (doc, subs) = decl'+ where+ decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False+ mdl = nameModule name+ subs' = filter (isExported . fst) subs+ sub_names = map fst subs'+ fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]+++ isExported = (`elem` exportedNames)+++ findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))+ findDecl n+ | m == thisMod, Just ds <- M.lookup n declMap =+ (ds, lookupDocs n warnings docMap argMap subMap)+ | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =+ (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))+ | otherwise = ([], (noDocForDecl, []))+ where+ m = nameModule n+++hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))+hiDecl dflags t = do+ mayTyThing <- liftGhcToErrMsgGhc $ lookupName t+ case mayTyThing of+ Nothing -> do+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]+ return Nothing+ Just x -> return (Just (tyThingToLHsDecl x))+++hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)+hiValExportItem dflags name doc splice fixity = do+ mayDecl <- hiDecl dflags name+ case mayDecl of+ Nothing -> return (ExportNoDecl name [])+ Just decl -> return (ExportDecl decl doc [] [] fixities splice)+ where+ fixities = case fixity of+ Just f -> [(name, f)]+ Nothing -> []+++-- | Lookup docs for a declaration from maps.+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])+lookupDocs n warnings docMap argMap subMap =+ let lookupArgDoc x = M.findWithDefault M.empty x argMap in+ let doc = (lookupDoc n, lookupArgDoc n) in+ let subs = M.findWithDefault [] n subMap in+ let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in+ (doc, subDocs)+ where+ lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)+++-- | Return all export items produced by an exported module. That is, we're+-- interested in the exports produced by \"module B\" in such a scenario:+--+-- > module A (module B) where+-- > import B (...) hiding (...)+--+-- There are three different cases to consider:+--+-- 1) B is hidden, in which case we return all its exports that are in scope in A.+-- 2) B is visible, but not all its exports are in scope in A, in which case we+-- only return those that are.+-- 3) B is visible and all its exports are in scope, in which case we return+-- a single 'ExportModule' item.+moduleExports :: Module -- ^ Module A+ -> ModuleName -- ^ The real name of B, the exported module+ -> DynFlags -- ^ The flags used when typechecking A+ -> WarningMap+ -> GlobalRdrEnv -- ^ The renaming environment used for A+ -> [Name] -- ^ All the exports of A+ -> [LHsDecl Name] -- ^ All the declarations in A+ -> IfaceMap -- ^ Already created interfaces+ -> InstIfaceMap -- ^ Interfaces in other packages+ -> Maps+ -> FixMap+ -> [SrcSpan] -- ^ Locations of all TH splices+ -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices+ | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls+ | otherwise =+ case M.lookup m ifaceMap of+ Just iface+ | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)+ | otherwise -> return [ ExportModule m ]++ Nothing -> -- We have to try to find it in the installed interfaces+ -- (external packages).+ case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of+ Just iface -> return [ ExportModule (instMod iface) ]+ Nothing -> do+ liftErrMsg $+ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " +++ "documentation for exported module: " ++ pretty dflags expMod]+ return []+ where+ m = mkModule packageId expMod+ packageId = modulePackageId thisMod+++-- Note [1]:+------------+-- It is unnecessary to document a subordinate by itself at the top level if+-- any of its parents is also documented. Furthermore, if the subordinate is a+-- record field or a class method, documenting it under its parent+-- indicates its special status.+--+-- A user might expect that it should show up separately, so we issue a+-- warning. It's a fine opportunity to also tell the user she might want to+-- export the subordinate through the parent export item for clarity.+--+-- The code removes top-level subordinates also when the parent is exported+-- through a 'module' export. I think that is fine.+--+-- (For more information, see Trac #69)+++fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]+ -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =+ liftM catMaybes $ mapM mkExportItem (expandSig decls)+ where+ -- A type signature can have multiple names, like:+ -- foo, bar :: Types..+ --+ -- We go through the list of declarations and expand type signatures, so+ -- that every type signature has exactly one name!+ expandSig :: [LHsDecl name] -> [LHsDecl name]+ expandSig = foldr f []+ where+ f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names+ f x xs = x : xs++ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))+ mkExportItem (L _ (DocD (DocGroup lev docStr))) = do+ return . Just . ExportGroup lev "" $ processDocString dflags gre docStr+ mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do+ return . Just . ExportDoc $ processDocStringParas dflags gre docStr+ mkExportItem (L l (ValD d))+ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =+ -- Top-level binding without type signature.+ let (doc, _) = lookupDocs name warnings docMap argMap subMap in+ fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)+ | otherwise = return Nothing+ mkExportItem decl@(L l (InstD d))+ | Just name <- M.lookup (getInstLoc d) instMap =+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in+ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))+ mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do+ mdef <- liftGhcToErrMsgGhc $ minimalDef name+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef+ expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name+ mkExportItem decl@(L l d)+ | name:_ <- getMainDeclBinder d = expDecl decl l name+ | otherwise = return Nothing++ fixities name subs = [ (n,f) | n <- name : map fst subs+ , Just f <- [M.lookup n fixMap] ]++ expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))+ where (doc, subs) = lookupDocs name warnings docMap argMap subMap+++-- | Sometimes the declaration we want to export is not the "main" declaration:+-- it might be an individual record selector or a class method. In these+-- cases we have to extract the required declaration (and somehow cobble+-- together a type signature for it...).+extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name+extractDecl name mdl decl+ | name `elem` getMainDeclBinder (unLoc decl) = decl+ | otherwise =+ case unLoc decl of+ TyClD d@ClassDecl {} ->+ let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,+ isVanillaLSig sig ] -- TODO: document fixity+ in case matches of+ [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)+ L pos sig = extractClassDecl n tyvar_names s0+ in L pos (SigD sig)+ _ -> error "internal: extractDecl (ClassDecl)"+ TyClD d@DataDecl {} ->+ let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)+ in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))+ InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n+ , dfid_pats = HsWB { hswb_cts = tys }+ , dfid_defn = defn }) ->+ SigD <$> extractRecSel name mdl n tys (dd_cons defn)+ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->+ let matches = [ d | L _ d <- insts+ , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)+ , ConDeclField { cd_fld_name = L _ n } <- rec+ , n == name+ ]+ in case matches of+ [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)+ _ -> error "internal: extractDecl (ClsInstD)"+ _ -> error "internal: extractDecl"+ where+ getTyVars = hsLTyVarLocNames . tyClDeclTyVars+++toTypeNoLoc :: Located Name -> LHsType Name+toTypeNoLoc = noLoc . HsTyVar . unLoc+++extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name+extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of+ L _ (HsForAllTy expl tvs (L _ preds) ty) ->+ L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))+ where+ lctxt = noLoc . ctxt+ ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds+extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"+++extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]+ -> LSig Name+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"++extractRecSel nm mdl t tvs (L _ con : rest) =+ case con_details con of+ RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))+ _ -> extractRecSel nm mdl t tvs rest+ where+ matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]+ data_ty+ | ResTyGADT ty <- con_res con = ty+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs+++-- | Keep export items with docs.+pruneExportItems :: [ExportItem Name] -> [ExportItem Name]+pruneExportItems = filter hasDoc+ where+ hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d+ hasDoc _ = True+++mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]+mkVisibleNames (_, _, _, _, instMap) exports opts+ | OptHide `elem` opts = []+ | otherwise = let ns = concatMap exportName exports+ in seqList ns `seq` ns+ where+ exportName e@ExportDecl {} = name ++ subs+ where subs = map fst (expItemSubDocs e)+ name = case unLoc $ expItemDecl e of+ InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap+ decl -> getMainDeclBinder decl+ exportName ExportNoDecl {} = [] -- we don't count these as visible, since+ -- we don't want links to go to them.+ exportName _ = []++seqList :: [a] -> ()+seqList [] = ()+seqList (x : xs) = x `seq` seqList xs++-- | Find a stand-alone documentation comment by its name.+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)+findNamedDoc name = search+ where+ search [] = do+ tell ["Cannot find documentation for: $" ++ name]+ return Nothing+ search (DocD (DocCommentNamed name' doc) : rest)+ | name == name' = return (Just doc)+ | otherwise = search rest+ search (_other_decl : rest) = search rest
+ src/Haddock/Interface/LexParseRn.hs view
@@ -0,0 +1,146 @@+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE BangPatterns #-}+ -----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.LexParseRn+-- Copyright : (c) Isaac Dupree 2009,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Interface.LexParseRn+ ( processDocString+ , processDocStringParas+ , processDocStrings+ , processModuleHeader+ ) where++import Control.Applicative+import Data.IntSet (toList)+import Data.List+import Documentation.Haddock.Doc (docConcat)+import DynFlags (ExtensionFlag(..), languageExtensions)+import FastString+import GHC+import Haddock.Interface.ParseModuleHeader+import Haddock.Parser+import Haddock.Types+import Name+import Outputable (showPpr)+import RdrName++processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)+processDocStrings dflags gre strs =+ case docConcat $ map (processDocStringParas dflags gre) strs of+ DocEmpty -> Nothing+ x -> Just x+++processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name+processDocStringParas = process parseParas+++processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name+processDocString = process parseString++process :: (DynFlags -> String -> Doc RdrName)+ -> DynFlags+ -> GlobalRdrEnv+ -> HsDocString+ -> Doc Name+process parse dflags gre (HsDocString fs) =+ rename dflags gre $ parse dflags (unpackFS fs)+++processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString+ -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))+processModuleHeader dflags gre safety mayStr = do+ (hmi, doc) <-+ case mayStr of+ Nothing -> return failure+ Just (L _ (HsDocString fs)) -> do+ let str = unpackFS fs+ (hmi, doc) = parseModuleHeader dflags str+ !descr = rename dflags gre <$> hmi_description hmi+ hmi' = hmi { hmi_description = descr }+ doc' = rename dflags gre doc+ return (hmi', Just doc')++ let flags :: [ExtensionFlag]+ -- We remove the flags implied by the language setting and we display the language instead+ flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)+ return (hmi { hmi_safety = Just $ showPpr dflags safety+ , hmi_language = language dflags+ , hmi_extensions = flags+ } , doc)+ where+ failure = (emptyHaddockModInfo, Nothing)+++rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> 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+ let choices = dataTcOccs' x+ let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices+ case names of+ [] ->+ case choices of+ [] -> DocMonospaced (DocString (showPpr dflags x))+ [a] -> outOfScope dflags a+ a:b:_ | isRdrTc a -> outOfScope dflags a+ | otherwise -> outOfScope dflags b+ [a] -> DocIdentifier a+ a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b+ -- If an id can refer to multiple things, we give precedence to type+ -- constructors.++ DocWarning doc -> DocWarning (rn doc)+ DocEmphasis doc -> DocEmphasis (rn doc)+ DocBold doc -> DocBold (rn doc)+ DocMonospaced doc -> DocMonospaced (rn doc)+ DocUnorderedList docs -> DocUnorderedList (map rn docs)+ DocOrderedList docs -> DocOrderedList (map rn docs)+ DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]+ DocCodeBlock doc -> DocCodeBlock (rn doc)+ DocIdentifierUnchecked x -> DocIdentifierUnchecked x+ DocModule str -> DocModule str+ DocHyperlink l -> DocHyperlink l+ DocPic str -> DocPic str+ DocAName str -> DocAName str+ DocProperty p -> DocProperty p+ DocExamples e -> DocExamples e+ DocEmpty -> DocEmpty+ DocString str -> DocString str+ DocHeader (Header l t) -> DocHeader $ Header l (rn t)++dataTcOccs' :: RdrName -> [RdrName]+-- If the input is a data constructor, return both it and a type+-- constructor. This is useful when we aren't sure which we are+-- looking at.+--+-- We use this definition instead of the GHC's to provide proper linking to+-- functions accross modules. See ticket #253 on Haddock Trac.+dataTcOccs' rdr_name+ | isDataOcc occ = [rdr_name, rdr_name_tc]+ | otherwise = [rdr_name]+ where+ occ = rdrNameOcc rdr_name+ rdr_name_tc = setRdrNameSpace rdr_name tcName+++outOfScope :: DynFlags -> RdrName -> Doc a+outOfScope dflags x =+ case x of+ Unqual occ -> monospaced occ+ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)+ Orig _ occ -> monospaced occ+ Exact name -> monospaced name -- Shouldn't happen since x is out of scope+ where+ monospaced a = DocMonospaced (DocString (showPpr dflags a))
+ src/Haddock/Interface/ParseModuleHeader.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_GHC -Wwarn #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.ParseModuleHeader+-- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where++import Control.Applicative ((<$>))+import Control.Monad (mplus)+import Data.Char+import DynFlags+import Haddock.Parser+import Haddock.Types+import RdrName++-- -----------------------------------------------------------------------------+-- Parsing module headers++-- NB. The headers must be given in the order Module, Description,+-- Copyright, License, Maintainer, Stability, Portability, except that+-- any or all may be omitted.+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)+parseModuleHeader dflags 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+ (maintainerOpt,str6) = getKey "Maintainer" str5+ (stabilityOpt,str7) = getKey "Stability" str6+ (portabilityOpt,str8) = getKey "Portability" str7++ in (HaddockModInfo {+ hmi_description = parseString dflags <$> descriptionOpt,+ hmi_copyright = copyrightOpt,+ hmi_license = licenseOpt `mplus` licenceOpt,+ hmi_maintainer = maintainerOpt,+ hmi_stability = stabilityOpt,+ hmi_portability = portabilityOpt,+ hmi_safety = Nothing,+ hmi_language = Nothing, -- set in LexParseRn+ hmi_extensions = [] -- also set in LexParseRn+ }, parseParas dflags str8)++-- | This function is how we read keys.+--+-- all fields in the header are optional and have the form+--+-- [spaces1][field name][spaces] ":"+-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*+-- where each [spaces2] should have [spaces1] as a prefix.+--+-- Thus for the key "Description",+--+-- > Description : this is a+-- > rather long+-- >+-- > description+-- >+-- > The module comment starts here+--+-- 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 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
+ src/Haddock/Interface/Rename.hs view
@@ -0,0 +1,506 @@+----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.Rename+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Interface.Rename (renameInterface) where+++import Data.Traversable (traverse)++import Haddock.GhcUtils+import Haddock.Types++import Bag (emptyBag)+import GHC hiding (NoLink)+import Name++import Control.Applicative+import Control.Monad hiding (mapM)+import Data.List+import qualified Data.Map as Map hiding ( Map )+import Data.Traversable (mapM)+import Prelude hiding (mapM)+++renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface+renameInterface dflags renamingEnv warnings iface =++ -- first create the local env, where every name exported by this module+ -- is mapped to itself, and everything else comes from the global renaming+ -- env+ let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)+ where fn env name = Map.insert name (ifaceMod iface) env++ -- rename names in the exported declarations to point to things that+ -- are closer to, or maybe even exported by, the current module.+ (renamedExportItems, missingNames1)+ = runRnFM localEnv (renameExportItems (ifaceExportItems iface))++ (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))++ (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))++ (finalModuleDoc, missingNames4)+ = runRnFM localEnv (renameDocumentation (ifaceDoc iface))++ -- combine the missing names and filter out the built-ins, which would+ -- otherwise allways be missing.+ missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much+ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)++ -- filter out certain built in type constructors using their string+ -- representation. TODO: use the Name constants from the GHC API.+-- strings = filter (`notElem` ["()", "[]", "(->)"])+-- (map pretty missingNames)+ strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames++ in do+ -- report things that we couldn't link to. Only do this for non-hidden+ -- modules.+ unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $+ tell ["Warning: " ++ moduleString (ifaceMod iface) +++ ": could not find link destinations for:\n"+++ unwords (" " : strings) ]++ return $ iface { ifaceRnDoc = finalModuleDoc,+ ifaceRnDocMap = rnDocMap,+ ifaceRnArgMap = rnArgMap,+ ifaceRnExportItems = renamedExportItems }+++--------------------------------------------------------------------------------+-- Monad for renaming+--+-- The monad does two things for us: it passes around the environment for+-- renaming, and it returns a list of names which couldn't be found in+-- the environment.+--------------------------------------------------------------------------------+++newtype RnM a =+ RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function+ -> (a,[Name])+ }++instance Monad RnM where+ (>>=) = thenRn+ return = returnRn++instance Functor RnM where+ fmap f x = do a <- x; return (f a)++instance Applicative RnM where+ pure = return+ (<*>) = ap++returnRn :: a -> RnM a+returnRn a = RnM (const (a,[]))+thenRn :: RnM a -> (a -> RnM b) -> RnM b+m `thenRn` k = RnM (\lkp -> case unRn m lkp of+ (a,out1) -> case unRn (k a) lkp of+ (b,out2) -> (b,out1++out2))++getLookupRn :: RnM (Name -> (Bool, DocName))+getLookupRn = RnM (\lkp -> (lkp,[]))++outRn :: Name -> RnM ()+outRn name = RnM (const ((),[name]))++lookupRn :: Name -> RnM DocName+lookupRn name = do+ lkp <- getLookupRn+ case lkp name of+ (False,maps_to) -> do outRn name; return maps_to+ (True, maps_to) -> return maps_to+++runRnFM :: LinkEnv -> RnM a -> (a,[Name])+runRnFM env rn = unRn rn lkp+ where+ lkp n = case Map.lookup n env of+ Nothing -> (False, Undocumented n)+ Just mdl -> (True, Documented n mdl)+++--------------------------------------------------------------------------------+-- Renaming+--------------------------------------------------------------------------------+++rename :: Name -> RnM DocName+rename = lookupRn+++renameL :: Located Name -> RnM (Located DocName)+renameL = mapM rename+++renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]+renameExportItems = mapM renameExportItem+++renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)+renameDocForDecl (doc, fnArgsDoc) =+ (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc+++renameDocumentation :: Documentation Name -> RnM (Documentation DocName)+renameDocumentation (Documentation mDoc mWarning) =+ Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning+++renameLDocHsSyn :: LHsDocString -> RnM LHsDocString+renameLDocHsSyn = return+++renameDoc :: Doc Name -> RnM (Doc DocName)+renameDoc = traverse rename+++renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)+renameFnArgsDoc = mapM renameDoc+++renameLType :: LHsType Name -> RnM (LHsType DocName)+renameLType = mapM renameType++renameLKind :: LHsKind Name -> RnM (LHsKind DocName)+renameLKind = renameLType++renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))+renameMaybeLKind = traverse renameLKind++renameType :: HsType Name -> RnM (HsType DocName)+renameType t = case t of+ HsForAllTy expl tyvars lcontext ltype -> do+ tyvars' <- renameLTyVarBndrs tyvars+ lcontext' <- renameLContext lcontext+ ltype' <- renameLType ltype+ return (HsForAllTy expl tyvars' lcontext' ltype')++ HsTyVar n -> return . HsTyVar =<< rename n+ HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype++ HsAppTy a b -> do+ a' <- renameLType a+ b' <- renameLType b+ return (HsAppTy a' b')++ HsFunTy a b -> do+ a' <- renameLType a+ b' <- renameLType b+ return (HsFunTy a' b')++ HsListTy ty -> return . HsListTy =<< renameLType ty+ HsPArrTy ty -> return . HsPArrTy =<< renameLType ty+ HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)+ HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)++ HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts++ HsOpTy a (w, L loc op) b -> do+ op' <- rename op+ a' <- renameLType a+ b' <- renameLType b+ return (HsOpTy a' (w, L loc op') b')++ HsParTy ty -> return . HsParTy =<< renameLType ty++ HsKindSig ty k -> do+ ty' <- renameLType ty+ k' <- renameLKind k+ return (HsKindSig ty' k')++ HsDocTy ty doc -> do+ ty' <- renameLType ty+ doc' <- renameLDocHsSyn doc+ return (HsDocTy ty' doc')++ HsTyLit x -> return (HsTyLit x)++ HsWrapTy a b -> HsWrapTy a <$> renameType b+ HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a+ HsCoreTy a -> pure (HsCoreTy a)+ HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b+ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b+ HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a+ HsSpliceTy _ _ -> error "renameType: HsSpliceTy"++renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)+renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c++renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)+renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })+ = do { tvs' <- mapM renameLTyVarBndr tvs+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }+ -- This is rather bogus, but I'm not sure what else to do++renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)+renameLTyVarBndr (L loc (UserTyVar n))+ = do { n' <- rename n+ ; return (L loc (UserTyVar n')) }+renameLTyVarBndr (L loc (KindedTyVar n kind))+ = do { n' <- rename n+ ; kind' <- renameLKind kind+ ; return (L loc (KindedTyVar n' kind')) }++renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])+renameLContext (L loc context) = do+ context' <- mapM renameLType context+ return (L loc context')+++renameInstHead :: InstHead Name -> RnM (InstHead DocName)+renameInstHead (className, k, types, rest) = do+ className' <- rename className+ k' <- mapM renameType k+ types' <- mapM renameType types+ rest' <- case rest of+ ClassInst cs -> ClassInst <$> mapM renameType cs+ TypeInst ts -> TypeInst <$> traverse renameType ts+ DataInst dd -> DataInst <$> renameTyClD dd+ return (className', k', types', rest')+++renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)+renameLDecl (L loc d) = return . L loc =<< renameDecl d+++renameDecl :: HsDecl Name -> RnM (HsDecl DocName)+renameDecl decl = case decl of+ TyClD d -> do+ d' <- renameTyClD d+ return (TyClD d')+ SigD s -> do+ s' <- renameSig s+ return (SigD s')+ ForD d -> do+ d' <- renameForD d+ return (ForD d')+ InstD d -> do+ d' <- renameInstD d+ return (InstD d')+ _ -> error "renameDecl"++renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))+renameLThing fn (L loc x) = return . L loc =<< fn x++renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)+renameTyClD d = case d of+ ForeignType lname b -> do+ lname' <- renameL lname+ return (ForeignType lname' b)++-- TyFamily flav lname ltyvars kind tckind -> do+ FamDecl { tcdFam = decl } -> do+ decl' <- renameFamilyDecl decl+ return (FamDecl { tcdFam = decl' })++ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do+ lname' <- renameL lname+ tyvars' <- renameLTyVarBndrs tyvars+ rhs' <- renameLType rhs+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })++ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do+ lname' <- renameL lname+ tyvars' <- renameLTyVarBndrs tyvars+ defn' <- renameDataDefn defn+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })++ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars+ , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do+ lcontext' <- renameLContext lcontext+ lname' <- renameL lname+ ltyvars' <- renameLTyVarBndrs ltyvars+ lfundeps' <- mapM renameLFunDep lfundeps+ lsigs' <- mapM renameLSig lsigs+ ats' <- mapM (renameLThing renameFamilyDecl) ats+ at_defs' <- mapM (mapM renameTyFamInstD) at_defs+ -- we don't need the default methods or the already collected doc entities+ return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'+ , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })++ where+ renameLFunDep (L loc (xs, ys)) = do+ xs' <- mapM rename xs+ ys' <- mapM rename ys+ return (L loc (xs', ys'))++ renameLSig (L loc sig) = return . L loc =<< renameSig sig++renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)+renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname+ , fdTyVars = ltyvars, fdKindSig = tckind }) = do+ info' <- renameFamilyInfo info+ lname' <- renameL lname+ ltyvars' <- renameLTyVarBndrs ltyvars+ tckind' <- renameMaybeLKind tckind+ return (FamilyDecl { fdInfo = info', fdLName = lname'+ , fdTyVars = ltyvars', fdKindSig = tckind' })++renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)+renameFamilyInfo DataFamily = return DataFamily+renameFamilyInfo OpenTypeFamily = return OpenTypeFamily+renameFamilyInfo (ClosedTypeFamily eqns)+ = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns+ ; return $ ClosedTypeFamily eqns' }++renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)+renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType+ , dd_kindSig = k, dd_cons = cons }) = do+ lcontext' <- renameLContext lcontext+ k' <- renameMaybeLKind k+ cons' <- mapM (mapM renameCon) cons+ -- I don't think we need the derivings, so we return Nothing+ return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType+ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })++renameCon :: ConDecl Name -> RnM (ConDecl DocName)+renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars+ , con_cxt = lcontext, con_details = details+ , con_res = restype, con_doc = mbldoc }) = do+ lname' <- renameL lname+ ltyvars' <- renameLTyVarBndrs ltyvars+ lcontext' <- renameLContext lcontext+ details' <- renameDetails details+ restype' <- renameResType restype+ mbldoc' <- mapM renameLDocHsSyn mbldoc+ return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'+ , con_details = details', con_res = restype', con_doc = mbldoc' })+ where+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields+ renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps+ renameDetails (InfixCon a b) = do+ a' <- renameLType a+ b' <- renameLType b+ return (InfixCon a' b')++ renameResType (ResTyH98) = return ResTyH98+ renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t+++renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)+renameConDeclFieldField (ConDeclField name t doc) = do+ name' <- renameL name+ t' <- renameLType t+ doc' <- mapM renameLDocHsSyn doc+ return (ConDeclField name' t' doc')+++renameSig :: Sig Name -> RnM (Sig DocName)+renameSig sig = case sig of+ TypeSig lnames ltype -> do+ lnames' <- mapM renameL lnames+ ltype' <- renameLType ltype+ return (TypeSig lnames' ltype')+ PatSynSig lname args ltype lreq lprov -> do+ lname' <- renameL lname+ args' <- case args of+ PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs+ InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright+ ltype' <- renameLType ltype+ lreq' <- renameLContext lreq+ lprov' <- renameLContext lprov+ return $ PatSynSig lname' args' ltype' lreq' lprov'+ FixSig (FixitySig lname fixity) -> do+ lname' <- renameL lname+ return $ FixSig (FixitySig lname' fixity)+ MinimalSig s -> MinimalSig <$> traverse renameL s+ -- we have filtered out all other kinds of signatures in Interface.Create+ _ -> error "expected TypeSig"+++renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)+renameForD (ForeignImport lname ltype co x) = do+ lname' <- renameL lname+ ltype' <- renameLType ltype+ return (ForeignImport lname' ltype' co x)+renameForD (ForeignExport lname ltype co x) = do+ lname' <- renameL lname+ ltype' <- renameLType ltype+ return (ForeignExport lname' ltype' co x)+++renameInstD :: InstDecl Name -> RnM (InstDecl DocName)+renameInstD (ClsInstD { cid_inst = d }) = do+ d' <- renameClsInstD d+ return (ClsInstD { cid_inst = d' })+renameInstD (TyFamInstD { tfid_inst = d }) = do+ d' <- renameTyFamInstD d+ return (TyFamInstD { tfid_inst = d' })+renameInstD (DataFamInstD { dfid_inst = d }) = do+ d' <- renameDataFamInstD d+ return (DataFamInstD { dfid_inst = d' })++renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)+renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do+ ltype' <- renameLType ltype+ lATs' <- mapM (mapM renameTyFamInstD) lATs+ lADTs' <- mapM (mapM renameDataFamInstD) lADTs+ return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []+ , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })+++renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)+renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })+ = do { eqn' <- renameLThing renameTyFamInstEqn eqn+ ; return (TyFamInstDecl { tfid_eqn = eqn'+ , tfid_fvs = placeHolderNames }) }++renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)+renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })+ = do { tc' <- renameL tc+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)+ ; rhs' <- renameLType rhs+ ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }+ , tfie_rhs = rhs' }) }++renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })+ = do { tc' <- renameL tc+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)+ ; defn' <- renameDataDefn defn+ ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }+ , dfid_defn = defn', dfid_fvs = placeHolderNames }) }++renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)+renameExportItem item = case item of+ ExportModule mdl -> return (ExportModule mdl)+ ExportGroup lev id_ doc -> do+ doc' <- renameDoc doc+ return (ExportGroup lev id_ doc')+ ExportDecl decl doc subs instances fixities splice -> do+ decl' <- renameLDecl decl+ doc' <- renameDocForDecl doc+ subs' <- mapM renameSub subs+ instances' <- forM instances $ \(inst, idoc) -> do+ inst' <- renameInstHead inst+ idoc' <- mapM renameDoc idoc+ return (inst', idoc')+ fixities' <- forM fixities $ \(name, fixity) -> do+ name' <- lookupRn name+ return (name', fixity)+ return (ExportDecl decl' doc' subs' instances' fixities' splice)+ ExportNoDecl x subs -> do+ x' <- lookupRn x+ subs' <- mapM lookupRn subs+ return (ExportNoDecl x' subs')+ ExportDoc doc -> do+ doc' <- renameDoc doc+ return (ExportDoc doc')+++renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)+renameSub (n,doc) = do+ n' <- rename n+ doc' <- renameDocForDecl doc+ return (n', doc')
+ src/Haddock/InterfaceFile.hs view
@@ -0,0 +1,636 @@+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.InterfaceFile+-- Copyright : (c) David Waern 2006-2009,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Reading and writing the .haddock interface file+-----------------------------------------------------------------------------+module Haddock.InterfaceFile (+ InterfaceFile(..), ifPackageId,+ readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,+ writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility+) where+++import Haddock.Types+import Haddock.Utils hiding (out)++import Control.Monad+import Data.Array+import Data.Functor ((<$>))+import Data.IORef+import Data.List+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Word++import BinIface (getSymtabName, getDictFastString)+import Binary+import FastMutInt+import FastString+import GHC hiding (NoLink)+import GhcMonad (withSession)+import HscTypes+import IfaceEnv+import Name+import UniqFM+import UniqSupply+import Unique+++data InterfaceFile = InterfaceFile {+ ifLinkEnv :: LinkEnv,+ ifInstalledIfaces :: [InstalledInterface]+}+++ifPackageId :: InterfaceFile -> PackageId+ifPackageId if_ =+ case ifInstalledIfaces if_ of+ [] -> error "empty InterfaceFile"+ iface:_ -> modulePackageId $ instMod iface+++binaryInterfaceMagic :: Word32+binaryInterfaceMagic = 0xD0Cface+++-- IMPORTANT: Since datatypes in the GHC API might change between major+-- versions, and because we store GHC datatypes in our interface files, we need+-- to make sure we version our interface files accordingly.+--+-- If you change the interface file format or adapt Haddock to work with a new+-- major version of GHC (so that the format changes indirectly) *you* need to+-- follow these steps:+--+-- (1) increase `binaryInterfaceVersion`+--+-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]+--+binaryInterfaceVersion :: Word16+#if __GLASGOW_HASKELL__ == 708+binaryInterfaceVersion = 25++binaryInterfaceVersionCompatibility :: [Word16]+binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]+#else+#error Unsupported GHC version+#endif+++initBinMemSize :: Int+initBinMemSize = 1024*1024+++writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()+writeInterfaceFile filename iface = do+ bh0 <- openBinMem initBinMemSize+ put_ bh0 binaryInterfaceMagic+ put_ bh0 binaryInterfaceVersion++ -- remember where the dictionary pointer will go+ dict_p_p <- tellBin bh0+ put_ bh0 dict_p_p++ -- remember where the symbol table pointer will go+ symtab_p_p <- tellBin bh0+ put_ bh0 symtab_p_p++ -- Make some intial state+ symtab_next <- newFastMutInt+ writeFastMutInt symtab_next 0+ symtab_map <- newIORef emptyUFM+ let bin_symtab = BinSymbolTable {+ bin_symtab_next = symtab_next,+ bin_symtab_map = symtab_map }+ dict_next_ref <- newFastMutInt+ writeFastMutInt dict_next_ref 0+ dict_map_ref <- newIORef emptyUFM+ let bin_dict = BinDictionary {+ bin_dict_next = dict_next_ref,+ bin_dict_map = dict_map_ref }++ -- put the main thing+ let bh = setUserData bh0 $ newWriteState (putName bin_symtab)+ (putFastString bin_dict)+ put_ bh iface++ -- write the symtab pointer at the front of the file+ symtab_p <- tellBin bh+ putAt bh symtab_p_p symtab_p+ seekBin bh symtab_p++ -- write the symbol table itself+ symtab_next' <- readFastMutInt symtab_next+ symtab_map' <- readIORef symtab_map+ putSymbolTable bh symtab_next' symtab_map'++ -- write the dictionary pointer at the fornt of the file+ dict_p <- tellBin bh+ putAt bh dict_p_p dict_p+ seekBin bh dict_p++ -- write the dictionary itself+ dict_next <- readFastMutInt dict_next_ref+ dict_map <- readIORef dict_map_ref+ putDictionary bh dict_next dict_map++ -- and send the result to the file+ writeBinMem bh filename+ return ()+++type NameCacheAccessor m = (m NameCache, NameCache -> m ())+++nameCacheFromGhc :: NameCacheAccessor Ghc+nameCacheFromGhc = ( read_from_session , write_to_session )+ where+ read_from_session = do+ ref <- withSession (return . hsc_NC)+ liftIO $ readIORef ref+ write_to_session nc' = do+ ref <- withSession (return . hsc_NC)+ liftIO $ writeIORef ref nc'+++freshNameCache :: NameCacheAccessor IO+freshNameCache = ( create_fresh_nc , \_ -> return () )+ where+ create_fresh_nc = do+ u <- mkSplitUniqSupply 'a' -- ??+ return (initNameCache u [])+++-- | Read a Haddock (@.haddock@) interface file. Return either an+-- 'InterfaceFile' or an error message.+--+-- This function can be called in two ways. Within a GHC session it will+-- update the use and update the session's name cache. Outside a GHC session+-- a new empty name cache is used. The function is therefore generic in the+-- monad being used. The exact monad is whichever monad the first+-- argument, the getter and setter of the name cache, requires.+--+readInterfaceFile :: forall m.+ MonadIO m+ => NameCacheAccessor m+ -> FilePath+ -> m (Either String InterfaceFile)+readInterfaceFile (get_name_cache, set_name_cache) filename = do+ bh0 <- liftIO $ readBinMem filename++ magic <- liftIO $ get bh0+ version <- liftIO $ get bh0++ case () of+ _ | magic /= binaryInterfaceMagic -> return . Left $+ "Magic number mismatch: couldn't load interface file: " ++ filename+ | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $+ "Interface file is of wrong version: " ++ filename+ | otherwise -> with_name_cache $ \update_nc -> do++ dict <- get_dictionary bh0++ -- read the symbol table so we are capable of reading the actual data+ bh1 <- do+ let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+ (getDictFastString dict)+ symtab <- update_nc (get_symbol_table bh1)+ return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)+ (getDictFastString dict)++ -- load the actual data+ iface <- liftIO $ get bh1+ return (Right iface)+ where+ with_name_cache :: forall a.+ ((forall n b. MonadIO n+ => (NameCache -> n (NameCache, b))+ -> n b)+ -> m a)+ -> m a+ with_name_cache act = do+ nc_var <- get_name_cache >>= (liftIO . newIORef)+ x <- act $ \f -> do+ nc <- liftIO $ readIORef nc_var+ (nc', x) <- f nc+ liftIO $ writeIORef nc_var nc'+ return x+ liftIO (readIORef nc_var) >>= set_name_cache+ return x++ get_dictionary bin_handle = liftIO $ do+ dict_p <- get bin_handle+ data_p <- tellBin bin_handle+ seekBin bin_handle dict_p+ dict <- getDictionary bin_handle+ seekBin bin_handle data_p+ return dict++ get_symbol_table bh1 theNC = liftIO $ do+ symtab_p <- get bh1+ data_p' <- tellBin bh1+ seekBin bh1 symtab_p+ (nc', symtab) <- getSymbolTable bh1 theNC+ seekBin bh1 data_p'+ return (nc', symtab)+++-------------------------------------------------------------------------------+-- * Symbol table+-------------------------------------------------------------------------------+++putName :: BinSymbolTable -> BinHandle -> Name -> IO ()+putName BinSymbolTable{+ bin_symtab_map = symtab_map_ref,+ bin_symtab_next = symtab_next } bh name+ = do+ symtab_map <- readIORef symtab_map_ref+ case lookupUFM symtab_map name of+ Just (off,_) -> put_ bh (fromIntegral off :: Word32)+ Nothing -> do+ off <- readFastMutInt symtab_next+ writeFastMutInt symtab_next (off+1)+ writeIORef symtab_map_ref+ $! addToUFM symtab_map name (off,name)+ put_ bh (fromIntegral off :: Word32)+++data BinSymbolTable = BinSymbolTable {+ bin_symtab_next :: !FastMutInt, -- The next index to use+ bin_symtab_map :: !(IORef (UniqFM (Int,Name)))+ -- indexed by Name+ }+++putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()+putFastString BinDictionary { bin_dict_next = j_r,+ bin_dict_map = out_r} bh f+ = do+ out <- readIORef out_r+ let unique = getUnique f+ case lookupUFM out unique of+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)+ Nothing -> do+ j <- readFastMutInt j_r+ put_ bh (fromIntegral j :: Word32)+ writeFastMutInt j_r (j + 1)+ writeIORef out_r $! addToUFM out unique (j, f)+++data BinDictionary = BinDictionary {+ bin_dict_next :: !FastMutInt, -- The next index to use+ bin_dict_map :: !(IORef (UniqFM (Int,FastString)))+ -- indexed by FastString+ }+++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()+putSymbolTable bh next_off symtab = do+ put_ bh next_off+ let names = elems (array (0,next_off-1) (eltsUFM symtab))+ mapM_ (\n -> serialiseName bh n symtab) names+++getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)+getSymbolTable bh namecache = do+ sz <- get bh+ od_names <- replicateM sz (get bh)+ let arr = listArray (0,sz-1) names+ (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names+ return (namecache', arr)+++type OnDiskName = (PackageId, ModuleName, OccName)+++fromOnDiskName+ :: Array Int Name+ -> NameCache+ -> OnDiskName+ -> (NameCache, Name)+fromOnDiskName _ nc (pid, mod_name, occ) =+ let+ modu = mkModule pid mod_name+ cache = nsNames nc+ in+ case lookupOrigNameCache cache modu occ of+ Just name -> (nc, name)+ Nothing ->+ let+ us = nsUniqs nc+ u = uniqFromSupply us+ name = mkExternalName u modu occ noSrcSpan+ new_cache = extendNameCache cache modu occ name+ in+ case splitUniqSupply us of { (us',_) ->+ ( nc{ nsUniqs = us', nsNames = new_cache }, name )+ }+++serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()+serialiseName bh name _ = do+ let modu = nameModule name+ put_ bh (modulePackageId modu, moduleName modu, nameOccName name)+++-------------------------------------------------------------------------------+-- * GhcBinary instances+-------------------------------------------------------------------------------+++instance (Ord k, Binary k, Binary v) => Binary (Map k v) where+ put_ bh m = put_ bh (Map.toList m)+ get bh = fmap (Map.fromList) (get bh)+++instance Binary InterfaceFile where+ put_ bh (InterfaceFile env ifaces) = do+ put_ bh env+ put_ bh ifaces++ get bh = do+ env <- get bh+ ifaces <- get bh+ return (InterfaceFile env ifaces)+++instance Binary InstalledInterface where+ put_ bh (InstalledInterface modu info docMap argMap+ exps visExps opts subMap fixMap) = do+ put_ bh modu+ put_ bh info+ put_ bh docMap+ put_ bh argMap+ put_ bh exps+ put_ bh visExps+ put_ bh opts+ put_ bh subMap+ put_ bh fixMap++ get bh = do+ modu <- get bh+ info <- get bh+ docMap <- get bh+ argMap <- get bh+ exps <- get bh+ visExps <- get bh+ opts <- get bh+ subMap <- get bh+ fixMap <- get bh++ return (InstalledInterface modu info docMap argMap+ exps visExps opts subMap fixMap)+++instance Binary DocOption where+ put_ bh OptHide = do+ putByte bh 0+ put_ bh OptPrune = do+ putByte bh 1+ put_ bh OptIgnoreExports = do+ putByte bh 2+ put_ bh OptNotHome = do+ putByte bh 3+ put_ bh OptShowExtensions = do+ putByte bh 4+ get bh = do+ h <- getByte bh+ case h of+ 0 -> do+ return OptHide+ 1 -> do+ return OptPrune+ 2 -> do+ return OptIgnoreExports+ 3 -> do+ return OptNotHome+ 4 -> do+ return OptShowExtensions+ _ -> fail "invalid binary data found"+++instance Binary Example where+ put_ bh (Example expression result) = do+ put_ bh expression+ put_ bh result+ get bh = do+ expression <- get bh+ result <- get bh+ return (Example expression result)++instance Binary Hyperlink where+ put_ bh (Hyperlink url label) = do+ put_ bh url+ put_ bh label+ get bh = do+ url <- get bh+ label <- get bh+ return (Hyperlink url label)++instance Binary Picture where+ put_ bh (Picture uri title) = do+ put_ bh uri+ put_ bh title+ get bh = do+ uri <- get bh+ title <- get bh+ return (Picture uri title)++instance Binary a => Binary (Header a) where+ put_ bh (Header l t) = do+ put_ bh l+ put_ bh t+ get bh = do+ l <- get bh+ t <- get bh+ return (Header l t)++{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance (Binary mod, Binary id) => Binary (DocH mod id) where+ put_ bh DocEmpty = do+ putByte bh 0+ put_ bh (DocAppend aa ab) = do+ putByte bh 1+ put_ bh aa+ put_ bh ab+ put_ bh (DocString ac) = do+ putByte bh 2+ put_ bh ac+ put_ bh (DocParagraph ad) = do+ putByte bh 3+ put_ bh ad+ put_ bh (DocIdentifier ae) = do+ putByte bh 4+ put_ bh ae+ put_ bh (DocModule af) = do+ putByte bh 5+ put_ bh af+ put_ bh (DocEmphasis ag) = do+ putByte bh 6+ put_ bh ag+ put_ bh (DocMonospaced ah) = do+ putByte bh 7+ put_ bh ah+ put_ bh (DocUnorderedList ai) = do+ putByte bh 8+ put_ bh ai+ put_ bh (DocOrderedList aj) = do+ putByte bh 9+ put_ bh aj+ put_ bh (DocDefList ak) = do+ putByte bh 10+ put_ bh ak+ put_ bh (DocCodeBlock al) = do+ putByte bh 11+ put_ bh al+ put_ bh (DocHyperlink am) = do+ putByte bh 12+ put_ bh am+ put_ bh (DocPic x) = do+ putByte bh 13+ put_ bh x+ put_ bh (DocAName an) = do+ putByte bh 14+ put_ bh an+ put_ bh (DocExamples ao) = do+ putByte bh 15+ put_ bh ao+ put_ bh (DocIdentifierUnchecked x) = do+ putByte bh 16+ put_ bh x+ put_ bh (DocWarning ag) = do+ putByte bh 17+ put_ bh ag+ put_ bh (DocProperty x) = do+ putByte bh 18+ put_ bh x+ put_ bh (DocBold x) = do+ putByte bh 19+ put_ bh x+ put_ bh (DocHeader aa) = do+ putByte bh 20+ put_ bh aa++ get bh = do+ h <- getByte bh+ case h of+ 0 -> do+ return DocEmpty+ 1 -> do+ aa <- get bh+ ab <- get bh+ return (DocAppend aa ab)+ 2 -> do+ ac <- get bh+ return (DocString ac)+ 3 -> do+ ad <- get bh+ return (DocParagraph ad)+ 4 -> do+ ae <- get bh+ return (DocIdentifier ae)+ 5 -> do+ af <- get bh+ return (DocModule af)+ 6 -> do+ ag <- get bh+ return (DocEmphasis ag)+ 7 -> do+ ah <- get bh+ return (DocMonospaced ah)+ 8 -> do+ ai <- get bh+ return (DocUnorderedList ai)+ 9 -> do+ aj <- get bh+ return (DocOrderedList aj)+ 10 -> do+ ak <- get bh+ return (DocDefList ak)+ 11 -> do+ al <- get bh+ return (DocCodeBlock al)+ 12 -> do+ am <- get bh+ return (DocHyperlink am)+ 13 -> do+ x <- get bh+ return (DocPic x)+ 14 -> do+ an <- get bh+ return (DocAName an)+ 15 -> do+ ao <- get bh+ return (DocExamples ao)+ 16 -> do+ x <- get bh+ return (DocIdentifierUnchecked x)+ 17 -> do+ ag <- get bh+ return (DocWarning ag)+ 18 -> do+ x <- get bh+ return (DocProperty x)+ 19 -> do+ x <- get bh+ return (DocBold x)+ 20 -> do+ aa <- get bh+ return (DocHeader aa)+ _ -> error "invalid binary data found in the interface file"+++instance Binary name => Binary (HaddockModInfo name) where+ put_ bh hmi = do+ put_ bh (hmi_description hmi)+ put_ bh (hmi_copyright hmi)+ put_ bh (hmi_license hmi)+ put_ bh (hmi_maintainer hmi)+ put_ bh (hmi_stability hmi)+ put_ bh (hmi_portability hmi)+ put_ bh (hmi_safety hmi)+ put_ bh (fromEnum <$> hmi_language hmi)+ put_ bh (map fromEnum $ hmi_extensions hmi)++ get bh = do+ descr <- get bh+ copyr <- get bh+ licen <- get bh+ maint <- get bh+ stabi <- get bh+ porta <- get bh+ safet <- get bh+ langu <- fmap toEnum <$> get bh+ exten <- map toEnum <$> get bh+ return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten)++instance Binary DocName where+ put_ bh (Documented name modu) = do+ putByte bh 0+ put_ bh name+ put_ bh modu+ put_ bh (Undocumented name) = do+ putByte bh 1+ put_ bh name++ get bh = do+ h <- getByte bh+ case h of+ 0 -> do+ name <- get bh+ modu <- get bh+ return (Documented name modu)+ 1 -> do+ name <- get bh+ return (Undocumented name)+ _ -> error "get DocName: Bad h"
+ src/Haddock/ModuleTree.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.ModuleTree+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where+++import Haddock.Types ( Doc )++import GHC ( Name )+import Module ( Module, moduleNameString, moduleName, modulePackageId,+ packageIdString )+++data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree]+++mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree]+mkModuleTree showPkgs mods =+ foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ]+ where+ modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_))+ | otherwise = Nothing+ fn (mod_,pkg,short) = addToTrees mod_ pkg short+++addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree]+addToTrees [] _ _ ts = ts+addToTrees ss pkg short [] = mkSubTree ss pkg short+addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)+ | s1 > s2 = t : addToTrees (s1:ss) pkg short ts+ | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts+ | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts+ where+ this_pkg = if null ss then pkg else node_pkg+ this_short = if null ss then short else node_short+++mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree]+mkSubTree [] _ _ = []+mkSubTree [s] pkg short = [Node s True pkg short []]+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]+++splitModule :: Module -> [String]+splitModule mdl = split (moduleNameString (moduleName mdl))+ where split mod0 = case break (== '.') mod0 of+ (s1, '.':s2) -> s1 : split s2+ (s1, _) -> [s1]
+ src/Haddock/Options.hs view
@@ -0,0 +1,287 @@+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Options+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Definition of the command line interface of Haddock.+-----------------------------------------------------------------------------+module Haddock.Options (+ parseHaddockOpts,+ Flag(..),+ getUsage,+ optTitle,+ outputDir,+ optContentsUrl,+ optIndexUrl,+ optCssFile,+ sourceUrls,+ wikiUrls,+ optDumpInterfaceFile,+ optLaTeXStyle,+ qualification,+ verbosity,+ ghcFlags,+ readIfaceArgs+) where+++import Distribution.Verbosity+import Haddock.Utils+import Haddock.Types+import System.Console.GetOpt+import qualified Data.Char as Char+++data Flag+ = Flag_BuiltInThemes+ | Flag_CSS String+-- | Flag_DocBook+ | Flag_ReadInterface String+ | Flag_DumpInterface String+ | Flag_Heading String+ | Flag_Html+ | Flag_Hoogle+ | Flag_Lib String+ | Flag_OutputDir FilePath+ | Flag_Prologue FilePath+ | Flag_SourceBaseURL String+ | Flag_SourceModuleURL String+ | Flag_SourceEntityURL String+ | Flag_SourceLEntityURL String+ | Flag_WikiBaseURL String+ | Flag_WikiModuleURL String+ | Flag_WikiEntityURL String+ | Flag_LaTeX+ | Flag_LaTeXStyle String+ | Flag_Help+ | Flag_Verbosity String+ | Flag_Version+ | Flag_CompatibleInterfaceVersions+ | Flag_InterfaceVersion+ | Flag_UseContents String+ | Flag_GenContents+ | Flag_UseIndex String+ | Flag_GenIndex+ | Flag_IgnoreAllExports+ | Flag_HideModule String+ | Flag_ShowExtensions String+ | Flag_OptGhc String+ | Flag_GhcLibDir String+ | Flag_GhcVersion+ | Flag_PrintGhcPath+ | Flag_PrintGhcLibDir+ | Flag_NoWarnings+ | Flag_UseUnicode+ | Flag_NoTmpCompDir+ | Flag_Qualification String+ | Flag_PrettyHtml+ | Flag_PrintMissingDocs+ deriving (Eq)+++options :: Bool -> [OptDescr Flag]+options backwardsCompat =+ [+ Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR")+ "path to a GHC lib dir, to override the default path",+ Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR")+ "directory in which to put the output files",+ Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR")+ "location of Haddock's auxiliary files",+ Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")+ "read an interface from FILE",+ Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")+ "write the resulting interface to FILE",+-- Option ['S'] ["docbook"] (NoArg Flag_DocBook)+-- "output in DocBook XML",+ Option ['h'] ["html"] (NoArg Flag_Html)+ "output in HTML (XHTML 1.0)",+ Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering",+ Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",+ Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",+ Option [] ["hoogle"] (NoArg Flag_Hoogle)+ "output for Hoogle",+ Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL")+ "URL for a source code link on the contents\nand index pages",+ Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])+ (ReqArg Flag_SourceModuleURL "URL")+ "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",+ Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL")+ "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",+ Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")+ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",+ Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL")+ "URL for a comments link on the contents\nand index pages",+ Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL")+ "URL for a comments link for each module\n(using the %{MODULE} var)",+ Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL")+ "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",+ Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH")+ "the CSS file or theme directory to use for HTML output",+ Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes)+ "include all the built-in haddock themes",+ Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE")+ "file containing prologue text",+ Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")+ "page heading",+ Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")+ "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",+ Option ['?'] ["help"] (NoArg Flag_Help)+ "display this help and exit",+ Option ['V'] ["version"] (NoArg Flag_Version)+ "output version information and exit",+ Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions)+ "output compatible interface file versions and exit",+ Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)+ "output interface file version and exit",+ Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")+ "set verbosity level",+ Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")+ "use a separately-generated HTML contents page",+ Option [] ["gen-contents"] (NoArg Flag_GenContents)+ "generate an HTML contents from specified\ninterfaces",+ Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")+ "use a separately-generated HTML index",+ Option [] ["gen-index"] (NoArg Flag_GenIndex)+ "generate an HTML index from specified\ninterfaces",+ Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)+ "behave as if all modules have the\nignore-exports atribute",+ Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")+ "behave as if MODULE has the hide attribute",+ Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")+ "behave as if MODULE has the show-extensions attribute",+ Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")+ "option to be forwarded to GHC",+ Option [] ["ghc-version"] (NoArg Flag_GhcVersion)+ "output GHC version in numeric format",+ Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath)+ "output path to GHC binary",+ Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir)+ "output GHC lib dir",+ Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",+ Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)+ "do not re-direct compilation output to a temporary directory",+ Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)+ "generate html with newlines and indenting (for use with --html)",+ Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs)+ "print information about any undocumented entities"+ ]+++getUsage :: IO String+getUsage = do+ prog <- getProgramName+ return $ usageInfo (usageHeader prog) (options False)+ where+ usageHeader :: String -> String+ usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"+++parseHaddockOpts :: [String] -> IO ([Flag], [String])+parseHaddockOpts params =+ case getOpt Permute (options True) params of+ (flags, args, []) -> return (flags, args)+ (_, _, errors) -> do+ usage <- getUsage+ throwE (concat errors ++ usage)+++optTitle :: [Flag] -> Maybe String+optTitle flags =+ case [str | Flag_Heading str <- flags] of+ [] -> Nothing+ (t:_) -> Just t+++outputDir :: [Flag] -> FilePath+outputDir flags =+ case [ path | Flag_OutputDir path <- flags ] of+ [] -> "."+ paths -> last paths+++optContentsUrl :: [Flag] -> Maybe String+optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ]+++optIndexUrl :: [Flag] -> Maybe String+optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]+++optCssFile :: [Flag] -> Maybe FilePath+optCssFile flags = optLast [ str | Flag_CSS str <- flags ]+++sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)+sourceUrls flags =+ (optLast [str | Flag_SourceBaseURL str <- flags]+ ,optLast [str | Flag_SourceModuleURL str <- flags]+ ,optLast [str | Flag_SourceEntityURL str <- flags]+ ,optLast [str | Flag_SourceLEntityURL str <- flags])+++wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)+wikiUrls flags =+ (optLast [str | Flag_WikiBaseURL str <- flags]+ ,optLast [str | Flag_WikiModuleURL str <- flags]+ ,optLast [str | Flag_WikiEntityURL str <- flags])+++optDumpInterfaceFile :: [Flag] -> Maybe FilePath+optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]+++optLaTeXStyle :: [Flag] -> Maybe String+optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]+++qualification :: [Flag] -> Either String QualOption+qualification flags =+ case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of+ [] -> Right OptNoQual+ ["none"] -> Right OptNoQual+ ["full"] -> Right OptFullQual+ ["local"] -> Right OptLocalQual+ ["relative"] -> Right OptRelativeQual+ ["aliased"] -> Right OptAliasedQual+ [arg] -> Left $ "unknown qualification type " ++ show arg+ _:_ -> Left "qualification option given multiple times"+++verbosity :: [Flag] -> Verbosity+verbosity flags =+ case [ str | Flag_Verbosity str <- flags ] of+ [] -> normal+ x:_ -> case parseVerbosity x of+ Left e -> throwE e+ Right v -> v+++ghcFlags :: [Flag] -> [String]+ghcFlags flags = [ option | Flag_OptGhc option <- flags ]+++readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]+readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]+ where+ parseIfaceOption :: String -> (DocPaths, FilePath)+ parseIfaceOption str =+ case break (==',') str of+ (fpath, ',':rest) ->+ case break (==',') rest of+ (src, ',':file) -> ((fpath, Just src), file)+ (file, _) -> ((fpath, Nothing), file)+ (file, _) -> (("", Nothing), file)+++-- | Like 'listToMaybe' but returns the last element instead of the first.+optLast :: [a] -> Maybe a+optLast [] = Nothing+optLast xs = Just (last xs)
+ src/Haddock/Parser.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving+ , FlexibleInstances, UndecidableInstances+ , IncoherentInstances #-}+{-# LANGUAGE LambdaCase #-}+-- |+-- Module : Haddock.Parser+-- Copyright : (c) Mateusz Kowalczyk 2013,+-- Simon Hengel 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable++module Haddock.Parser ( parseParas+ , parseString+ , parseIdent+ ) where++import qualified Documentation.Haddock.Parser as P+import DynFlags (DynFlags)+import FastString (mkFastString)+import Documentation.Haddock.Types+import Lexer (mkPState, unP, ParseResult(POk))+import Parser (parseIdentifier)+import RdrName (RdrName)+import SrcLoc (mkRealSrcLoc, unLoc)+import StringBuffer (stringToStringBuffer)++parseParas :: DynFlags -> String -> DocH mod RdrName+parseParas d = P.overIdentifier (parseIdent d) . P.parseParas++parseString :: DynFlags -> String -> DocH mod RdrName+parseString d = P.overIdentifier (parseIdent d) . P.parseString++parseIdent :: DynFlags -> String -> Maybe RdrName+parseIdent dflags str0 =+ let buffer = stringToStringBuffer str0+ realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0+ pstate = mkPState dflags buffer realSrcLc+ in case unP parseIdentifier pstate of+ POk _ name -> Just (unLoc name)+ _ -> Nothing
+ src/Haddock/Types.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Types+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009,+-- Mateusz Kowalczyk 2013+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskellorg+-- Stability : experimental+-- Portability : portable+--+-- Types that are commonly used through-out Haddock. Some of the most+-- important types are defined here, like 'Interface' and 'DocName'.+-----------------------------------------------------------------------------+module Haddock.Types (+ module Haddock.Types+ , HsDocString, LHsDocString+ , Fixity(..)+ , module Documentation.Haddock.Types+ ) where++import Control.Exception+import Control.Arrow hiding ((<+>))+import Control.DeepSeq+import Data.Typeable+import Data.Map (Map)+import qualified Data.Map as Map+import Documentation.Haddock.Types+import BasicTypes (Fixity(..))+import GHC hiding (NoLink)+import DynFlags (ExtensionFlag, Language)+import OccName+import Outputable+import Control.Applicative (Applicative(..))+import Control.Monad (ap)++-----------------------------------------------------------------------------+-- * Convenient synonyms+-----------------------------------------------------------------------------+++type IfaceMap = Map Module Interface+type InstIfaceMap = Map Module InstalledInterface -- TODO: rename+type DocMap a = Map Name (Doc a)+type ArgMap a = Map Name (Map Int (Doc a))+type SubMap = Map Name [Name]+type DeclMap = Map Name [LHsDecl Name]+type InstMap = Map SrcSpan Name+type FixMap = Map Name Fixity+type SrcMap = Map PackageId FilePath+type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources+++-----------------------------------------------------------------------------+-- * Interface+-----------------------------------------------------------------------------+++-- | 'Interface' holds all information used to render a single Haddock page.+-- It represents the /interface/ of a module. The core business of Haddock+-- lies in creating this structure. Note that the record contains some fields+-- that are only used to create the final record, and that are not used by the+-- backends.+data Interface = Interface+ {+ -- | The module behind this interface.+ ifaceMod :: !Module++ -- | Original file name of the module.+ , ifaceOrigFilename :: !FilePath++ -- | Textual information about the module.+ , ifaceInfo :: !(HaddockModInfo Name)++ -- | Documentation header.+ , ifaceDoc :: !(Documentation Name)++ -- | Documentation header with cross-reference information.+ , ifaceRnDoc :: !(Documentation DocName)++ -- | Haddock options for this module (prune, ignore-exports, etc).+ , ifaceOptions :: ![DocOption]++ -- | Declarations originating from the module. Excludes declarations without+ -- names (instances and stand-alone documentation comments). Includes+ -- names of subordinate declarations mapped to their parent declarations.+ , ifaceDeclMap :: !(Map Name [LHsDecl Name])++ -- | Documentation of declarations originating from the module (including+ -- subordinates).+ , ifaceDocMap :: !(DocMap Name)+ , ifaceArgMap :: !(ArgMap Name)++ -- | Documentation of declarations originating from the module (including+ -- subordinates).+ , ifaceRnDocMap :: !(DocMap DocName)+ , ifaceRnArgMap :: !(ArgMap DocName)++ , ifaceSubMap :: !(Map Name [Name])+ , ifaceFixMap :: !(Map Name Fixity)++ , ifaceExportItems :: ![ExportItem Name]+ , ifaceRnExportItems :: ![ExportItem DocName]++ -- | All names exported by the module.+ , ifaceExports :: ![Name]++ -- | All \"visible\" names exported by the module.+ -- A visible name is a name that will show up in the documentation of the+ -- module.+ , ifaceVisibleExports :: ![Name]++ -- | Aliases of module imports as in @import A.B.C as C@.+ , ifaceModuleAliases :: !AliasMap++ -- | Instances exported by the module.+ , ifaceInstances :: ![ClsInst]+ , ifaceFamInstances :: ![FamInst]++ -- | The number of haddockable and haddocked items in the module, as a+ -- tuple. Haddockable items are the exports and the module itself.+ , ifaceHaddockCoverage :: !(Int, Int)++ -- | Warnings for things defined in this module.+ , ifaceWarningMap :: !WarningMap+ }++type WarningMap = DocMap Name+++-- | A subset of the fields of 'Interface' that we store in the interface+-- files.+data InstalledInterface = InstalledInterface+ {+ -- | The module represented by this interface.+ instMod :: Module++ -- | Textual information about the module.+ , instInfo :: HaddockModInfo Name++ -- | Documentation of declarations originating from the module (including+ -- subordinates).+ , instDocMap :: DocMap Name++ , instArgMap :: ArgMap Name++ -- | All names exported by this module.+ , instExports :: [Name]++ -- | All \"visible\" names exported by the module.+ -- A visible name is a name that will show up in the documentation of the+ -- module.+ , instVisibleExports :: [Name]++ -- | Haddock options for this module (prune, ignore-exports, etc).+ , instOptions :: [DocOption]++ , instSubMap :: Map Name [Name]+ , instFixMap :: Map Name Fixity+ }+++-- | Convert an 'Interface' to an 'InstalledInterface'+toInstalledIface :: Interface -> InstalledInterface+toInstalledIface interface = InstalledInterface+ { instMod = ifaceMod interface+ , instInfo = ifaceInfo interface+ , instDocMap = ifaceDocMap interface+ , instArgMap = ifaceArgMap interface+ , instExports = ifaceExports interface+ , instVisibleExports = ifaceVisibleExports interface+ , instOptions = ifaceOptions interface+ , instSubMap = ifaceSubMap interface+ , instFixMap = ifaceFixMap interface+ }+++-----------------------------------------------------------------------------+-- * Export items & declarations+-----------------------------------------------------------------------------+++data ExportItem name++ -- | An exported declaration.+ = ExportDecl+ {+ -- | A declaration.+ expItemDecl :: !(LHsDecl name)++ -- | Maybe a doc comment, and possibly docs for arguments (if this+ -- decl is a function or type-synonym).+ , expItemMbDoc :: !(DocForDecl name)++ -- | Subordinate names, possibly with documentation.+ , expItemSubDocs :: ![(name, DocForDecl name)]++ -- | Instances relevant to this declaration, possibly with+ -- documentation.+ , expItemInstances :: ![DocInstance name]++ -- | Fixity decls relevant to this declaration (including subordinates).+ , expItemFixities :: ![(name, Fixity)]++ -- | Whether the ExportItem is from a TH splice or not, for generating+ -- the appropriate type of Source link.+ , expItemSpliced :: !Bool+ }++ -- | An exported entity for which we have no documentation (perhaps because it+ -- resides in another package).+ | ExportNoDecl+ { expItemName :: !name++ -- | Subordinate names.+ , expItemSubs :: ![name]+ }++ -- | A section heading.+ | ExportGroup+ {+ -- | Section level (1, 2, 3, ...).+ expItemSectionLevel :: !Int++ -- | Section id (for hyperlinks).+ , expItemSectionId :: !String++ -- | Section heading text.+ , expItemSectionText :: !(Doc name)+ }++ -- | Some documentation.+ | ExportDoc !(Doc name)++ -- | A cross-reference to another module.+ | ExportModule !Module++data Documentation name = Documentation+ { documentationDoc :: Maybe (Doc name)+ , documentationWarning :: !(Maybe (Doc name))+ } deriving Functor+++-- | Arguments and result are indexed by Int, zero-based from the left,+-- because that's the easiest to use when recursing over types.+type FnArgsDoc name = Map Int (Doc name)+type DocForDecl name = (Documentation name, FnArgsDoc name)+++noDocForDecl :: DocForDecl name+noDocForDecl = (Documentation Nothing Nothing, Map.empty)+++unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name+unrenameDocForDecl (doc, fnArgsDoc) =+ (fmap getName doc, (fmap . fmap) getName fnArgsDoc)+++-----------------------------------------------------------------------------+-- * Cross-referencing+-----------------------------------------------------------------------------+++-- | Type of environment used to cross-reference identifiers in the syntax.+type LinkEnv = Map Name Module+++-- | Extends 'Name' with cross-reference information.+data DocName+ = Documented Name Module+ -- ^ This thing is part of the (existing or resulting)+ -- documentation. The 'Module' is the preferred place+ -- in the documentation to refer to.+ | Undocumented Name+ -- ^ This thing is not part of the (existing or resulting)+ -- documentation, as far as Haddock knows.+ deriving Eq+++instance NamedThing DocName where+ getName (Documented name _) = name+ getName (Undocumented name) = name+++-----------------------------------------------------------------------------+-- * Instances+-----------------------------------------------------------------------------++-- | The three types of instances+data InstType name+ = ClassInst [HsType name] -- ^ Context+ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)+ | DataInst (TyClDecl name) -- ^ Data constructors++instance OutputableBndr a => Outputable (InstType a) where+ ppr (ClassInst a) = text "ClassInst" <+> ppr a+ ppr (TypeInst a) = text "TypeInst" <+> ppr a+ ppr (DataInst a) = text "DataInst" <+> ppr a++-- | An instance head that may have documentation.+type DocInstance name = (InstHead name, Maybe (Doc name))++-- | The head of an instance. Consists of a class name, a list of kind+-- parameters, a list of type parameters and an instance type+type InstHead name = (name, [HsType name], [HsType name], InstType name)++-----------------------------------------------------------------------------+-- * Documentation comments+-----------------------------------------------------------------------------+++type LDoc id = Located (Doc id)++type Doc id = DocH (ModuleName, OccName) id++instance (NFData a, NFData mod)+ => NFData (DocH mod a) where+ rnf doc = case doc of+ DocEmpty -> ()+ DocAppend a b -> a `deepseq` b `deepseq` ()+ DocString a -> a `deepseq` ()+ DocParagraph a -> a `deepseq` ()+ DocIdentifier a -> a `deepseq` ()+ DocIdentifierUnchecked a -> a `deepseq` ()+ DocModule a -> a `deepseq` ()+ DocWarning a -> a `deepseq` ()+ DocEmphasis a -> a `deepseq` ()+ DocBold a -> a `deepseq` ()+ DocMonospaced a -> a `deepseq` ()+ DocUnorderedList a -> a `deepseq` ()+ DocOrderedList a -> a `deepseq` ()+ DocDefList a -> a `deepseq` ()+ DocCodeBlock a -> a `deepseq` ()+ DocHyperlink a -> a `deepseq` ()+ DocPic a -> a `deepseq` ()+ DocAName a -> a `deepseq` ()+ DocProperty a -> a `deepseq` ()+ DocExamples a -> a `deepseq` ()+ DocHeader a -> a `deepseq` ()+++instance NFData Name+instance NFData OccName+instance NFData ModuleName++instance NFData id => NFData (Header id) where+ rnf (Header a b) = a `deepseq` b `deepseq` ()++instance NFData Hyperlink where+ rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()++instance NFData Picture where+ rnf (Picture a b) = a `deepseq` b `deepseq` ()++instance NFData Example where+ rnf (Example a b) = a `deepseq` b `deepseq` ()+++exampleToString :: Example -> String+exampleToString (Example expression result) =+ ">>> " ++ expression ++ "\n" ++ unlines result+++data DocMarkup id a = Markup+ { markupEmpty :: a+ , markupString :: String -> a+ , markupParagraph :: a -> a+ , markupAppend :: a -> a -> a+ , markupIdentifier :: id -> a+ , markupIdentifierUnchecked :: (ModuleName, OccName) -> a+ , markupModule :: String -> a+ , markupWarning :: a -> a+ , markupEmphasis :: a -> a+ , markupBold :: a -> a+ , markupMonospaced :: a -> a+ , markupUnorderedList :: [a] -> a+ , markupOrderedList :: [a] -> a+ , markupDefList :: [(a,a)] -> a+ , markupCodeBlock :: a -> a+ , markupHyperlink :: Hyperlink -> a+ , markupAName :: String -> a+ , markupPic :: Picture -> a+ , markupProperty :: String -> a+ , markupExample :: [Example] -> a+ , markupHeader :: Header a -> a+ }+++data HaddockModInfo name = HaddockModInfo+ { hmi_description :: Maybe (Doc name)+ , hmi_copyright :: Maybe String+ , hmi_license :: Maybe String+ , hmi_maintainer :: Maybe String+ , hmi_stability :: Maybe String+ , hmi_portability :: Maybe String+ , hmi_safety :: Maybe String+ , hmi_language :: Maybe Language+ , hmi_extensions :: [ExtensionFlag]+ }+++emptyHaddockModInfo :: HaddockModInfo a+emptyHaddockModInfo = HaddockModInfo+ { hmi_description = Nothing+ , hmi_copyright = Nothing+ , hmi_license = Nothing+ , hmi_maintainer = Nothing+ , hmi_stability = Nothing+ , hmi_portability = Nothing+ , hmi_safety = Nothing+ , hmi_language = Nothing+ , hmi_extensions = []+ }+++-----------------------------------------------------------------------------+-- * Options+-----------------------------------------------------------------------------+++{-! for DocOption derive: Binary !-}+-- | Source-level options for controlling the documentation.+data DocOption+ = OptHide -- ^ This module should not appear in the docs.+ | OptPrune+ | OptIgnoreExports -- ^ Pretend everything is exported.+ | OptNotHome -- ^ Not the best place to get docs for things+ -- exported by this module.+ | OptShowExtensions -- ^ Render enabled extensions for this module.+ deriving (Eq, Show)+++-- | Option controlling how to qualify names+data QualOption+ = OptNoQual -- ^ Never qualify any names.+ | OptFullQual -- ^ Qualify all names fully.+ | OptLocalQual -- ^ Qualify all imported names fully.+ | OptRelativeQual -- ^ Like local, but strip module prefix+ -- from modules in the same hierarchy.+ | OptAliasedQual -- ^ Uses aliases of module names+ -- as suggested by module import renamings.+ -- However, we are unfortunately not able+ -- to maintain the original qualifications.+ -- Image a re-export of a whole module,+ -- how could the re-exported identifiers be qualified?++type AliasMap = Map Module ModuleName++data Qualification+ = NoQual+ | FullQual+ | LocalQual Module+ | RelativeQual Module+ | AliasedQual AliasMap Module+ -- ^ @Module@ contains the current module.+ -- This way we can distinguish imported and local identifiers.++makeContentsQual :: QualOption -> Qualification+makeContentsQual qual =+ case qual of+ OptNoQual -> NoQual+ _ -> FullQual++makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification+makeModuleQual qual aliases mdl =+ case qual of+ OptLocalQual -> LocalQual mdl+ OptRelativeQual -> RelativeQual mdl+ OptAliasedQual -> AliasedQual aliases mdl+ OptFullQual -> FullQual+ OptNoQual -> NoQual+++-----------------------------------------------------------------------------+-- * Error handling+-----------------------------------------------------------------------------+++-- A monad which collects error messages, locally defined to avoid a dep on mtl+++type ErrMsg = String+newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }+++instance Functor ErrMsgM where+ fmap f (Writer (a, msgs)) = Writer (f a, msgs)++instance Applicative ErrMsgM where+ pure = return+ (<*>) = ap++instance Monad ErrMsgM where+ return a = Writer (a, [])+ m >>= k = Writer $ let+ (a, w) = runWriter m+ (b, w') = runWriter (k a)+ in (b, w ++ w')+++tell :: [ErrMsg] -> ErrMsgM ()+tell w = Writer ((), w)+++-- Exceptions+++-- | Haddock's own exception type.+data HaddockException = HaddockException String deriving Typeable+++instance Show HaddockException where+ show (HaddockException str) = str+++throwE :: String -> a+instance Exception HaddockException+throwE str = throw (HaddockException str)+++-- In "Haddock.Interface.Create", we need to gather+-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,+-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the+-- transformed monad to be MonadIO.+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }+--instance MonadIO ErrMsgGhc where+-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO+--er, implementing GhcMonad involves annoying ExceptionMonad and+--WarnLogMonad classes, so don't bother.+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a+liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a+liftErrMsg = WriterGhc . return . runWriter+-- for now, use (liftErrMsg . tell) for this+--tell :: [ErrMsg] -> ErrMsgGhc ()+--tell msgs = WriterGhc $ return ( (), msgs )+++instance Functor ErrMsgGhc where+ fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)++instance Applicative ErrMsgGhc where+ pure = return+ (<*>) = ap++instance Monad ErrMsgGhc where+ return a = WriterGhc (return (a, []))+ m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->+ fmap (second (msgs1 ++)) (runWriterGhc (k a))
+ src/Haddock/Utils.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Utils+-- Copyright : (c) The University of Glasgow 2001-2002,+-- Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Utils (++ -- * Misc utilities+ restrictTo, emptyHsQTvs,+ toDescription, toInstalledDescription,++ -- * Filename utilities+ moduleHtmlFile, moduleHtmlFile',+ contentsHtmlFile, indexHtmlFile,+ frameIndexHtmlFile,+ moduleIndexFrameName, mainFrameName, synopsisFrameName,+ subIndexHtmlFile,+ jsFile, framesFile,++ -- * Anchor and URL utilities+ moduleNameUrl, moduleNameUrl', moduleUrl,+ nameAnchorId,+ makeAnchorId,++ -- * Miscellaneous utilities+ getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,++ -- * HTML cross reference mapping+ html_xrefs_ref, html_xrefs_ref',++ -- * Doc markup+ markup,+ idMarkup,++ -- * List utilities+ replace,+ spanWith,++ -- * MTL stuff+ MonadIO(..),++ -- * Logging+ parseVerbosity,+ out,++ -- * System tools+ getProcessID+ ) where+++import Haddock.Types+import Haddock.GhcUtils++import GHC+import Name++import Control.Monad ( liftM )+import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )+import Numeric ( showIntAtBase )+import Data.Map ( Map )+import qualified Data.Map as Map hiding ( Map )+import Data.IORef ( IORef, newIORef, readIORef )+import Data.List ( isSuffixOf )+import Data.Maybe ( mapMaybe )+import System.Environment ( getProgName )+import System.Exit+import System.IO ( hPutStr, stderr )+import System.IO.Unsafe ( unsafePerformIO )+import qualified System.FilePath.Posix as HtmlPath+import Distribution.Verbosity+import Distribution.ReadE++#ifndef mingw32_HOST_OS+import qualified System.Posix.Internals+#endif++import MonadUtils ( MonadIO(..) )+++--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------+++parseVerbosity :: String -> Either String Verbosity+parseVerbosity = runReadE flagToVerbosity+++-- | Print a message to stdout, if it is not too verbose+out :: MonadIO m+ => Verbosity -- ^ program verbosity+ -> Verbosity -- ^ message verbosity+ -> String -> m ()+out progVerbosity msgVerbosity msg+ | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg+ | otherwise = return ()+++--------------------------------------------------------------------------------+-- * Some Utilities+--------------------------------------------------------------------------------+++-- | Extract a module's short description.+toDescription :: Interface -> Maybe (Doc Name)+toDescription = hmi_description . ifaceInfo+++-- | Extract a module's short description.+toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)+toInstalledDescription = hmi_description . instInfo+++--------------------------------------------------------------------------------+-- * Making abstract declarations+--------------------------------------------------------------------------------+++restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name+restrictTo names (L loc decl) = L loc $ case decl of+ TyClD d | isDataDecl d ->+ TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })+ TyClD d | isClassDecl d ->+ TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),+ tcdATs = restrictATs names (tcdATs d) })+ _ -> decl++restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name+restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })+ | DataType <- new_or_data+ = defn { dd_cons = restrictCons names cons }+ | otherwise -- Newtype+ = case restrictCons names cons of+ [] -> defn { dd_ND = DataType, dd_cons = [] }+ [con] -> defn { dd_cons = [con] }+ _ -> error "Should not happen"++restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]+ where+ keep d | unLoc (con_name d) `elem` names =+ case con_details d of+ PrefixCon _ -> Just d+ RecCon fields+ | all field_avail fields -> Just d+ | otherwise -> Just (d { con_details = PrefixCon (field_types 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 (ConDeclField n _ _) = unLoc n `elem` names+ field_types flds = [ t | ConDeclField _ t _ <- flds ]++ keep _ = Nothing+++restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))+++restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]+restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]++emptyHsQTvs :: LHsTyVarBndrs Name+-- This function is here, rather than in HsTypes, because it *renamed*, but+-- does not necessarily have all the rigt kind variables. It is used+-- in Haddock just for printing, so it doesn't matter+emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }+++--------------------------------------------------------------------------------+-- * Filename mangling functions stolen from s main/DriverUtil.lhs.+--------------------------------------------------------------------------------+++baseName :: ModuleName -> FilePath+baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString+++moduleHtmlFile :: Module -> FilePath+moduleHtmlFile mdl =+ case Map.lookup mdl html_xrefs of+ Nothing -> baseName mdl' ++ ".html"+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"]+ where+ mdl' = moduleName mdl+++moduleHtmlFile' :: ModuleName -> FilePath+moduleHtmlFile' mdl =+ case Map.lookup mdl html_xrefs' of+ Nothing -> baseName mdl ++ ".html"+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]+++contentsHtmlFile, indexHtmlFile :: String+contentsHtmlFile = "index.html"+indexHtmlFile = "doc-index.html"+++-- | The name of the module index file to be displayed inside a frame.+-- Modules are display in full, but without indentation. Clicking opens in+-- the main window.+frameIndexHtmlFile :: String+frameIndexHtmlFile = "index-frames.html"+++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+ | otherwise = concatMap (show . ord) ls+++-------------------------------------------------------------------------------+-- * Anchor and URL utilities+--+-- NB: Anchor IDs, used as the destination of a link within a document must+-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's+-- various needs and compatibility constraints, means these IDs have to match:+-- [A-Za-z][A-Za-z0-9:_.-]*+-- Such IDs do not need to be escaped in any way when used as the fragment part+-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it+-- isn't clear if such fragment identifiers should, or should not be unescaped+-- before being matched with IDs in the target document.+-------------------------------------------------------------------------------+++moduleUrl :: Module -> String+moduleUrl = moduleHtmlFile+++moduleNameUrl :: Module -> OccName -> String+moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n+++moduleNameUrl' :: ModuleName -> OccName -> String+moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n+++nameAnchorId :: OccName -> String+nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)+ where prefix | isValOcc name = 'v'+ | otherwise = 't'+++-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is+-- identity preserving.+makeAnchorId :: String -> String+makeAnchorId [] = []+makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r+ where+ escape p c | p c = [c]+ | otherwise = '-' : show (ord c) ++ "-"+ isLegal ':' = True+ isLegal '_' = True+ isLegal '.' = True+ isLegal c = isAscii c && isAlphaNum c+ -- NB: '-' is legal in IDs, but we use it as the escape char+++-------------------------------------------------------------------------------+-- * Files we need to copy from our $libdir+-------------------------------------------------------------------------------+++jsFile, framesFile :: String+jsFile = "haddock-util.js"+framesFile = "frames.html"+++-------------------------------------------------------------------------------+-- * Misc.+-------------------------------------------------------------------------------+++getProgramName :: IO String+getProgramName = liftM (`withoutSuffix` ".bin") getProgName+ where str `withoutSuffix` suff+ | suff `isSuffixOf` str = take (length str - length suff) str+ | otherwise = str+++bye :: String -> IO a+bye s = putStr s >> exitSuccess+++die :: String -> IO a+die s = hPutStr stderr s >> exitWith (ExitFailure 1)+++dieMsg :: String -> IO a+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+++-- Following few functions are copy'n'pasted from Network.URI module+-- to avoid depending on the network lib, since doing so gives a+-- circular build dependency between haddock and network+-- (at least if you want to build network with haddock docs)+escapeURIChar :: (Char -> Bool) -> Char -> String+escapeURIChar p c+ | p c = [c]+ | otherwise = '%' : myShowHex (ord c) ""+ where+ myShowHex :: Int -> ShowS+ myShowHex n r = case showIntAtBase 16 toChrHex n r of+ [] -> "00"+ [a] -> ['0',a]+ cs -> cs+ toChrHex d+ | d < 10 = chr (ord '0' + fromIntegral d)+ | otherwise = chr (ord 'A' + fromIntegral (d - 10))+++escapeURIString :: (Char -> Bool) -> String -> String+escapeURIString = concatMap . escapeURIChar+++isUnreserved :: Char -> Bool+isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")+++isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool+isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')+isDigitChar c = c >= '0' && c <= '9'+isAlphaNumChar c = isAlphaChar c || isDigitChar c+++-----------------------------------------------------------------------------+-- * HTML cross references+--+-- For each module, we need to know where its HTML documentation lives+-- so that we can point hyperlinks to it. It is extremely+-- inconvenient to plumb this information to all the places that need+-- it (basically every function in HaddockHtml), and furthermore the+-- mapping is constant for any single run of Haddock. So for the time+-- being I'm going to use a write-once global variable.+-----------------------------------------------------------------------------+++{-# NOINLINE html_xrefs_ref #-}+html_xrefs_ref :: IORef (Map Module FilePath)+html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))+++{-# NOINLINE html_xrefs_ref' #-}+html_xrefs_ref' :: IORef (Map ModuleName FilePath)+html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map"))+++{-# NOINLINE html_xrefs #-}+html_xrefs :: Map Module FilePath+html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)+++{-# NOINLINE html_xrefs' #-}+html_xrefs' :: Map ModuleName FilePath+html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref')+++-----------------------------------------------------------------------------+-- * List utils+-----------------------------------------------------------------------------+++replace :: Eq a => a -> a -> [a] -> [a]+replace a b = map (\x -> if x == a then b else x)+++spanWith :: (a -> Maybe b) -> [a] -> ([b],[a])+spanWith _ [] = ([],[])+spanWith p xs@(a:as)+ | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)+ | otherwise = ([],xs)+++-----------------------------------------------------------------------------+-- * Put here temporarily+-----------------------------------------------------------------------------+++markup :: DocMarkup id a -> Doc id -> a+markup m DocEmpty = markupEmpty m+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)+markup m (DocString s) = markupString m s+markup m (DocParagraph d) = markupParagraph m (markup m d)+markup m (DocIdentifier x) = markupIdentifier m x+markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x+markup m (DocModule mod0) = markupModule m mod0+markup m (DocWarning d) = markupWarning m (markup m d)+markup m (DocEmphasis d) = markupEmphasis m (markup m d)+markup m (DocBold d) = markupBold m (markup m d)+markup m (DocMonospaced d) = markupMonospaced m (markup m d)+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)+markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)+markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)+markup m (DocHyperlink l) = markupHyperlink m l+markup m (DocAName ref) = markupAName m ref+markup m (DocPic img) = markupPic m img+markup m (DocProperty p) = markupProperty m p+markup m (DocExamples e) = markupExample m e+markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))+++markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)+markupPair m (a,b) = (markup m a, markup m b)+++-- | The identity markup+idMarkup :: DocMarkup a (Doc a)+idMarkup = Markup {+ markupEmpty = DocEmpty,+ markupString = DocString,+ markupParagraph = DocParagraph,+ markupAppend = DocAppend,+ markupIdentifier = DocIdentifier,+ markupIdentifierUnchecked = DocIdentifierUnchecked,+ markupModule = DocModule,+ markupWarning = DocWarning,+ markupEmphasis = DocEmphasis,+ markupBold = DocBold,+ markupMonospaced = DocMonospaced,+ markupUnorderedList = DocUnorderedList,+ markupOrderedList = DocOrderedList,+ markupDefList = DocDefList,+ markupCodeBlock = DocCodeBlock,+ markupHyperlink = DocHyperlink,+ markupAName = DocAName,+ markupPic = DocPic,+ markupProperty = DocProperty,+ markupExample = DocExamples,+ markupHeader = DocHeader+ }+++-----------------------------------------------------------------------------+-- * System tools+-----------------------------------------------------------------------------+++#ifdef mingw32_HOST_OS+foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows+#else+getProcessID :: IO Int+getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid+#endif
+ src/Haddock/Version.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Version+-- Copyright : (c) Simon Marlow 2003+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+-----------------------------------------------------------------------------+module Haddock.Version ( + projectName, projectVersion, projectUrl+) where++#ifdef IN_GHC_TREE+import Paths_haddock ( version )+#else+import Paths_haddock_api ( version )+#endif+import Data.Version ( showVersion )++projectName :: String+projectName = "Haddock"++projectUrl :: String+projectUrl = "http://www.haskell.org/haddock/"++projectVersion :: String+projectVersion = showVersion version