packages feed

haddock 2.14.3 → 2.15.0

raw patch · 207 files changed

+15683/−17685 lines, 207 filesdep +haddock-apidep −QuickCheckdep −ghc-pathsdep −haddockdep ~basedep ~ghcsetup-changed

Dependencies added: haddock-api

Dependencies removed: QuickCheck, ghc-paths, haddock, hspec

Dependency ranges changed: base, ghc

Files

CHANGES view
@@ -1,3 +1,33 @@+Changes in version 2.15.0++ * Always read in prologue files as UTF8 (#286 and Cabal #1721)++ * parser: don't wrap headers in DocParagraph (#307)++ * parser: don't mangle append order for nested lists (pandoc #1346)++ * parser: preserve list ordering in certain scenarios (#313)++ * parser: update the attoparsec version used internally giving slight+   parsing performance boost.++ * Move development to be against latest GHC release and not GHC HEAD.++ * Further split up the package to separate the executable from the+   library, necessary by things like GHCJS. We now have+   ‘haddock-library’ which are the parts that don't use GHC API,+   ‘haddock-api’ which are (some of) the parts that do use GHC API and+   ‘haddock’ which merely provides the executable.++ * Export few extra functions in the API.++ * Add compatibility with GHC 7.8.2.++ * Omit unnecessary ‘forall’s (#315 and #86)++ * Remove some files which were really old or did not belong in the+   repository in the first place.+ Changes in version 2.14.3   * Fix parsing of identifiers with ^ or ⋆ in them (#298)
LICENSE view
@@ -5,11 +5,11 @@  - 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
README view
@@ -6,13 +6,12 @@ documenting library interfaces, but it should be useful for any kind of Haskell code. -Like other systems ([1],[2]), Haddock lets you write documentation-annotations next to the definitions of functions and types in the-source code, in a syntax that is easy on the eye when writing the-source code (no heavyweight mark-up).  The documentation generated by-Haddock is fully hyperlinked - click on a type name in a type-signature to go straight to the definition, and documentation, for-that type.+Haddock lets you write documentation annotations next to the+definitions of functions and types in the source code, in a syntax+that is easy on the eye when writing the source code (no heavyweight+mark-up). The documentation generated by Haddock is fully hyperlinked+- click on a type name in a type signature to go straight to the+definition, and documentation, for that type.  Haddock understands Haskell's module system, so you can structure your code however you like without worrying that internal structure will be@@ -28,21 +27,11 @@ useful documentation from your source code.  Haddock can generate documentation in multiple formats; currently HTML-is implemented, and there is partial support for generating DocBook.-The generated HTML uses stylesheets, so you need a fairly up-to-date-browser to view it properly (Mozilla, Konqueror, Opera, and IE 6-should all be ok).+is implemented, and there is partial support for generating LaTeX and+Hoogle.  Full documentation can be found in the doc/ subdirectory, in DocBook format. -Please send questions and suggestions to:--David Waern <david.waern@gmail.com> or-Simon Marlow <simonmar@microsoft.com>---[1] IDoc - A No Frills Haskell Interface Documentation System-    http://www.cse.unsw.edu.au/~chak/haskell/idoc/--[2] HDoc http://www.fmi.uni-passau.de/~groessli/hdoc/+Please create issues when you have any problems and pull requests if+you have some code.
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
doc/haddock.xml view
@@ -21,2096 +21,2100 @@       <holder>Simon Marlow, David Waern</holder>     </copyright>     <abstract>-      <para>This document describes Haddock version 2.14.3, a Haskell-      documentation tool.</para>-    </abstract>-  </bookinfo>--  <!-- Table of contents -->-  <toc></toc>--  <chapter id="introduction">-    <title>Introduction</title>--    <para>This is Haddock, a tool for automatically generating-    documentation from annotated Haskell source code.  Haddock was-    designed with several goals in mind:</para>--    <itemizedlist>-      <listitem>-	<para>When documenting APIs, it is desirable to keep the-	documentation close to the actual interface or implementation-	of the API, preferably in the same file, to reduce the risk-	that the two become out of sync.  Haddock therefore lets you-	write the documentation for an entity (function, type, or-	class) next to the definition of the entity in the source-	code.</para>-      </listitem>-      <listitem>-	<para>There is a tremendous amount of useful API documentation-	that can be extracted from just the bare source code,-	including types of exported functions, definitions of data-	types and classes, and so on.  Haddock can therefore generate-	documentation from a set of straight Haskell 98 modules, and-	the documentation will contain precisely the interface that is-	available to a programmer using those modules.</para>-      </listitem>-      <listitem>-	<para>Documentation annotations in the source code should be-	easy on the eye when editing the source code itself, so as not-	to obscure the code and to make reading and writing-	documentation annotations easy.  The easier it is to write-	documentation, the more likely the programmer is to do it.-	Haddock therefore uses lightweight markup in its annotations,-	taking several ideas from <ulink-	url="http://www.cse.unsw.edu.au/~chak/haskell/idoc/">IDoc</ulink>.-	In fact, Haddock can understand IDoc-annotated source-	code.</para>-      </listitem>-      <listitem>-	<para>The documentation should not expose any of the structure-	of the implementation, or to put it another way, the-	implementer of the API should be free to structure the-	implementation however he or she wishes, without exposing any-	of that structure to the consumer.  In practical terms, this-	means that while an API may internally consist of several-	Haskell modules, we often only want to expose a single module-	to the user of the interface, where this single module just-	re-exports the relevant parts of the implementation-	modules.</para>--	<para>Haddock therefore understands the Haskell module system-	and can generate documentation which hides not only-	non-exported entities from the interface, but also the-	internal module structure of the interface.  A documentation-	annotation can still be placed next to the implementation, and-	it will be propagated to the external module in the generated-	documentation.</para>-      </listitem>-      <listitem>-	<para>Being able to move around the documentation by following-	hyperlinks is essential.  Documentation generated by Haddock-	is therefore littered with hyperlinks: every type and class-	name is a link to the corresponding definition, and-	user-written documentation annotations can contain identifiers-	which are linked automatically when the documentation is-	generated.</para>-      </listitem>-      <listitem>-	<para>We might want documentation in multiple formats - online-	and printed, for example.  Haddock comes with HTML, LaTeX,-  and Hoogle backends, and it is structured in such a way that adding new-	backends is straightforward.</para>-      </listitem>-    </itemizedlist>--    <section id="obtaining">-      <title>Obtaining Haddock</title>--      <para>Distributions (source &amp; binary) of Haddock can be obtained-      from its <ulink url="http://www.haskell.org/haddock/">web-      site</ulink>.</para>--      <para>Up-to-date sources can also be obtained from our public-      darcs repository.  The Haddock sources are at-      <literal>http://code.haskell.org/haddock</literal>.  See-      <ulink url="http://www.darcs.net/">darcs.net</ulink> for more-      information on the darcs version control utility.</para>-    </section>--    <section id="license">-      <title>License</title>--      <para>The following license covers this documentation, and the-      Haddock source code, except where otherwise indicated.</para>--      <blockquote>-	<para>Copyright 2002-2010, Simon Marlow.  All rights reserved.</para>--	<para>Redistribution and use in source and binary forms, with-        or without modification, are permitted provided that the-        following conditions are met:</para>--	<itemizedlist>-	  <listitem>-	    <para>Redistributions of source code must retain the above-            copyright notice, this list of conditions and the-            following disclaimer.</para>-	  </listitem>-	  <listitem>-	    <para>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.</para>-	  </listitem>-	</itemizedlist>--	<para>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.</para>-      </blockquote>-    </section>--    <section>-      <title>Contributors</title>-      <para>Haddock was originally written by Simon Marlow. Since it is an open source-      project, many people have contributed to its development over the years.-      Below is a list of contributors in alphabetical order that we hope is-      somewhat complete. If you think you are missing from this list, please contact-      us.-      </para>-      <itemizedlist>-	<listitem><simpara>Ashley Yakeley</simpara></listitem>-	<listitem><simpara>Benjamin Franksen</simpara></listitem>-	<listitem><simpara>Brett Letner</simpara></listitem>-        <listitem><simpara>Clemens Fruhwirth</simpara></listitem>-        <listitem><simpara>Conal Elliott</simpara></listitem>-        <listitem><simpara>David Waern</simpara></listitem>-        <listitem><simpara>Duncan Coutts</simpara></listitem>-        <listitem><simpara>George Pollard</simpara></listitem>-        <listitem><simpara>George Russel</simpara></listitem>-        <listitem><simpara>Hal Daume</simpara></listitem>-        <listitem><simpara>Ian Lynagh</simpara></listitem>-        <listitem><simpara>Isaac Dupree</simpara></listitem>-        <listitem><simpara>Joachim Breitner</simpara></listitem>-        <listitem><simpara>Krasimir Angelov</simpara></listitem>-        <listitem><simpara>Lennart Augustsson</simpara></listitem>-        <listitem><simpara>Luke Plant</simpara></listitem>-        <listitem><simpara>Malcolm Wallace</simpara></listitem>-        <listitem><simpara>Manuel Chakravarty</simpara></listitem>-        <listitem><simpara>Mark Lentczner</simpara></listitem>-        <listitem><simpara>Mark Shields</simpara></listitem>-        <listitem><simpara>Mateusz Kowalczyk</simpara></listitem>-        <listitem><simpara>Mike Thomas</simpara></listitem>-        <listitem><simpara>Neil Mitchell</simpara></listitem>-        <listitem><simpara>Oliver Brown</simpara></listitem>-        <listitem><simpara>Roman Cheplyaka</simpara></listitem>-        <listitem><simpara>Ross Paterson</simpara></listitem>-        <listitem><simpara>Sigbjorn Finne</simpara></listitem>-        <listitem><simpara>Simon Hengel</simpara></listitem>-        <listitem><simpara>Simon Marlow</simpara></listitem>-        <listitem><simpara>Simon Peyton-Jones</simpara></listitem>-        <listitem><simpara>Stefan O'Rear</simpara></listitem>-        <listitem><simpara>Sven Panne</simpara></listitem>-        <listitem><simpara>Thomas Schilling</simpara></listitem>-        <listitem><simpara>Wolfgang Jeltsch</simpara></listitem>-        <listitem><simpara>Yitzchak Gale</simpara></listitem>-      </itemizedlist>-    </section>-    <section>-      <title>Acknowledgements</title>--      <para>Several documentation systems provided the inspiration for-      Haddock, most notably:</para>--      <itemizedlist>-	<listitem>-	  <para><ulink-          url="http://www.cse.unsw.edu.au/~chak/haskell/idoc/">-          IDoc</ulink></para>-	</listitem>-	<listitem>-	  <para><ulink-	  url="http://www.fmi.uni-passau.de/~groessli/hdoc/">HDoc</ulink></para>-	</listitem>-	<listitem>-	  <para><ulink url="http://www.stack.nl/~dimitri/doxygen/">-          Doxygen</ulink></para>-	</listitem>-      </itemizedlist>--      <para>and probably several others I've forgotten.</para>--      <para>Thanks to the the members-      of <email>haskelldoc@haskell.org</email>,-      <email>haddock@projects.haskell.org</email> and everyone who-      contributed to the many libraries that Haddock makes use-      of.</para>-    </section>--  </chapter>--  <chapter id="invoking">-    <title>Invoking Haddock</title>-    <para>Haddock is invoked from the command line, like so:</para>--    <cmdsynopsis>-      <command>haddock</command>-      <arg rep="repeat"><replaceable>option</replaceable></arg>-      <arg rep="repeat" choice="plain"><replaceable>file</replaceable></arg>-    </cmdsynopsis>--    <para>Where each <replaceable>file</replaceable> is a filename-    containing a Haskell source module (.hs) or a Literate Haskell source-    module (.lhs) or just a module name.</para>--    <para>All the modules specified on the command line will be-    processed together.  When one module refers to an entity in-    another module being processed, the documentation will link-    directly to that entity.</para>--    <para>Entities that cannot be found, for example because they are-    in a module that isn't being processed as part of the current-    batch, simply won't be hyperlinked in the generated-    documentation.  Haddock will emit warnings listing all the-    identifiers it couldn't resolve.</para>--    <para>The modules should <emphasis>not</emphasis> be mutually-    recursive, as Haddock don't like swimming in circles.</para>--    <para>Note that while older version would fail on invalid markup, this is considered a bug in the-    new versions. If you ever get failed parsing message, please report it.</para>--    <para>You must also specify an option for the output format.-    Currently only the <option>-h</option> option for HTML and the-    <option>--hoogle</option> option for outputting Hoogle data are-    functional.</para>--    <para>The packaging-    tool <ulink url="http://www.haskell.org/ghc/docs/latest/html/Cabal/index.html">Cabal</ulink>-    has Haddock support, and is often used instead of invoking Haddock-    directly.</para>--    <para>The following options are available:</para>--    <variablelist>--      <varlistentry>-	<term>-          <indexterm><primary><option>-B</option></primary></indexterm>-          <option>-B</option> <replaceable>dir</replaceable>-        </term>-	<listitem>-	  <para>Tell GHC that that its lib directory is-    <replaceable>dir</replaceable>. Can be used to override the default path.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-          <indexterm><primary><option>-o</option></primary></indexterm>-          <option>-o</option> <replaceable>dir</replaceable>-        </term>-	<term>-          <indexterm><primary><option>--odir</option></primary></indexterm>-          <option>--odir</option>=<replaceable>dir</replaceable>-        </term>-	<listitem>-	  <para>Generate files into <replaceable>dir</replaceable>-	  instead of the current directory.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-l</option></primary></indexterm>-          <option>-l</option> <replaceable>dir</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--lib</option></primary></indexterm>-          <option>--lib</option>=<replaceable>dir</replaceable>-        </term>-	<listitem>-	  <para>Use Haddock auxiliary files (themes, javascript, etc...) in <replaceable>dir</replaceable>.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-i</option></primary></indexterm>-          <option>-i</option> <replaceable>path</replaceable>,<replaceable>file</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--read-interface</option></primary></indexterm>-          <option>--read-interface</option>=<replaceable>path</replaceable>,<replaceable>file</replaceable>-        </term>-	<listitem>-	  <para>Read the interface file in-	  <replaceable>file</replaceable>, which must have been-	  produced by running Haddock with the-	  <option>--dump-interface</option> option.  The interface-	  describes a set of modules whose HTML documentation is-	  located in <replaceable>path</replaceable> (which may be a-	  relative pathname).  The <replaceable>path</replaceable> is-	  optional, and defaults to <quote>.</quote>.</para>--	  <para>This option allows Haddock to produce separate sets of-	  documentation with hyperlinks between them.  The-	  <replaceable>path</replaceable> is used to direct hyperlinks-	  to point to the right files; so make sure you don't move the-	  HTML files later or these links will break.  Using a-	  relative <replaceable>path</replaceable> means that a-	  documentation subtree can still be moved around without-	  breaking links.</para>--	  <para>Multiple <option>--read-interface</option> options may-	  be given.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-  	  <indexterm><primary><option>-D</option></primary></indexterm>-          <option>-D</option> <replaceable>file</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--dump-interface</option></primary></indexterm>-          <option>--dump-interface</option>=<replaceable>file</replaceable>-        </term>-	<listitem>-	  <para>Produce an <firstterm>interface-	  file</firstterm><footnote><para>Haddock interface files are-	  not the same as Haskell interface files, I just couldn't-	  think of a better name.</para> </footnote>-	  in the file <replaceable>file</replaceable>.  An interface-	  file contains information Haddock needs to produce more-	  documentation that refers to the modules currently being-	  processed - see the <option>--read-interface</option> option-	  for more details.  The interface file is in a binary format;-	  don't try to read it.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-h</option></primary></indexterm>-          <option>-h</option>-        </term>-	<term>-	  <indexterm><primary><option>--html</option></primary></indexterm>-          <option>--html</option>-        </term>-	<listitem>-	  <para>Generate documentation in HTML format.  Several files-	  will be generated into the current directory (or the-	  specified directory if the <option>-o</option> option is-	  given), including the following:</para>-	  <variablelist>-	    <varlistentry>-	      <term><filename><replaceable>module</replaceable>.html</filename></term>-	      <term><filename>mini_<replaceable>module</replaceable>.html</filename></term>-	      <listitem>-		<para>An HTML page for each-		<replaceable>module</replaceable>, and a "mini" page for-		each used when viewing in frames.</para>-	      </listitem>-	    </varlistentry>-	    <varlistentry>-	      <term><filename>index.html</filename></term>-	      <listitem>-		<para>The top level page of the documentation: lists-		the modules available, using indentation to represent-		the hierarchy if the modules are hierarchical.</para>-	      </listitem>-	    </varlistentry>-	    <varlistentry>-	      <term><filename>doc-index.html</filename></term>-	      <term><filename>doc-index-<replaceable>X</replaceable>.html</filename></term>-	      <listitem>-		<para>The alphabetic index, possibly split into multiple-		pages if big enough.</para>-	      </listitem>-	    </varlistentry>-	    <varlistentry>-	      <term><filename>frames.html</filename></term>-	      <listitem>-		<para>The top level document when viewing in frames.</para>-	      </listitem>-	    </varlistentry>-	    <varlistentry>-	      <term><filename><replaceable>some</replaceable>.css</filename></term>-	      <term><filename><replaceable>etc...</replaceable></filename></term>-	      <listitem>-		<para>Files needed for the themes used. Specify your themes-		using the <option>--theme</option> option.</para>-	      </listitem>-	    </varlistentry>-	    <varlistentry>-	      <term><filename>haddock-util.js</filename></term>-	      <listitem>-		<para>Some JavaScript utilities used to implement some of the-		dynamic features like collapsible sections, and switching to-		frames view.</para>-	      </listitem>-	    </varlistentry>-	  </variablelist>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>--latex</option></primary></indexterm>-          <option>--latex</option>-        </term>-        <listitem>-          <para>Generate documentation in LaTeX format.  Several files-          will be generated into the current directory (or the-            specified directory if the <option>-o</option> option is-            given), including the following:</para>--	  <variablelist>-	    <varlistentry>-	      <term><filename><replaceable>package</replaceable>.tex</filename></term>-	      <listitem>-                <para>The top-level LaTeX source file; to format the-                documentation into PDF you might run something like-                  this:</para>-<screen>-$ pdflatex <replaceable>package</replaceable>.tex</screen>-              </listitem>-            </varlistentry>-            <varlistentry>-              <term><filename>haddock.sty</filename></term>-              <listitem>-                <para>The default style.  The file contains-                definitions for various macros used in the LaTeX-                sources generated by Haddock; to change the way the-                formatted output looks, you might want to override-                these by specifying your own style with-                the <option>--latex-style</option> option.</para>-              </listitem>-            </varlistentry>-            <varlistentry>-              <term><filename><replaceable>module</replaceable>.tex</filename></term>-              <listitem>-                <para>The LaTeX documentation for-                each <replaceable>module</replaceable>.</para>-              </listitem>-            </varlistentry>-          </variablelist>-        </listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>--latex-style</option></primary></indexterm>-          <option>--latex-style=<replaceable>style</replaceable></option>-        </term>-        <listitem>-          <para>This option lets you override the default style used-            by the LaTeX generated by the <option>--latex</option> option.-            Normally Haddock puts a-            standard <filename>haddock.sty</filename> in the output-            directory, and includes the-            command <literal>\usepackage{haddock}</literal> in the-            LaTeX source.  If this option is given,-            then <filename>haddock.sty</filename> is not generated,-            and the command is-            instead <literal>\usepackage{<replaceable>style</replaceable>}</literal>.-          </para>-        </listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-S</option></primary></indexterm>-          <option>-S</option>-        </term>-	<term>-	  <indexterm><primary><option>--docbook</option></primary></indexterm>-          <option>--docbook</option>-        </term>-	<listitem>-	  <para>Reserved for future use (output documentation in DocBook XML-	  format).</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--source-base</option></primary></indexterm>-          <option>--source-base</option>=<replaceable>URL</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--source-module</option></primary></indexterm>-          <option>--source-module</option>=<replaceable>URL</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--source-entity</option></primary></indexterm>-          <option>--source-entity</option>=<replaceable>URL</replaceable>-        </term>-        <term>-	  <indexterm><primary><option>--source-entity-line</option></primary></indexterm>-	  <option>--source-entity-line</option>=<replaceable>URL</replaceable>-        </term>-	<listitem>-	  <para>Include links to the source files in the generated-	  documentation. Use the <option>--source-base</option> option to add a-	  source code link in the header bar of the contents and index pages.-	  Use the <option>--source-module</option> to add a source code link in-	  the header bar of each module page. Use the-	  <option>--source-entity</option> option to add a source code link-	  next to the documentation for every value and type in each module.-	  <option>--source-entity-line</option> is a flag that gets used for-	  entities that need to link to an exact source location rather than a-	  name, eg. since they were defined inside a Template Haskell splice.-	  </para>--	  <para>In each case <replaceable>URL</replaceable> is the base URL-	  where the source files can be found.  For the per-module and-	  per-entity URLs, the following substitutions are made within the-	  string <replaceable>URL</replaceable>:</para>--	  <itemizedlist>-	    <listitem>-	      <para>The string <literal>%M</literal> or <literal>%{MODULE}</literal>-	      is replaced by the module name. Note that for the per-entity URLs-	      this is the name of the <emphasis>exporting</emphasis> module.</para>-	    </listitem>-	    <listitem>-	      <para>The string <literal>%F</literal> or <literal>%{FILE}</literal>-	      is replaced by the original source file name. Note that for the-	      per-entity URLs this is the name of the <emphasis>defining</emphasis>-	      module.</para>-	    </listitem>-	    <listitem>-	      <para>The string <literal>%N</literal> or <literal>%{NAME}</literal>-	      is replaced by the name of the exported value or type. This is-	      only valid for the <option>--source-entity</option> option.</para>-	    </listitem>-	    <listitem>-	      <para>The string <literal>%K</literal> or <literal>%{KIND}</literal>-	      is replaced by a flag indicating whether the exported name is a value-	      '<literal>v</literal>' or a type '<literal>t</literal>'. This is-	      only valid for the <option>--source-entity</option> option.</para>-	    </listitem>-	    <listitem>-	      <para>The string <literal>%L</literal> or <literal>%{LINE}</literal>-	      is replaced by the number of the line where the exported value or-	      type is defined. This is only valid for the-	      <option>--source-entity</option> option.</para>-	    </listitem>-	    <listitem>-	      <para>The string <literal>%%</literal> is replaced by-	      <literal>%</literal>.</para>-      </listitem>--	  </itemizedlist>--	  <para>For example, if your sources are online under some directory,-	  you would say-	  <literal>haddock --source-base=<replaceable>url</replaceable>/-	  --source-module=<replaceable>url</replaceable>/%F</literal></para>--	  <para>If you have html versions of your sources online with anchors-	  for each type and function name, you would say-	  <literal>haddock --source-base=<replaceable>url</replaceable>/-	  --source-module=<replaceable>url</replaceable>/%M.html-	  --source-entity=<replaceable>url</replaceable>/%M.html#%N</literal></para>--	  <para>For the <literal>%{MODULE}</literal> substitution you may want to-	  replace the '<literal>.</literal>' character in the module names with-	  some other character (some web servers are known to get confused by-	  multiple '<literal>.</literal>' characters in a file name). To-	  replace it with a character <replaceable>c</replaceable> use-	  <literal>%{MODULE/./<replaceable>c</replaceable>}</literal>.</para>--	  <para>Similarly, for the <literal>%{FILE}</literal> substitution-          you may want to replace the '<literal>/</literal>' character in-          the file names with some other character (especially for links-          to colourised entity source code with a shared css file).  To replace-          it with a character <replaceable>c</replaceable> use-          <literal>%{FILE///<replaceable>c</replaceable>}</literal>/</para>--          <para>One example of a tool that can generate syntax-highlighted-          HTML from your source code, complete with anchors suitable for use-          from haddock, is-          <ulink url="http://www.cs.york.ac.uk/fp/darcs/hscolour">hscolour</ulink>.</para>--	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-s</option></primary></indexterm>-          <option>-s</option> <replaceable>URL</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--source</option></primary></indexterm>-          <option>--source</option>=<replaceable>URL</replaceable>-        </term>-	<listitem>-	  <para>Deprecated aliases for <option>--source-module</option></para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--comments-base</option></primary></indexterm>-          <option>--comments-base</option>=<replaceable>URL</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--comments-module</option></primary></indexterm>-          <option>--comments-module</option>=<replaceable>URL</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--comments-entity</option></primary></indexterm>-          <option>--comments-entity</option>=<replaceable>URL</replaceable>-        </term>-	<listitem>-	  <para>Include links to pages where readers may comment on the-	  documentation. This feature would typically be used in conjunction-	  with a Wiki system.</para>--	  <para>Use the <option>--comments-base</option> option to add a-	  user comments link in the header bar of the contents and index pages.-	  Use the <option>--comments-module</option> to add a user comments-	  link in the header bar of each module page. Use the-	  <option>--comments-entity</option> option to add a comments link-	  next to the documentation for every value and type in each module.-	  </para>--	  <para>In each case <replaceable>URL</replaceable> is the base URL-	  where the corresponding comments page can be found.  For the-	  per-module and per-entity URLs the same substitutions are made as-	  with the <option>--source-module</option> and-	  <option>--source-entity</option> options above.</para>--	  <para>For example, if you want to link the contents page to a wiki-	  page, and every module to subpages, you would say-	  <literal>haddock --comments-base=<replaceable>url</replaceable>-	  --comments-module=<replaceable>url</replaceable>/%M</literal></para>--	  <para>If your Wiki system doesn't like the '<literal>.</literal>' character-	  in Haskell module names, you can replace it with a different character. For-	  example to replace the '<literal>.</literal>' characters with-	  '<literal>_</literal>' use <literal>haddock-	  --comments-base=<replaceable>url</replaceable>-	  --comments-module=<replaceable>url</replaceable>/%{MODULE/./_}</literal>-	  Similarly, you can replace the '<literal>/</literal>' in a file name (may-	  be useful for entity comments, but probably not.) </para>--	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--theme</option></primary></indexterm>-          <option>--theme</option>=<replaceable>path</replaceable>-        </term>-	<listitem>-	  <para>Specify a theme to be used for HTML (<option>--html</option>)-	  documentation. If given multiple times then the pages will use the-	  first theme given by default, and have alternate style sheets for-	  the others. The reader can switch between themes with browsers that-	  support alternate style sheets, or with the "Style" menu that gets-	  added when the page is loaded. If-	  no themes are specified, then just the default built-in theme-	  ("Ocean") is used.-	  </para>--	  <para>The <replaceable>path</replaceable> parameter can be one of:-	  </para>--	  <itemizedlist>-	    <listitem>-	      <para>A <emphasis>directory</emphasis>: The base name of-	      the directory becomes the name of the theme. The directory-	      must contain exactly one-	      <filename><replaceable>some</replaceable>.css</filename> file.-	      Other files, usually image files, will be copied, along with-	      the <filename><replaceable>some</replaceable>.css</filename>-	      file, into the generated output directory.</para>-	    </listitem>-	    <listitem>-	      <para>A <emphasis>CSS file</emphasis>: The base name of-	      the file becomes the name of the theme.</para>-	    </listitem>-	    <listitem>-	      <para>The <emphasis>name</emphasis> of a built-in theme-	      ("Ocean" or "Classic").</para>-	    </listitem>-	  </itemizedlist>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--built-in-themes</option></primary></indexterm>-          <option>--built-in-themes</option>-        </term>-	<listitem>-	  <para>Includes the built-in themes ("Ocean" and "Classic").-	  Can be combined with <option>--theme</option>. Note that order-	  matters: The first specified theme will be the default.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-c</option></primary></indexterm>-          <option>-c</option> <replaceable>file</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--css</option></primary></indexterm>-          <option>--css</option>=<replaceable>file</replaceable>-        </term>-	<listitem>-	  <para>Deprecated aliases for <option>--theme</option></para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>-p</option></primary></indexterm>-          <option>-p</option> <replaceable>file</replaceable>-        </term>-	<term>-	  <indexterm><primary><option>--prologue</option></primary></indexterm>-          <option>--prologue</option>=<replaceable>file</replaceable>-        </term>-	<listitem>-	  <para>Specify a file containing documentation which is-	  placed on the main contents page under the heading-	  &ldquo;Description&rdquo;.  The file is parsed as a normal-	  Haddock doc comment (but the comment markers are not-	  required).</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>-t</option></primary></indexterm>-          <option>-t</option> <replaceable>title</replaceable>-        </term>-        <term>-          <indexterm><primary><option>--title</option></primary></indexterm>-          <option>--title</option>=<replaceable>title</replaceable>-        </term>-	<listitem>-	  <para>Use <replaceable>title</replaceable> as the page-	  heading for each page in the documentation.This will-	  normally be the name of the library being documented.</para>--	  <para>The title should be a plain string (no markup-	  please!).</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>-q</option></primary></indexterm>-          <option>-q</option> <replaceable>mode</replaceable>-        </term>-        <term>-          <indexterm><primary><option>--qual</option></primary></indexterm>-          <option>--qual</option>=<replaceable>mode</replaceable>-        </term>-        <listitem>-            <para>-                Specify how identifiers are qualified.-            </para>-            <para>-                <replaceable>mode</replaceable> should be one of-                <itemizedlist>-                    <listitem>-                        <para>none (default): don't qualify any identifiers</para>-                    </listitem>-                    <listitem>-                        <para>full: always qualify identifiers completely</para>-                    </listitem>-                    <listitem>-                        <para>local: only qualify identifiers that are not part-                            of the module</para>-                    </listitem>-                    <listitem>-                        <para>relative: like local, but strip name of the module-                            from qualifications of identifiers in submodules</para>-                    </listitem>-                </itemizedlist>-            </para>-            <para>-                Example: If you generate documentation for module A, then the-                identifiers A.x, A.B.y and C.z are qualified as follows.-            </para>-            <para>-                <itemizedlist>-                    <listitem>-                        <simpara>none: x, y, z</simpara>-                    </listitem>-                    <listitem>-                        <simpara>full: A.x, A.B.y, C.z</simpara>-                    </listitem>-                    <listitem>-                        <simpara>local: x, A.B.y, C.z</simpara>-                    </listitem>-                    <listitem>-                        <simpara>relative: x, B.y, C.z</simpara>-                    </listitem>-                </itemizedlist>-	        </para>-	    </listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>-?</option></primary></indexterm>-          <option>-?</option>-        </term>-        <term>-          <indexterm><primary><option>--help</option></primary></indexterm>-          <option>--help</option>-        </term>-	<listitem>-	  <para>Display help and exit.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>-V</option></primary></indexterm>-          <option>-V</option>-        </term>-        <term>-          <indexterm><primary><option>--version</option></primary></indexterm>-          <option>--version</option>-        </term>-	<listitem>-	  <para>Output version information and exit.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>-v</option></primary></indexterm>-          <option>-v</option>-        </term>-        <term>-          <indexterm><primary><option>--verbose</option></primary></indexterm>-          <option>--verbose</option>-        </term>-	<listitem>-	  <para>Increase verbosity.  Currently this will cause Haddock-	  to emit some extra warnings, in particular about modules-	  which were imported but it had no information about (this is-	  often quite normal; for example when there is no information-	  about the <literal>Prelude</literal>).</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>--use-contents</option></primary></indexterm>-          <option>--use-contents=<replaceable>URL</replaceable></option>-        </term>-        <term>-          <indexterm><primary><option>--use-index</option></primary></indexterm>-          <option>--use-index=<replaceable>URL</replaceable></option>-        </term>-	<listitem>-	  <para>When generating HTML, do not generate an index.-	  Instead, redirect the Contents and/or Index link on each page to-	  <replaceable>URL</replaceable>.  This option is intended for-	  use in conjunction with <option>--gen-contents</option> and/or-	  <option>--gen-index</option> for-	  generating a separate contents and/or index covering multiple-	  libraries.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>--gen-contents</option></primary></indexterm>-          <option>--gen-contents</option>-        </term>-        <term>-          <indexterm><primary><option>--gen-index</option></primary></indexterm>-          <option>--gen-index</option>-        </term>-	<listitem>-	  <para>Generate an HTML contents and/or index containing entries pulled-	  from all the specified interfaces (interfaces are specified using-	  <option>-i</option> or <option>--read-interface</option>).-	  This is used to generate a single contents and/or index for multiple-	  sets of Haddock documentation.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--ignore-all-exports</option></primary>-	  </indexterm>-	  <option>--ignore-all-exports</option>-	</term>-	<listitem>-	  <para>Causes Haddock to behave as if every module has the-	    <literal>ignore-exports</literal> attribute (<xref-	      linkend="module-attributes" />).  This might be useful for-	    generating implementation documentation rather than interface-	    documentation, for example.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--hide</option></primary>-	  </indexterm>-	  <option>--hide</option>&nbsp;<replaceable>module</replaceable>-	</term>-	<listitem>-	  <para>Causes Haddock to behave as if module-	    <replaceable>module</replaceable> has the <literal>hide</literal>-	    attribute. (<xref linkend="module-attributes" />).</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-	  <indexterm><primary><option>--show-extensions</option></primary>-	  </indexterm>-	  <option>--show-extensions</option>&nbsp;<replaceable>module</replaceable>-	</term>-	<listitem>-	  <para>Causes Haddock to behave as if module-	    <replaceable>module</replaceable> has the <literal>show-extensions</literal>-	    attribute. (<xref linkend="module-attributes" />).</para>-	</listitem>-      </varlistentry>--      <varlistentry>-	<term>-          <indexterm><primary><option>--optghc</option></primary></indexterm>-          <option>--optghc</option>=<replaceable>option</replaceable>-        </term>-	<listitem>-	  <para>Pass <replaceable>option</replaceable> to GHC. Note that there is a double dash there, unlike for GHC.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>-w</option></primary></indexterm>-          <option>-w</option>-        </term>-        <term>-          <indexterm><primary><option>--no-warnings</option></primary></indexterm>-          <option>--no-warnings</option>-        </term>-	<listitem>-	  <para>Turn off all warnings.</para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>--compatible-interface-versions</option></primary></indexterm>-          <option>--compatible-interface-versions</option>-        </term>-	<listitem>-          <para>-            Prints out space-separated versions of binary Haddock interface files that this version is compatible-            with.-          </para>-	</listitem>-      </varlistentry>--      <varlistentry>-        <term>-          <indexterm><primary><option>--no-tmp-comp-dir</option></primary></indexterm>-          <option>--no-tmp-comp-dir</option>-        </term>-	<listitem>-          <para>-          Do not use a temporary directory for reading and writing compilation output files-          (<literal>.o</literal>, <literal>.hi</literal>, and stub files). Instead, use the-          present directory or another directory that you have explicitly told GHC to use-          via the <literal>--optghc</literal> flag.-          </para>-          <para>-          This flag can be used to avoid recompilation if compilation files already exist.-          Compilation files are produced when Haddock has to process modules that make use of-          Template Haskell, in which case Haddock compiles the modules using the GHC API.-          </para>-	</listitem>-      </varlistentry>-    </variablelist>--    <section id="cpp">-      <title>Using literate or pre-processed source</title>--      <para>Since Haddock uses GHC internally, both plain and-            literate Haskell sources are accepted without the need for the user-            to do anything. To use the C pre-processor, however,-            the user must pass the the <option>-cpp</option> option to GHC-            using <option>--optghc</option>.-      </para>-    </section>--  </chapter>--  <chapter id="markup">-    <title>Documentation and Markup</title>--    <para>Haddock understands special documentation annotations in the-    Haskell source file and propagates these into the generated-    documentation.  The annotations are purely optional: if there are-    no annotations, Haddock will just generate documentation that-    contains the type signatures, data type declarations, and class-    declarations exported by each of the modules being-    processed.</para>--    <section>-      <title>Documenting a top-level declaration</title>--      <para>The simplest example of a documentation annotation is for-      documenting any top-level declaration (function type signature,-      type declaration, or class declaration).  For example, if the-      source file contains the following type signature:</para>--<programlisting>-square :: Int -> Int-square x = x * x-</programlisting>--    <para>Then we can document it like this:</para>--<programlisting>--- |The 'square' function squares an integer.-square :: Int -> Int-square x = x * x-</programlisting>---      <para>The <quote><literal>-- |</literal></quote> syntax begins a-      documentation annotation, which applies to the-      <emphasis>following</emphasis> declaration in the source file.-      Note that the annotation is just a comment in Haskell &mdash; it-      will be ignored by the Haskell compiler.</para>--      <para>The declaration following a documentation annotation-      should be one of the following:</para>-      <itemizedlist>-	<listitem>-	  <para>A type signature for a top-level function,</para>-	</listitem>-	<listitem>-	  <para>A <literal>data</literal> declaration,</para>-	</listitem>-	<listitem>-	  <para>A <literal>newtype</literal> declaration,</para>-	</listitem>-	<listitem>-	  <para>A <literal>type</literal> declaration</para>-	</listitem>-	<listitem>-	  <para>A <literal>class</literal> declaration,</para>-	</listitem>-        <listitem>-          <para>A <literal>data family</literal> or-            <literal>type family</literal> declaration, or</para>-        </listitem>-        <listitem>-          <para>A <literal>data instance</literal> or-            <literal>type instance</literal> declaration.</para>-        </listitem>-      </itemizedlist>--      <para>If the annotation is followed by a different kind of-      declaration, it will probably be ignored by Haddock.</para>--      <para>Some people like to write their documentation-      <emphasis>after</emphasis> the declaration; this is possible in-      Haddock too:</para>--<programlisting>-square :: Int -> Int--- ^The 'square' function squares an integer.-square x = x * x-</programlisting>--      <para>Note that Haddock doesn't contain a Haskell type system-      &mdash; if you don't write the type signature for a function,-      then Haddock can't tell what its type is and it won't be-      included in the documentation.</para>--      <para>Documentation annotations may span several lines; the-      annotation continues until the first non-comment line in the-      source file.  For example:</para>--<programlisting>--- |The 'square' function squares an integer.--- It takes one argument, of type 'Int'.-square :: Int -> Int-square x = x * x-</programlisting>--      <para>You can also use Haskell's nested-comment style for-      documentation annotations, which is sometimes more convenient-      when using multi-line comments:</para>--<programlisting>-{-|-  The 'square' function squares an integer.-  It takes one argument, of type 'Int'.--}-square :: Int -> Int-square x = x * x-</programlisting>--    </section>-    <section>-      <title>Documenting parts of a declaration</title>--      <para>In addition to documenting the whole declaration, in some-      cases we can also document individual parts of the-      declaration.</para>--      <section>-	<title>Class methods</title>--	<para>Class methods are documented in the same way as top-	level type signatures, by using either the-	<quote><literal>--&nbsp;|</literal></quote> or-	<quote><literal>--&nbsp;^</literal></quote>-	annotations:</para>--<programlisting>-class C a where-   -- | This is the documentation for the 'f' method-   f :: a -> Int-   -- | This is the documentation for the 'g' method-   g :: Int -> a-</programlisting>-      </section>--      <section>-	<title>Constructors and record fields</title>--	<para>Constructors are documented like so:</para>--<programlisting>-data T a b-  -- | This is the documentation for the 'C1' constructor-  = C1 a b-  -- | This is the documentation for the 'C2' constructor-  | C2 a b-</programlisting>--	<para>or like this:</para>--<programlisting>-data T a b-  = C1 a b  -- ^ This is the documentation for the 'C1' constructor-  | C2 a b  -- ^ This is the documentation for the 'C2' constructor-</programlisting>--	<para>Record fields are documented using one of these-	styles:</para>--<programlisting>-data R a b =-  C { -- | This is the documentation for the 'a' field-      a :: a,-      -- | This is the documentation for the 'b' field-      b :: b-    }--data R a b =-  C { a :: a  -- ^ This is the documentation for the 'a' field-    , b :: b  -- ^ This is the documentation for the 'b' field-    }-</programlisting>--        <para>Alternative layout styles are generally accepted by-        Haddock - for example doc comments can appear before or after-        the comma in separated lists such as the list of record fields-        above.</para>--        <para>In case that more than one constructor exports a field-        with the same name, the documentation attached to the first-        occurence of the field will be used, even if a comment is not-        present.-        </para>--<programlisting>-data T a = A { someField :: a -- ^ Doc for someField of A-             }-         | B { someField :: a -- ^ Doc for someField of B-             }-</programlisting>--        <para>In the above example, all occurences of-        <literal>someField</literal> in the documentation are going to-        be documented with <literal>Doc for someField of A</literal>.-        Note that Haddock versions 2.14.0 and before would join up-        documentation of each field and render the result. The reason-        for this seemingly weird behaviour is the fact that-        <literal>someField</literal> is actually the same (partial)-        function.</para>--      </section>--      <section>-	<title>Function arguments</title>--	<para>Individual arguments to a function may be documented-	like this:</para>--<programlisting>-f  :: Int      -- ^ The 'Int' argument-   -> Float    -- ^ The 'Float' argument-   -> IO ()    -- ^ The return value-</programlisting>-      </section>-    </section>--    <section>-      <title>The module description</title>--      <para>A module itself may be documented with multiple fields-      that can then be displayed by the backend. In particular, the-      HTML backend displays all the fields it currently knows-      about. We first show the most complete module documentation-      example and then talk about the fields.</para>--<programlisting>-{-|-Module      : W-Description : Short description-Copyright   : (c) Some Guy, 2013-                  Someone Else, 2014-License     : GPL-3-Maintainer  : sample@email.com-Stability   : experimental-Portability : POSIX--Here is a longer description of this module, containing some-commentary with @some markup@.--}-module W where-...-</programlisting>--      <para>The <quote>Module</quote> field should be clear. It-      currently doesn't affect the output of any of the backends but-      you might want to include it for human information or for any-      other tools that might be parsing these comments without the-      help of GHC.</para>--      <para>The <quote>Description</quote> field accepts some short text-      which outlines the general purpose of the module. If you're-      generating HTML, it will show up next to the module link in-      the module index.</para>--      <para>The <quote>Copyright</quote>, <quote>License</quote>,-      <quote>Maintainer</quote> and <quote>Stability</quote> fields-      should be obvious. An alternative spelling for the-      <quote>License</quote> field is accepted as-      <quote>Licence</quote> but the output will always prefer-      <quote>License</quote>.</para>--      <para>The <quote>Portability</quote> field has seen varied use-      by different library authors. Some people put down things like-      operating system constraints there while others put down which GHC-      extensions are used in the module. Note that you might want to-      consider using the <quote>show-extensions</quote> module flag for the-      latter.</para>--      <para>Finally, a module may contain a documentation comment-      before the module header, in which case this comment is-      interpreted by Haddock as an overall description of the module-      itself, and placed in a section entitled-      <quote>Description</quote> in the documentation for the module.-      All usual Haddock markup is valid in this comment.</para>--      <para>All fields are optional but they must be in order if they-      do appear. Multi-line fields are accepted but the consecutive-      lines have to start indented more than their label. If your-      label is indented one space as is often the case with-      <quote>--</quote> syntax, the consecutive lines have to start at-      two spaces at the very least. Please note that we do not enforce-      the format for any of the fields and the established formats are-      just a convention.</para>--    </section>--    <section>-      <title>Controlling the documentation structure</title>--      <para>Haddock produces interface documentation that lists only-      the entities actually exported by the module.  The documentation-      for a module will include <emphasis>all</emphasis> entities-      exported by that module, even if they were re-exported by-      another module.  The only exception is when Haddock can't see-      the declaration for the re-exported entity, perhaps because it-      isn't part of the batch of modules currently being-      processed.</para>--      <para>However, to Haddock the export list has even more-      significance than just specifying the entities to be included in-      the documentation.  It also specifies the-      <emphasis>order</emphasis> that entities will be listed in the-      generated documentation.  This leaves the programmer free to-      implement functions in any order he/she pleases, and indeed in-      any <emphasis>module</emphasis> he/she pleases, but still-      specify the order that the functions should be documented in the-      export list.  Indeed, many programmers already do this: the-      export list is often used as a kind of ad-hoc interface-      documentation, with headings, groups of functions, type-      signatures and declarations in comments.</para>--      <para>You can insert headings and sub-headings in the-      documentation by including annotations at the appropriate point-      in the export list.  For example:</para>--<programlisting>-module Foo (-  -- * Classes-  C(..),-  -- * Types-  -- ** A data type-  T,-  -- ** A record-  R,-  -- * Some functions-  f, g-  ) where-</programlisting>--      <para>Headings are introduced with the syntax-      <quote><literal>--&nbsp;*</literal></quote>,-      <quote><literal>--&nbsp;**</literal></quote> and so on, where-      the number of <literal>*</literal>s indicates the level of the-      heading (section, sub-section, sub-sub-section, etc.).</para>--      <para>If you use section headings, then Haddock will generate a-      table of contents at the top of the module documentation for-      you.</para>--      <para>The alternative style of placing the commas at the-      beginning of each line is also supported. eg.:</para>--<programlisting>-module Foo (-  -- * Classes-  , C(..)-  -- * Types-  -- ** A data type-  , T-  -- ** A record-  , R-  -- * Some functions-  , f-  , g-  ) where-</programlisting>--      <section>-	<title>Re-exporting an entire module</title>--	<para>Haskell allows you to re-export the entire contents of a-	module (or at least, everything currently in scope that was-	imported from a given module) by listing it in the export-	list:</para>--<programlisting>-module A (-  module B,-  module C- ) where-</programlisting>--	<para>What will the Haddock-generated documentation for this-	module look like?  Well, it depends on how the modules-	<literal>B</literal> and <literal>C</literal> are imported.-	If they are imported wholly and without any-	<literal>hiding</literal> qualifiers, then the documentation-	will just contain a cross-reference to the documentation for-	<literal>B</literal> and <literal>C</literal>.  However, if-	the modules are not <emphasis>completely</emphasis>-	re-exported, for example:</para>--<programlisting>-module A (-  module B,-  module C- ) where--import B hiding (f)-import C (a, b)-</programlisting>--	<para>then Haddock behaves as if the set of entities-	re-exported from <literal>B</literal> and <literal>C</literal>-	had been listed explicitly in the export-	list<footnote><para>NOTE: this is not fully implemented at the-	time of writing (version 0.2).  At the moment, Haddock always-	inserts a cross-reference.</para>-	  </footnote>.</para>--	<para>The exception to this rule is when the re-exported-	module is declared with the <literal>hide</literal> attribute-	(<xref linkend="module-attributes"/>), in which case the module-	is never cross-referenced; the contents are always expanded in-	place in the re-exporting module.</para>-      </section>--      <section>-	<title>Omitting the export list</title>--	<para>If there is no export list in the module, how does-	Haddock generate documentation?  Well, when the export list is-	omitted, e.g.:</para>--<programlisting>module Foo where</programlisting>--	<para>this is equivalent to an export list which mentions-	every entity defined at the top level in this module, and-	Haddock treats it in the same way.  Furthermore, the generated-	documentation will retain the order in which entities are-	defined in the module.  In this special case the module body-	may also include section headings (normally they would be-	ignored by Haddock).</para>--<programlisting>-module Foo where---- * This heading will now appear before foo.---- | Documentation for 'foo'.-foo :: Integer-foo = 5-</programlisting>--      </section>-    </section>--    <section>-      <title>Named chunks of documentation</title>--      <para>Occasionally it is desirable to include a chunk of-      documentation which is not attached to any particular Haskell-      declaration.  There are two ways to do this:</para>--      <itemizedlist>-	<listitem>-	  <para>The documentation can be included in the export list-	  directly, e.g.:</para>--<programlisting>-module Foo (-   -- * A section heading--   -- | Some documentation not attached to a particular Haskell entity-   ...- ) where-</programlisting>-	</listitem>--	<listitem>-	  <para>If the documentation is large and placing it inline in-	  the export list might bloat the export list and obscure the-	  structure, then it can be given a name and placed out of-	  line in the body of the module.  This is achieved with a-	  special form of documentation annotation-	  <quote><literal>--&nbsp;$</literal></quote>:</para>--<programlisting>-module Foo (-   -- * A section heading--   -- $doc-   ...- ) where---- $doc--- Here is a large chunk of documentation which may be referred to by--- the name $doc.-</programlisting>--	  <para>The documentation chunk is given a name, which is the-	  sequence of alphanumeric characters directly after the-	  <quote><literal>--&nbsp;$</literal></quote>, and it may be-	  referred to by the same name in the export list.</para>-	</listitem>-      </itemizedlist>-    </section>--    <section id="hyperlinking">-      <title>Hyperlinking and re-exported entities</title>--      <para>When Haddock renders a type in the generated-      documentation, it hyperlinks all the type constructors and class-      names in that type to their respective definitions.  But for a-      given type constructor or class there may be several modules-      re-exporting it, and therefore several modules whose-      documentation contains the definition of that type or class-      (possibly including the current module!) so which one do we link-      to?</para>--      <para>Let's look at an example.  Suppose we have three modules-      <literal>A</literal>, <literal>B</literal> and-      <literal>C</literal> defined as follows:</para>--<programlisting>-module A (T) where-data T a = C a--module B (f) where-import A-f :: T Int -> Int-f (C i) = i--module C (T, f) where-import A-import B-</programlisting>--      <para>Module <literal>A</literal> exports a datatype-      <literal>T</literal>.  Module <literal>B</literal> imports-      <literal>A</literal> and exports a function <literal>f</literal>-      whose type refers to <literal>T</literal>.  Also, both-	<literal>T</literal> and <literal>f</literal> are re-exported from-	module C.</para>--      <para>Haddock takes the view that each entity has a-	<emphasis>home</emphasis> module; that is, the module that the library-	designer would most like to direct the user to, to find the-	documentation for that entity.  So, Haddock makes all links to an entity-	point to the home module.  The one exception is when the entity is also-      exported by the current module: Haddock makes a local link if it-	can.</para>--      <para>How is the home module for an entity determined?-	Haddock uses the following rules:</para>--      <itemizedlist>-	<listitem>-	  <para>If modules A and B both export the entity, and module A imports-	    (directly or indirectly) module B, then B is preferred.</para>-	</listitem>-	<listitem>-	  <para>A module with the <literal>hide</literal> attribute is never-	    chosen as the home.</para>-	</listitem>-	<listitem>-	  <para>A module with the <literal>not-home</literal> attribute is only-	    chosen if there are no other modules to choose.</para>-	</listitem>-      </itemizedlist>--      <para>If multiple modules fit the criteria, then one is chosen at-	random.  If no modules fit the criteria (because the candidates are all-      hidden), then Haddock will issue a warning for each reference to an-	entity without a home.</para>--      <para>In the example above, module <literal>A</literal> is chosen as the-	home for <literal>T</literal> because it does not import any other-	module that exports <literal>T</literal>.  The link from-	<literal>f</literal>'s-	type in module <literal>B</literal> will therefore point to-	<literal>A.T</literal>.  However, <literal>C</literal> also exports-	<literal>T</literal> and <literal>f</literal>, and the link from-	<literal>f</literal>'s type in <literal>C</literal> will therefore-	point locally to <literal>C.T</literal>.</para>-    </section>--    <section id="module-attributes">-      <title>Module Attributes</title>--      <para>Certain attributes may be specified for each module which-      affects the way that Haddock generates documentation for that-      module.  Attributes are specified in a comma-separated list in an-      <literal>{-# OPTIONS_HADDOCK ... #-}</literal> pragma at the-      top of the module, either before or after the module-      description.  For example:</para>--<programlisting>-{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}---- |Module description-module A where-...-</programlisting>--      <para>The options and module description can be in either order.</para>--      <para>The following attributes are currently understood by-      Haddock:</para>--      <variablelist>-	<varlistentry>-          <term>-            <indexterm><primary><literal>hide</literal></primary></indexterm>-            <literal>hide</literal>-          </term>-	  <listitem>-	    <para>Omit this module from the generated documentation,-	    but nevertheless propagate definitions and documentation-	    from within this module to modules that re-export those-	    definitions.</para>-	  </listitem>-	</varlistentry>--	<varlistentry>-          <term>-            <indexterm><primary><literal>hide</literal></primary></indexterm>-            <literal>prune</literal>-          </term>-	  <listitem>-	    <para>Omit definitions that have no documentation-	    annotations from the generated documentation.</para>-	  </listitem>-	</varlistentry>--	<varlistentry>-          <term>-            <indexterm><primary><literal>ignore-exports</literal></primary></indexterm>-            <literal>ignore-exports</literal>-          </term>-	  <listitem>-	    <para>Ignore the export list.  Generate documentation as-	    if the module had no export list - i.e. all the top-level-	    declarations are exported, and section headings may be-	    given in the body of the module.</para>-	  </listitem>-	</varlistentry>--	<varlistentry>-	  <term>-	    <indexterm><primary><literal>not-home</literal></primary></indexterm>-      <literal>not-home</literal>-	  </term>-	  <listitem>-	    <para>Indicates that the current module should not be considered to-	      be the home module for each entity it exports,-	      unless that entity is not exported from any other module.  See-	      <xref linkend="hyperlinking" /> for more details.</para>-	  </listitem>-	</varlistentry>--	<varlistentry>-	  <term>-	    <indexterm><primary><literal>show-extensions</literal></primary></indexterm>-      <literal>show-extensions</literal>-	  </term>-	  <listitem>-	    <para>Indicates that we should render the extensions used in this module in the-            resulting documentation. This will only render if the output format supports it.-            If Language is set, it will be shown as well and all the extensions implied by it won't.-            All enabled extensions will be rendered, including those implied by their more powerful versions.</para>-	  </listitem>-	</varlistentry>--      </variablelist>--    </section>--    <section>-      <title>Markup</title>--      <para>Haddock understands certain textual cues inside-      documentation annotations that tell it how to render the-      documentation.  The cues (or <quote>markup</quote>) have been-      designed to be simple and mnemonic in ASCII so that the-      programmer doesn't have to deal with heavyweight annotations-      when editing documentation comments.</para>--      <section>-	<title>Paragraphs</title>--	<para>One or more blank lines separates two paragraphs in a-	documentation comment.</para>-      </section>--      <section>-	<title>Special characters</title>--	<para>The following characters have special meanings in-	documentation comments: <literal>\</literal>, <literal>/</literal>,-	<literal>'</literal>, <literal>`</literal>,-	<literal>"</literal>, <literal>@</literal>,-	<literal>&lt;</literal>.  To insert a literal occurrence of-	one of these special characters, precede it with a backslash-	(<literal>\</literal>).</para>--        <para>Additionally, the character <literal>&gt;</literal> has-        a special meaning at the beginning of a line, and the-        following characters have special meanings at the beginning of-        a paragraph:-        <literal>*</literal>, <literal>-</literal>.  These characters-        can also be escaped using <literal>\</literal>.</para>--        <para>Furthermore, the character sequence <literal>&gt;&gt;&gt;</literal>-        has a special meaning at the beginning of a line. To-        escape it, just prefix the characters in the sequence with a-        backslash.</para>-      </section>--      <section>-	<title>Character references</title>--	<para>Although Haskell source files may contain any character-	from the Unicode character set, the encoding of these characters-	as bytes varies between systems, so that only source files-	restricted to the ASCII character set are portable.  Other-	characters may be specified in character and string literals-	using Haskell character escapes.  To represent such characters-	in documentation comments, Haddock supports SGML-style numeric-	character references of the forms-	<literal>&amp;#</literal><replaceable>D</replaceable><literal>;</literal>-	and-	<literal>&amp;#x</literal><replaceable>H</replaceable><literal>;</literal>-	where <replaceable>D</replaceable> and <replaceable>H</replaceable>-	are decimal and hexadecimal numbers denoting a code position-	in Unicode (or ISO 10646).  For example, the references-	<literal>&amp;#x3BB;</literal>, <literal>&amp;#x3bb;</literal>-	and <literal>&amp;#955;</literal> all represent the lower-case-	letter lambda.</para>-      </section>--      <section>-	<title>Code Blocks</title>--	<para>Displayed blocks of code are indicated by surrounding a-	paragraph with <literal>@...@</literal> or by preceding each-	line of a paragraph with <literal>&gt;</literal> (we often-	call these &ldquo;bird tracks&rdquo;).  For-	example:</para>--<programlisting>--- | This documentation includes two blocks of code:------ @---     f x = x + x--- @------ &gt;  g x = x * 42-</programlisting>--	<para>There is an important difference between the two forms-        of code block: in the bird-track form, the text to the right-        of the &lsquo;<literal>></literal>&rsquo; is interpreted-        literally, whereas the <literal>@...@</literal> form-        interprets markup as normal inside the code block.</para>-      </section>--      <section>-	<title>Examples</title>--	<para> Haddock has markup support for examples of interaction with a-  <emphasis>read-eval-print loop (REPL)</emphasis>.  An-	example is introduced with-	<literal>&gt;&gt;&gt;</literal> followed by an expression followed-	by zero or more result lines:</para>--<programlisting>--- | Two examples are given below:------ &gt;&gt;&gt; fib 10--- 55------ &gt;&gt;&gt; putStrLn "foo\nbar"--- foo--- bar-</programlisting>-	<para>Result lines that only contain the string-	<literal>&lt;BLANKLINE&gt;</literal> are rendered as blank lines in the-	generated documentation.</para>-      </section>--      <section>-	<title>Properties</title>-        <para>-          Haddock provides markup for properties:-<programlisting>--- | Addition is commutative:------ prop> a + b = b + a-</programlisting>-          This allows third-party applications to extract and verify them.-        </para>-      </section>--      <section>-	<title>Hyperlinked Identifiers</title>--	<para>Referring to a Haskell identifier, whether it be a type,-	class, constructor, or function, is done by surrounding it-	with single quotes:</para>--<programlisting>--- | This module defines the type 'T'.-</programlisting>--	<para>If there is an entity <literal>T</literal> in scope in-	the current module, then the documentation will hyperlink the-	reference in the text to the definition of-	<literal>T</literal> (if the output format supports-	hyperlinking, of course; in a printed format it might instead-	insert a page reference to the definition).</para>--	<para>It is also possible to refer to entities that are not in-	scope in the current module, by giving the full qualified name-	of the entity:</para>--<programlisting>--- | The identifier 'M.T' is not in scope-</programlisting>--	<para>If <literal>M.T</literal> is not otherwise in scope,-	then Haddock will simply emit a link pointing to the entity-	<literal>T</literal> exported from module <literal>M</literal>-	(without checking to see whether either <literal>M</literal>-	or <literal>M.T</literal> exist).</para>--	<para>To make life easier for documentation writers, a quoted-	identifier is only interpreted as such if the quotes surround-	a lexically valid Haskell identifier.  This means, for-	example, that it normally isn't necessary to escape the single-	quote when used as an apostrophe:</para>--<programlisting>--- | I don't have to escape my apostrophes; great, isn't it?-</programlisting>--	<para>For compatibility with other systems, the following-	alternative form of markup is accepted<footnote><para>-	We chose not to use this as the primary markup for-	identifiers because strictly speaking the <literal>`</literal>-	character should not be used as a left quote, it is a grave accent.</para>-	  </footnote>: <literal>`T'</literal>.</para>-      </section>--      <section>-	<title>Emphasis, Bold and Monospaced text</title>--	<para>Emphasis may be added by surrounding text with-	<literal>/.../</literal>. Other markup is valid inside emphasis. To have a forward-        slash inside of emphasis, just escape it: <literal>/fo\/o/</literal></para>--        <para>Bold (strong) text is indicated by surrounding it with <literal>__...__</literal>.-        Other markup is valid inside bold. For example, <literal>__/foo/__</literal> will make the emphasised-        text <literal>foo</literal> bold. You don't have to escape a single underscore if you need it bold:-        <literal>__This_text_with_underscores_is_bold__</literal>.-        </para>--	<para>Monospaced (or typewriter) text is indicated by-	surrounding it with <literal>@...@</literal>.  Other markup is-	valid inside a monospaced span: for example-	<literal>@'f'&nbsp;a&nbsp;b@</literal> will hyperlink the-	identifier <literal>f</literal> inside the code fragment.</para>-      </section>--      <section>-	<title>Linking to modules</title>--	<para>Linking to a module is done by surrounding the module-	name with double quotes:</para>--<programlisting>--- | This is a reference to the "Foo" module.-</programlisting>--        <para>A basic check is done on the syntax of the header name to ensure that it is valid-        before turning it into a link but unlike with identifiers, whether the module is in scope isn't checked-        and will always be turned into a link.-        </para>--      </section>--      <section>-	<title>Itemized and Enumerated lists</title>--	<para>A bulleted item is represented by preceding a paragraph-	with either <quote><literal>*</literal></quote> or-	<quote><literal>-</literal></quote>.  A sequence of bulleted-	paragraphs is rendered as an itemized list in the generated-	documentation, eg.:</para>--<programlisting>--- | This is a bulleted list:------     * first item------     * second item-</programlisting>--	<para>An enumerated list is similar, except each paragraph-	must be preceded by either-	<quote><literal>(<replaceable>n</replaceable>)</literal></quote>-	or-	<quote><literal><replaceable>n</replaceable>.</literal></quote>-	where <replaceable>n</replaceable> is any integer.  e.g.</para>--<programlisting>--- | This is an enumerated list:------     (1) first item------     2. second item-</programlisting>--      <para>Lists of the same type don't have to be separated by a newline:</para>-<programlisting>--- | This is an enumerated list:------     (1) first item---     2. second item------ This is a bulleted list:------     * first item---     * second item-</programlisting>--      <para>You can have more than one line of content in a list element:-      </para>-<programlisting>--- |--- * first item--- and more content for the first item--- * second item--- and more content for the second item-</programlisting>--     <para>You can even nest whole paragraphs inside of list elements. The rules-     are 4 spaces for each indentation level. You're required to use a newline before-     such nested paragraph:-     </para>-<programlisting>-{-|-* Beginning of list-This belongs to the list above!--    > nested-    > bird-    > tracks--    * Next list-    More of the indented list.--        * Deeper--            @-            even code blocks work-            @--            * Deeper--                    1. Even deeper!-                    2. No newline separation even in indented lists.--}-</programlisting>--      </section>--      <section>-	<title>Definition lists</title>--	<para>Definition lists are written as follows:</para>--<programlisting>--- | This is a definition list:------   [@foo@] The description of @foo@.------   [@bar@] The description of @bar@.-</programlisting>--	<para>To produce output something like this:</para>--	<variablelist>-	  <varlistentry>-	    <term><literal>foo</literal></term>-	    <listitem>-	      <para>The description of <literal>foo</literal>.</para>-	    </listitem>-	  </varlistentry>-	  <varlistentry>-	    <term><literal>bar</literal></term>-	    <listitem>-	      <para>The description of <literal>bar</literal>.</para>-	    </listitem>-	  </varlistentry>-	</variablelist>--	<para>Each paragraph should be preceded by the-	&ldquo;definition term&rdquo; enclosed in square brackets.-	The square bracket characters have no special meaning outside-	the beginning of a definition paragraph.  That is, if a-	paragraph begins with a <literal>[</literal> character, then-	it is assumed to be a definition paragraph, and the next-	<literal>]</literal> character found will close the definition-	term.  Other markup operators may be used freely within the-	definition term. You can escape <literal>]</literal> with a backslash as usual.</para>--      <para>Same rules about nesting and no newline separation as for bulleted and numbered lists apply.-      </para>--      </section>--      <section>-	<title>URLs</title>--	<para>A URL can be included in a documentation comment by-	surrounding it in angle brackets:-	<literal>&lt;...&gt;</literal>.  If the output format supports-	it, the URL will be turned into a hyperlink when-	rendered.</para>--        <para>The URL can be followed by an optional label:</para>-<programlisting>-&lt;http://example.com label&gt;-</programlisting>-      <para>The label is then used as a descriptive text for the hyperlink, if the-        output format supports it.</para>--      <para>If Haddock sees something that looks like a URL (such as something starting with-      <literal>http://</literal> or <literal>ssh://</literal>) where the URL markup is valid,-      it will automatically make it a hyperlink.</para>-      </section>--      <section>-	<title>Images</title>--	<para>An image can be included in a documentation comment by-	surrounding it in double angle brackets:-	<literal>&lt;&lt;...&gt;&gt;</literal>.  If the output format supports-	it, the image will be rendered inside the documentation.</para>--        <para>Title text can be included using an optional label:</para>-<programlisting>-&lt;&lt;pathtoimage.png title&gt;&gt;-</programlisting>--      </section>--      <section>-	<title>Anchors</title>--	<para>Sometimes it is useful to be able to link to a point in-	the documentation which doesn't correspond to a particular-	entity.  For that purpose, we allow <emphasis>anchors</emphasis> to be-	included in a documentation comment.  The syntax is-	<literal>#<replaceable>label</replaceable>#</literal>, where-	<replaceable>label</replaceable> is the name of the anchor.-	An anchor is invisible in the generated documentation.</para>--	<para>To link to an anchor from elsewhere, use the syntax-	<literal>"<replaceable>module</replaceable>#<replaceable>label</replaceable>"</literal>-	where <replaceable>module</replaceable> is the module name-	containing the anchor, and <replaceable>label</replaceable> is-	the anchor label. The module does not have to be local, it can-	be imported via an interface. Please note that in Haddock-	versions 2.13.x and earlier, the syntax was-	<literal>"<replaceable>module</replaceable>\#<replaceable>label</replaceable>"</literal>.-	This is deprecated as of version 2.14.3 and will be removed in-	future versions.</para>-      </section>--      <section>-	<title>Headings</title>+      <para>This document describes Haddock version 2.15.0, a Haskell+      documentation tool.</para>+    </abstract>+  </bookinfo>++  <!-- Table of contents -->+  <toc></toc>++  <chapter id="introduction">+    <title>Introduction</title>++    <para>This is Haddock, a tool for automatically generating+    documentation from annotated Haskell source code.  Haddock was+    designed with several goals in mind:</para>++    <itemizedlist>+      <listitem>+        <para>When documenting APIs, it is desirable to keep the+        documentation close to the actual interface or implementation+        of the API, preferably in the same file, to reduce the risk+        that the two become out of sync.  Haddock therefore lets you+        write the documentation for an entity (function, type, or+        class) next to the definition of the entity in the source+        code.</para>+      </listitem>+      <listitem>+        <para>There is a tremendous amount of useful API documentation+        that can be extracted from just the bare source code,+        including types of exported functions, definitions of data+        types and classes, and so on.  Haddock can therefore generate+        documentation from a set of straight Haskell 98 modules, and+        the documentation will contain precisely the interface that is+        available to a programmer using those modules.</para>+      </listitem>+      <listitem>+        <para>Documentation annotations in the source code should be+        easy on the eye when editing the source code itself, so as not+        to obscure the code and to make reading and writing+        documentation annotations easy.  The easier it is to write+        documentation, the more likely the programmer is to do it.+        Haddock therefore uses lightweight markup in its annotations,+        taking several ideas from <ulink+        url="http://www.cse.unsw.edu.au/~chak/haskell/idoc/">IDoc</ulink>.+        In fact, Haddock can understand IDoc-annotated source+        code.</para>+      </listitem>+      <listitem>+        <para>The documentation should not expose any of the structure+        of the implementation, or to put it another way, the+        implementer of the API should be free to structure the+        implementation however he or she wishes, without exposing any+        of that structure to the consumer.  In practical terms, this+        means that while an API may internally consist of several+        Haskell modules, we often only want to expose a single module+        to the user of the interface, where this single module just+        re-exports the relevant parts of the implementation+        modules.</para>++        <para>Haddock therefore understands the Haskell module system+        and can generate documentation which hides not only+        non-exported entities from the interface, but also the+        internal module structure of the interface.  A documentation+        annotation can still be placed next to the implementation, and+        it will be propagated to the external module in the generated+        documentation.</para>+      </listitem>+      <listitem>+        <para>Being able to move around the documentation by following+        hyperlinks is essential.  Documentation generated by Haddock+        is therefore littered with hyperlinks: every type and class+        name is a link to the corresponding definition, and+        user-written documentation annotations can contain identifiers+        which are linked automatically when the documentation is+        generated.</para>+      </listitem>+      <listitem>+        <para>We might want documentation in multiple formats - online+        and printed, for example.  Haddock comes with HTML, LaTeX,+  and Hoogle backends, and it is structured in such a way that adding new+        backends is straightforward.</para>+      </listitem>+    </itemizedlist>++    <section id="obtaining">+      <title>Obtaining Haddock</title>++      <para>Distributions (source &amp; binary) of Haddock can be obtained+      from its <ulink url="http://www.haskell.org/haddock/">web+      site</ulink>.</para>++      <para>Up-to-date sources can also be obtained from our public+      darcs repository.  The Haddock sources are at+      <literal>http://code.haskell.org/haddock</literal>.  See+      <ulink url="http://www.darcs.net/">darcs.net</ulink> for more+      information on the darcs version control utility.</para>+    </section>++    <section id="license">+      <title>License</title>++      <para>The following license covers this documentation, and the+      Haddock source code, except where otherwise indicated.</para>++      <blockquote>+        <para>Copyright 2002-2010, Simon Marlow.  All rights reserved.</para>++        <para>Redistribution and use in source and binary forms, with+        or without modification, are permitted provided that the+        following conditions are met:</para>++        <itemizedlist>+          <listitem>+            <para>Redistributions of source code must retain the above+            copyright notice, this list of conditions and the+            following disclaimer.</para>+          </listitem>+          <listitem>+            <para>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.</para>+          </listitem>+        </itemizedlist>++        <para>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.</para>+      </blockquote>+    </section>++    <section>+      <title>Contributors</title>+      <para>Haddock was originally written by Simon Marlow. Since it is an open source+      project, many people have contributed to its development over the years.+      Below is a list of contributors in alphabetical order that we hope is+      somewhat complete. If you think you are missing from this list, please contact+      us.+      </para>+      <itemizedlist>+        <listitem><simpara>Ashley Yakeley</simpara></listitem>+        <listitem><simpara>Benjamin Franksen</simpara></listitem>+        <listitem><simpara>Brett Letner</simpara></listitem>+        <listitem><simpara>Clemens Fruhwirth</simpara></listitem>+        <listitem><simpara>Conal Elliott</simpara></listitem>+        <listitem><simpara>David Waern</simpara></listitem>+        <listitem><simpara>Duncan Coutts</simpara></listitem>+        <listitem><simpara>George Pollard</simpara></listitem>+        <listitem><simpara>George Russel</simpara></listitem>+        <listitem><simpara>Hal Daume</simpara></listitem>+        <listitem><simpara>Ian Lynagh</simpara></listitem>+        <listitem><simpara>Isaac Dupree</simpara></listitem>+        <listitem><simpara>Joachim Breitner</simpara></listitem>+        <listitem><simpara>Krasimir Angelov</simpara></listitem>+        <listitem><simpara>Lennart Augustsson</simpara></listitem>+        <listitem><simpara>Luke Plant</simpara></listitem>+        <listitem><simpara>Malcolm Wallace</simpara></listitem>+        <listitem><simpara>Manuel Chakravarty</simpara></listitem>+        <listitem><simpara>Mark Lentczner</simpara></listitem>+        <listitem><simpara>Mark Shields</simpara></listitem>+        <listitem><simpara>Mateusz Kowalczyk</simpara></listitem>+        <listitem><simpara>Mike Thomas</simpara></listitem>+        <listitem><simpara>Neil Mitchell</simpara></listitem>+        <listitem><simpara>Oliver Brown</simpara></listitem>+        <listitem><simpara>Roman Cheplyaka</simpara></listitem>+        <listitem><simpara>Ross Paterson</simpara></listitem>+        <listitem><simpara>Sigbjorn Finne</simpara></listitem>+        <listitem><simpara>Simon Hengel</simpara></listitem>+        <listitem><simpara>Simon Marlow</simpara></listitem>+        <listitem><simpara>Simon Peyton-Jones</simpara></listitem>+        <listitem><simpara>Stefan O'Rear</simpara></listitem>+        <listitem><simpara>Sven Panne</simpara></listitem>+        <listitem><simpara>Thomas Schilling</simpara></listitem>+        <listitem><simpara>Wolfgang Jeltsch</simpara></listitem>+        <listitem><simpara>Yitzchak Gale</simpara></listitem>+      </itemizedlist>+    </section>+    <section>+      <title>Acknowledgements</title>++      <para>Several documentation systems provided the inspiration for+      Haddock, most notably:</para>++      <itemizedlist>+        <listitem>+          <para><ulink+          url="http://www.cse.unsw.edu.au/~chak/haskell/idoc/">+          IDoc</ulink></para>+        </listitem>+        <listitem>+          <para><ulink+          url="http://www.fmi.uni-passau.de/~groessli/hdoc/">HDoc</ulink></para>+        </listitem>+        <listitem>+          <para><ulink url="http://www.stack.nl/~dimitri/doxygen/">+          Doxygen</ulink></para>+        </listitem>+      </itemizedlist>++      <para>and probably several others I've forgotten.</para>++      <para>Thanks to the the members+      of <email>haskelldoc@haskell.org</email>,+      <email>haddock@projects.haskell.org</email> and everyone who+      contributed to the many libraries that Haddock makes use+      of.</para>+    </section>++  </chapter>++  <chapter id="invoking">+    <title>Invoking Haddock</title>+    <para>Haddock is invoked from the command line, like so:</para>++    <cmdsynopsis>+      <command>haddock</command>+      <arg rep="repeat"><replaceable>option</replaceable></arg>+      <arg rep="repeat" choice="plain"><replaceable>file</replaceable></arg>+    </cmdsynopsis>++    <para>Where each <replaceable>file</replaceable> is a filename+    containing a Haskell source module (.hs) or a Literate Haskell source+    module (.lhs) or just a module name.</para>++    <para>All the modules specified on the command line will be+    processed together.  When one module refers to an entity in+    another module being processed, the documentation will link+    directly to that entity.</para>++    <para>Entities that cannot be found, for example because they are+    in a module that isn't being processed as part of the current+    batch, simply won't be hyperlinked in the generated+    documentation.  Haddock will emit warnings listing all the+    identifiers it couldn't resolve.</para>++    <para>The modules should <emphasis>not</emphasis> be mutually+    recursive, as Haddock don't like swimming in circles.</para>++    <para>Note that while older version would fail on invalid markup, this is considered a bug in the+    new versions. If you ever get failed parsing message, please report it.</para>++    <para>You must also specify an option for the output format.+    Currently only the <option>-h</option> option for HTML and the+    <option>--hoogle</option> option for outputting Hoogle data are+    functional.</para>++    <para>The packaging+    tool <ulink url="http://www.haskell.org/ghc/docs/latest/html/Cabal/index.html">Cabal</ulink>+    has Haddock support, and is often used instead of invoking Haddock+    directly.</para>++    <para>The following options are available:</para>++    <variablelist>++      <varlistentry>+        <term>+          <indexterm><primary><option>-B</option></primary></indexterm>+          <option>-B</option> <replaceable>dir</replaceable>+        </term>+        <listitem>+          <para>Tell GHC that that its lib directory is+    <replaceable>dir</replaceable>. Can be used to override the default path.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-o</option></primary></indexterm>+          <option>-o</option> <replaceable>dir</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--odir</option></primary></indexterm>+          <option>--odir</option>=<replaceable>dir</replaceable>+        </term>+        <listitem>+          <para>Generate files into <replaceable>dir</replaceable>+          instead of the current directory.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-l</option></primary></indexterm>+          <option>-l</option> <replaceable>dir</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--lib</option></primary></indexterm>+          <option>--lib</option>=<replaceable>dir</replaceable>+        </term>+        <listitem>+          <para>Use Haddock auxiliary files (themes, javascript, etc...) in <replaceable>dir</replaceable>.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-i</option></primary></indexterm>+          <option>-i</option> <replaceable>path</replaceable>,<replaceable>file</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--read-interface</option></primary></indexterm>+          <option>--read-interface</option>=<replaceable>path</replaceable>,<replaceable>file</replaceable>+        </term>+        <listitem>+          <para>Read the interface file in+          <replaceable>file</replaceable>, which must have been+          produced by running Haddock with the+          <option>--dump-interface</option> option.  The interface+          describes a set of modules whose HTML documentation is+          located in <replaceable>path</replaceable> (which may be a+          relative pathname).  The <replaceable>path</replaceable> is+          optional, and defaults to <quote>.</quote>.</para>++          <para>This option allows Haddock to produce separate sets of+          documentation with hyperlinks between them.  The+          <replaceable>path</replaceable> is used to direct hyperlinks+          to point to the right files; so make sure you don't move the+          HTML files later or these links will break.  Using a+          relative <replaceable>path</replaceable> means that a+          documentation subtree can still be moved around without+          breaking links.</para>++          <para>Multiple <option>--read-interface</option> options may+          be given.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-D</option></primary></indexterm>+          <option>-D</option> <replaceable>file</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--dump-interface</option></primary></indexterm>+          <option>--dump-interface</option>=<replaceable>file</replaceable>+        </term>+        <listitem>+          <para>Produce an <firstterm>interface+          file</firstterm><footnote><para>Haddock interface files are+          not the same as Haskell interface files, I just couldn't+          think of a better name.</para> </footnote>+          in the file <replaceable>file</replaceable>.  An interface+          file contains information Haddock needs to produce more+          documentation that refers to the modules currently being+          processed - see the <option>--read-interface</option> option+          for more details.  The interface file is in a binary format;+          don't try to read it.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-h</option></primary></indexterm>+          <option>-h</option>+        </term>+        <term>+          <indexterm><primary><option>--html</option></primary></indexterm>+          <option>--html</option>+        </term>+        <listitem>+          <para>Generate documentation in HTML format.  Several files+          will be generated into the current directory (or the+          specified directory if the <option>-o</option> option is+          given), including the following:</para>+          <variablelist>+            <varlistentry>+              <term><filename><replaceable>module</replaceable>.html</filename></term>+              <term><filename>mini_<replaceable>module</replaceable>.html</filename></term>+              <listitem>+                <para>An HTML page for each+                <replaceable>module</replaceable>, and a "mini" page for+                each used when viewing in frames.</para>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename>index.html</filename></term>+              <listitem>+                <para>The top level page of the documentation: lists+                the modules available, using indentation to represent+                the hierarchy if the modules are hierarchical.</para>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename>doc-index.html</filename></term>+              <term><filename>doc-index-<replaceable>X</replaceable>.html</filename></term>+              <listitem>+                <para>The alphabetic index, possibly split into multiple+                pages if big enough.</para>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename>frames.html</filename></term>+              <listitem>+                <para>The top level document when viewing in frames.</para>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename><replaceable>some</replaceable>.css</filename></term>+              <term><filename><replaceable>etc...</replaceable></filename></term>+              <listitem>+                <para>Files needed for the themes used. Specify your themes+                using the <option>--theme</option> option.</para>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename>haddock-util.js</filename></term>+              <listitem>+                <para>Some JavaScript utilities used to implement some of the+                dynamic features like collapsible sections, and switching to+                frames view.</para>+              </listitem>+            </varlistentry>+          </variablelist>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--latex</option></primary></indexterm>+          <option>--latex</option>+        </term>+        <listitem>+          <para>Generate documentation in LaTeX format.  Several files+          will be generated into the current directory (or the+            specified directory if the <option>-o</option> option is+            given), including the following:</para>++          <variablelist>+            <varlistentry>+              <term><filename><replaceable>package</replaceable>.tex</filename></term>+              <listitem>+                <para>The top-level LaTeX source file; to format the+                documentation into PDF you might run something like+                  this:</para>+<screen>+$ pdflatex <replaceable>package</replaceable>.tex</screen>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename>haddock.sty</filename></term>+              <listitem>+                <para>The default style.  The file contains+                definitions for various macros used in the LaTeX+                sources generated by Haddock; to change the way the+                formatted output looks, you might want to override+                these by specifying your own style with+                the <option>--latex-style</option> option.</para>+              </listitem>+            </varlistentry>+            <varlistentry>+              <term><filename><replaceable>module</replaceable>.tex</filename></term>+              <listitem>+                <para>The LaTeX documentation for+                each <replaceable>module</replaceable>.</para>+              </listitem>+            </varlistentry>+          </variablelist>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--latex-style</option></primary></indexterm>+          <option>--latex-style=<replaceable>style</replaceable></option>+        </term>+        <listitem>+          <para>This option lets you override the default style used+            by the LaTeX generated by the <option>--latex</option> option.+            Normally Haddock puts a+            standard <filename>haddock.sty</filename> in the output+            directory, and includes the+            command <literal>\usepackage{haddock}</literal> in the+            LaTeX source.  If this option is given,+            then <filename>haddock.sty</filename> is not generated,+            and the command is+            instead <literal>\usepackage{<replaceable>style</replaceable>}</literal>.+          </para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-S</option></primary></indexterm>+          <option>-S</option>+        </term>+        <term>+          <indexterm><primary><option>--docbook</option></primary></indexterm>+          <option>--docbook</option>+        </term>+        <listitem>+          <para>Reserved for future use (output documentation in DocBook XML+          format).</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--source-base</option></primary></indexterm>+          <option>--source-base</option>=<replaceable>URL</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--source-module</option></primary></indexterm>+          <option>--source-module</option>=<replaceable>URL</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--source-entity</option></primary></indexterm>+          <option>--source-entity</option>=<replaceable>URL</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--source-entity-line</option></primary></indexterm>+          <option>--source-entity-line</option>=<replaceable>URL</replaceable>+        </term>+        <listitem>+          <para>Include links to the source files in the generated+          documentation. Use the <option>--source-base</option> option to add a+          source code link in the header bar of the contents and index pages.+          Use the <option>--source-module</option> to add a source code link in+          the header bar of each module page. Use the+          <option>--source-entity</option> option to add a source code link+          next to the documentation for every value and type in each module.+          <option>--source-entity-line</option> is a flag that gets used for+          entities that need to link to an exact source location rather than a+          name, eg. since they were defined inside a Template Haskell splice.+          </para>++          <para>In each case <replaceable>URL</replaceable> is the base URL+          where the source files can be found.  For the per-module and+          per-entity URLs, the following substitutions are made within the+          string <replaceable>URL</replaceable>:</para>++          <itemizedlist>+            <listitem>+              <para>The string <literal>%M</literal> or <literal>%{MODULE}</literal>+              is replaced by the module name. Note that for the per-entity URLs+              this is the name of the <emphasis>exporting</emphasis> module.</para>+            </listitem>+            <listitem>+              <para>The string <literal>%F</literal> or <literal>%{FILE}</literal>+              is replaced by the original source file name. Note that for the+              per-entity URLs this is the name of the <emphasis>defining</emphasis>+              module.</para>+            </listitem>+            <listitem>+              <para>The string <literal>%N</literal> or <literal>%{NAME}</literal>+              is replaced by the name of the exported value or type. This is+              only valid for the <option>--source-entity</option> option.</para>+            </listitem>+            <listitem>+              <para>The string <literal>%K</literal> or <literal>%{KIND}</literal>+              is replaced by a flag indicating whether the exported name is a value+              '<literal>v</literal>' or a type '<literal>t</literal>'. This is+              only valid for the <option>--source-entity</option> option.</para>+            </listitem>+            <listitem>+              <para>The string <literal>%L</literal> or <literal>%{LINE}</literal>+              is replaced by the number of the line where the exported value or+              type is defined. This is only valid for the+              <option>--source-entity</option> option.</para>+            </listitem>+            <listitem>+              <para>The string <literal>%%</literal> is replaced by+              <literal>%</literal>.</para>+      </listitem>++          </itemizedlist>++          <para>For example, if your sources are online under some directory,+          you would say+          <literal>haddock --source-base=<replaceable>url</replaceable>/+          --source-module=<replaceable>url</replaceable>/%F</literal></para>++          <para>If you have html versions of your sources online with anchors+          for each type and function name, you would say+          <literal>haddock --source-base=<replaceable>url</replaceable>/+          --source-module=<replaceable>url</replaceable>/%M.html+          --source-entity=<replaceable>url</replaceable>/%M.html#%N</literal></para>++          <para>For the <literal>%{MODULE}</literal> substitution you may want to+          replace the '<literal>.</literal>' character in the module names with+          some other character (some web servers are known to get confused by+          multiple '<literal>.</literal>' characters in a file name). To+          replace it with a character <replaceable>c</replaceable> use+          <literal>%{MODULE/./<replaceable>c</replaceable>}</literal>.</para>++          <para>Similarly, for the <literal>%{FILE}</literal> substitution+          you may want to replace the '<literal>/</literal>' character in+          the file names with some other character (especially for links+          to colourised entity source code with a shared css file).  To replace+          it with a character <replaceable>c</replaceable> use+          <literal>%{FILE///<replaceable>c</replaceable>}</literal>/</para>++          <para>One example of a tool that can generate syntax-highlighted+          HTML from your source code, complete with anchors suitable for use+          from haddock, is+          <ulink url="http://www.cs.york.ac.uk/fp/darcs/hscolour">hscolour</ulink>.</para>++        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-s</option></primary></indexterm>+          <option>-s</option> <replaceable>URL</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--source</option></primary></indexterm>+          <option>--source</option>=<replaceable>URL</replaceable>+        </term>+        <listitem>+          <para>Deprecated aliases for <option>--source-module</option></para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--comments-base</option></primary></indexterm>+          <option>--comments-base</option>=<replaceable>URL</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--comments-module</option></primary></indexterm>+          <option>--comments-module</option>=<replaceable>URL</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--comments-entity</option></primary></indexterm>+          <option>--comments-entity</option>=<replaceable>URL</replaceable>+        </term>+        <listitem>+          <para>Include links to pages where readers may comment on the+          documentation. This feature would typically be used in conjunction+          with a Wiki system.</para>++          <para>Use the <option>--comments-base</option> option to add a+          user comments link in the header bar of the contents and index pages.+          Use the <option>--comments-module</option> to add a user comments+          link in the header bar of each module page. Use the+          <option>--comments-entity</option> option to add a comments link+          next to the documentation for every value and type in each module.+          </para>++          <para>In each case <replaceable>URL</replaceable> is the base URL+          where the corresponding comments page can be found.  For the+          per-module and per-entity URLs the same substitutions are made as+          with the <option>--source-module</option> and+          <option>--source-entity</option> options above.</para>++          <para>For example, if you want to link the contents page to a wiki+          page, and every module to subpages, you would say+          <literal>haddock --comments-base=<replaceable>url</replaceable>+          --comments-module=<replaceable>url</replaceable>/%M</literal></para>++          <para>If your Wiki system doesn't like the '<literal>.</literal>' character+          in Haskell module names, you can replace it with a different character. For+          example to replace the '<literal>.</literal>' characters with+          '<literal>_</literal>' use <literal>haddock+          --comments-base=<replaceable>url</replaceable>+          --comments-module=<replaceable>url</replaceable>/%{MODULE/./_}</literal>+          Similarly, you can replace the '<literal>/</literal>' in a file name (may+          be useful for entity comments, but probably not.) </para>++        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--theme</option></primary></indexterm>+          <option>--theme</option>=<replaceable>path</replaceable>+        </term>+        <listitem>+          <para>Specify a theme to be used for HTML (<option>--html</option>)+          documentation. If given multiple times then the pages will use the+          first theme given by default, and have alternate style sheets for+          the others. The reader can switch between themes with browsers that+          support alternate style sheets, or with the "Style" menu that gets+          added when the page is loaded. If+          no themes are specified, then just the default built-in theme+          ("Ocean") is used.+          </para>++          <para>The <replaceable>path</replaceable> parameter can be one of:+          </para>++          <itemizedlist>+            <listitem>+              <para>A <emphasis>directory</emphasis>: The base name of+              the directory becomes the name of the theme. The directory+              must contain exactly one+              <filename><replaceable>some</replaceable>.css</filename> file.+              Other files, usually image files, will be copied, along with+              the <filename><replaceable>some</replaceable>.css</filename>+              file, into the generated output directory.</para>+            </listitem>+            <listitem>+              <para>A <emphasis>CSS file</emphasis>: The base name of+              the file becomes the name of the theme.</para>+            </listitem>+            <listitem>+              <para>The <emphasis>name</emphasis> of a built-in theme+              ("Ocean" or "Classic").</para>+            </listitem>+          </itemizedlist>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--built-in-themes</option></primary></indexterm>+          <option>--built-in-themes</option>+        </term>+        <listitem>+          <para>Includes the built-in themes ("Ocean" and "Classic").+          Can be combined with <option>--theme</option>. Note that order+          matters: The first specified theme will be the default.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-c</option></primary></indexterm>+          <option>-c</option> <replaceable>file</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--css</option></primary></indexterm>+          <option>--css</option>=<replaceable>file</replaceable>+        </term>+        <listitem>+          <para>Deprecated aliases for <option>--theme</option></para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-p</option></primary></indexterm>+          <option>-p</option> <replaceable>file</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--prologue</option></primary></indexterm>+          <option>--prologue</option>=<replaceable>file</replaceable>+        </term>+        <listitem>+          <para>Specify a file containing documentation which is+          placed on the main contents page under the heading+          &ldquo;Description&rdquo;.  The file is parsed as a normal+          Haddock doc comment (but the comment markers are not+          required).</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-t</option></primary></indexterm>+          <option>-t</option> <replaceable>title</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--title</option></primary></indexterm>+          <option>--title</option>=<replaceable>title</replaceable>+        </term>+        <listitem>+          <para>Use <replaceable>title</replaceable> as the page+          heading for each page in the documentation.This will+          normally be the name of the library being documented.</para>++          <para>The title should be a plain string (no markup+          please!).</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-q</option></primary></indexterm>+          <option>-q</option> <replaceable>mode</replaceable>+        </term>+        <term>+          <indexterm><primary><option>--qual</option></primary></indexterm>+          <option>--qual</option>=<replaceable>mode</replaceable>+        </term>+        <listitem>+            <para>+                Specify how identifiers are qualified.+            </para>+            <para>+                <replaceable>mode</replaceable> should be one of+                <itemizedlist>+                    <listitem>+                        <para>none (default): don't qualify any identifiers</para>+                    </listitem>+                    <listitem>+                        <para>full: always qualify identifiers completely</para>+                    </listitem>+                    <listitem>+                        <para>local: only qualify identifiers that are not part+                            of the module</para>+                    </listitem>+                    <listitem>+                        <para>relative: like local, but strip name of the module+                            from qualifications of identifiers in submodules</para>+                    </listitem>+                </itemizedlist>+            </para>+            <para>+                Example: If you generate documentation for module A, then the+                identifiers A.x, A.B.y and C.z are qualified as follows.+            </para>+            <para>+                <itemizedlist>+                    <listitem>+                        <simpara>none: x, y, z</simpara>+                    </listitem>+                    <listitem>+                        <simpara>full: A.x, A.B.y, C.z</simpara>+                    </listitem>+                    <listitem>+                        <simpara>local: x, A.B.y, C.z</simpara>+                    </listitem>+                    <listitem>+                        <simpara>relative: x, B.y, C.z</simpara>+                    </listitem>+                </itemizedlist>+                </para>+            </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-?</option></primary></indexterm>+          <option>-?</option>+        </term>+        <term>+          <indexterm><primary><option>--help</option></primary></indexterm>+          <option>--help</option>+        </term>+        <listitem>+          <para>Display help and exit.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-V</option></primary></indexterm>+          <option>-V</option>+        </term>+        <term>+          <indexterm><primary><option>--version</option></primary></indexterm>+          <option>--version</option>+        </term>+        <listitem>+          <para>Output version information and exit.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-v</option></primary></indexterm>+          <option>-v</option>+        </term>+        <term>+          <indexterm><primary><option>--verbose</option></primary></indexterm>+          <option>--verbose</option>+        </term>+        <listitem>+          <para>Increase verbosity.  Currently this will cause Haddock+          to emit some extra warnings, in particular about modules+          which were imported but it had no information about (this is+          often quite normal; for example when there is no information+          about the <literal>Prelude</literal>).</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--use-contents</option></primary></indexterm>+          <option>--use-contents=<replaceable>URL</replaceable></option>+        </term>+        <term>+          <indexterm><primary><option>--use-index</option></primary></indexterm>+          <option>--use-index=<replaceable>URL</replaceable></option>+        </term>+        <listitem>+          <para>When generating HTML, do not generate an index.+          Instead, redirect the Contents and/or Index link on each page to+          <replaceable>URL</replaceable>.  This option is intended for+          use in conjunction with <option>--gen-contents</option> and/or+          <option>--gen-index</option> for+          generating a separate contents and/or index covering multiple+          libraries.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--gen-contents</option></primary></indexterm>+          <option>--gen-contents</option>+        </term>+        <term>+          <indexterm><primary><option>--gen-index</option></primary></indexterm>+          <option>--gen-index</option>+        </term>+        <listitem>+          <para>Generate an HTML contents and/or index containing entries pulled+          from all the specified interfaces (interfaces are specified using+          <option>-i</option> or <option>--read-interface</option>).+          This is used to generate a single contents and/or index for multiple+          sets of Haddock documentation.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--ignore-all-exports</option></primary>+          </indexterm>+          <option>--ignore-all-exports</option>+        </term>+        <listitem>+          <para>Causes Haddock to behave as if every module has the+            <literal>ignore-exports</literal> attribute (<xref+              linkend="module-attributes" />).  This might be useful for+            generating implementation documentation rather than interface+            documentation, for example.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--hide</option></primary>+          </indexterm>+          <option>--hide</option>&nbsp;<replaceable>module</replaceable>+        </term>+        <listitem>+          <para>Causes Haddock to behave as if module+            <replaceable>module</replaceable> has the <literal>hide</literal>+            attribute. (<xref linkend="module-attributes" />).</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--show-extensions</option></primary>+          </indexterm>+          <option>--show-extensions</option>&nbsp;<replaceable>module</replaceable>+        </term>+        <listitem>+          <para>Causes Haddock to behave as if module+            <replaceable>module</replaceable> has the <literal>show-extensions</literal>+            attribute. (<xref linkend="module-attributes" />).</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--optghc</option></primary></indexterm>+          <option>--optghc</option>=<replaceable>option</replaceable>+        </term>+        <listitem>+          <para>Pass <replaceable>option</replaceable> to GHC. Note that there is a double dash there, unlike for GHC.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>-w</option></primary></indexterm>+          <option>-w</option>+        </term>+        <term>+          <indexterm><primary><option>--no-warnings</option></primary></indexterm>+          <option>--no-warnings</option>+        </term>+        <listitem>+          <para>Turn off all warnings.</para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--compatible-interface-versions</option></primary></indexterm>+          <option>--compatible-interface-versions</option>+        </term>+        <listitem>+          <para>+            Prints out space-separated versions of binary Haddock interface files that this version is compatible+            with.+          </para>+        </listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--no-tmp-comp-dir</option></primary></indexterm>+          <option>--no-tmp-comp-dir</option>+        </term>+        <listitem>+          <para>+          Do not use a temporary directory for reading and writing compilation output files+          (<literal>.o</literal>, <literal>.hi</literal>, and stub files). Instead, use the+          present directory or another directory that you have explicitly told GHC to use+          via the <literal>--optghc</literal> flag.+          </para>+          <para>+          This flag can be used to avoid recompilation if compilation files already exist.+          Compilation files are produced when Haddock has to process modules that make use of+          Template Haskell, in which case Haddock compiles the modules using the GHC API.+          </para>+        </listitem>+      </varlistentry>+    </variablelist>++    <section id="cpp">+      <title>Using literate or pre-processed source</title>++      <para>Since Haddock uses GHC internally, both plain and+            literate Haskell sources are accepted without the need for the user+            to do anything. To use the C pre-processor, however,+            the user must pass the the <option>-cpp</option> option to GHC+            using <option>--optghc</option>.+      </para>+    </section>++  </chapter>++  <chapter id="markup">+    <title>Documentation and Markup</title>++    <para>Haddock understands special documentation annotations in the+    Haskell source file and propagates these into the generated+    documentation.  The annotations are purely optional: if there are+    no annotations, Haddock will just generate documentation that+    contains the type signatures, data type declarations, and class+    declarations exported by each of the modules being+    processed.</para>++    <section>+      <title>Documenting a top-level declaration</title>++      <para>The simplest example of a documentation annotation is for+      documenting any top-level declaration (function type signature,+      type declaration, or class declaration).  For example, if the+      source file contains the following type signature:</para>++<programlisting>+square :: Int -> Int+square x = x * x+</programlisting>++    <para>Then we can document it like this:</para>++<programlisting>+-- |The 'square' function squares an integer.+square :: Int -> Int+square x = x * x+</programlisting>+++      <para>The <quote><literal>-- |</literal></quote> syntax begins a+      documentation annotation, which applies to the+      <emphasis>following</emphasis> declaration in the source file.+      Note that the annotation is just a comment in Haskell &mdash; it+      will be ignored by the Haskell compiler.</para>++      <para>The declaration following a documentation annotation+      should be one of the following:</para>+      <itemizedlist>+        <listitem>+          <para>A type signature for a top-level function,</para>+        </listitem>+        <listitem>+          <para>A <literal>data</literal> declaration,</para>+        </listitem>+        <listitem>+          <para>A <literal>newtype</literal> declaration,</para>+        </listitem>+        <listitem>+          <para>A <literal>type</literal> declaration</para>+        </listitem>+        <listitem>+          <para>A <literal>class</literal> declaration,</para>+        </listitem>+        <listitem>+          <para>A <literal>data family</literal> or+            <literal>type family</literal> declaration, or</para>+        </listitem>+        <listitem>+          <para>A <literal>data instance</literal> or+            <literal>type instance</literal> declaration.</para>+        </listitem>+      </itemizedlist>++      <para>If the annotation is followed by a different kind of+      declaration, it will probably be ignored by Haddock.</para>++      <para>Some people like to write their documentation+      <emphasis>after</emphasis> the declaration; this is possible in+      Haddock too:</para>++<programlisting>+square :: Int -> Int+-- ^The 'square' function squares an integer.+square x = x * x+</programlisting>++      <para>Note that Haddock doesn't contain a Haskell type system+      &mdash; if you don't write the type signature for a function,+      then Haddock can't tell what its type is and it won't be+      included in the documentation.</para>++      <para>Documentation annotations may span several lines; the+      annotation continues until the first non-comment line in the+      source file.  For example:</para>++<programlisting>+-- |The 'square' function squares an integer.+-- It takes one argument, of type 'Int'.+square :: Int -> Int+square x = x * x+</programlisting>++      <para>You can also use Haskell's nested-comment style for+      documentation annotations, which is sometimes more convenient+      when using multi-line comments:</para>++<programlisting>+{-|+  The 'square' function squares an integer.+  It takes one argument, of type 'Int'.+-}+square :: Int -> Int+square x = x * x+</programlisting>++    </section>+    <section>+      <title>Documenting parts of a declaration</title>++      <para>In addition to documenting the whole declaration, in some+      cases we can also document individual parts of the+      declaration.</para>++      <section>+        <title>Class methods</title>++        <para>Class methods are documented in the same way as top+        level type signatures, by using either the+        <quote><literal>--&nbsp;|</literal></quote> or+        <quote><literal>--&nbsp;^</literal></quote>+        annotations:</para>++<programlisting>+class C a where+   -- | This is the documentation for the 'f' method+   f :: a -> Int+   -- | This is the documentation for the 'g' method+   g :: Int -> a+</programlisting>+      </section>++      <section>+        <title>Constructors and record fields</title>++        <para>Constructors are documented like so:</para>++<programlisting>+data T a b+  -- | This is the documentation for the 'C1' constructor+  = C1 a b+  -- | This is the documentation for the 'C2' constructor+  | C2 a b+</programlisting>++        <para>or like this:</para>++<programlisting>+data T a b+  = C1 a b  -- ^ This is the documentation for the 'C1' constructor+  | C2 a b  -- ^ This is the documentation for the 'C2' constructor+</programlisting>++        <para>Record fields are documented using one of these+        styles:</para>++<programlisting>+data R a b =+  C { -- | This is the documentation for the 'a' field+      a :: a,+      -- | This is the documentation for the 'b' field+      b :: b+    }++data R a b =+  C { a :: a  -- ^ This is the documentation for the 'a' field+    , b :: b  -- ^ This is the documentation for the 'b' field+    }+</programlisting>++        <para>Alternative layout styles are generally accepted by+        Haddock - for example doc comments can appear before or after+        the comma in separated lists such as the list of record fields+        above.</para>++        <para>In case that more than one constructor exports a field+        with the same name, the documentation attached to the first+        occurence of the field will be used, even if a comment is not+        present.+        </para>++<programlisting>+data T a = A { someField :: a -- ^ Doc for someField of A+             }+         | B { someField :: a -- ^ Doc for someField of B+             }+</programlisting>++        <para>In the above example, all occurences of+        <literal>someField</literal> in the documentation are going to+        be documented with <literal>Doc for someField of A</literal>.+        Note that Haddock versions 2.14.0 and before would join up+        documentation of each field and render the result. The reason+        for this seemingly weird behaviour is the fact that+        <literal>someField</literal> is actually the same (partial)+        function.</para>++      </section>++      <section>+        <title>Function arguments</title>++        <para>Individual arguments to a function may be documented+        like this:</para>++<programlisting>+f  :: Int      -- ^ The 'Int' argument+   -> Float    -- ^ The 'Float' argument+   -> IO ()    -- ^ The return value+</programlisting>+      </section>+    </section>++    <section>+      <title>The module description</title>++      <para>A module itself may be documented with multiple fields+      that can then be displayed by the backend. In particular, the+      HTML backend displays all the fields it currently knows+      about. We first show the most complete module documentation+      example and then talk about the fields.</para>++<programlisting>+{-|+Module      : W+Description : Short description+Copyright   : (c) Some Guy, 2013+                  Someone Else, 2014+License     : GPL-3+Maintainer  : sample@email.com+Stability   : experimental+Portability : POSIX++Here is a longer description of this module, containing some+commentary with @some markup@.+-}+module W where+...+</programlisting>++      <para>The <quote>Module</quote> field should be clear. It+      currently doesn't affect the output of any of the backends but+      you might want to include it for human information or for any+      other tools that might be parsing these comments without the+      help of GHC.</para>++      <para>The <quote>Description</quote> field accepts some short text+      which outlines the general purpose of the module. If you're+      generating HTML, it will show up next to the module link in+      the module index.</para>++      <para>The <quote>Copyright</quote>, <quote>License</quote>,+      <quote>Maintainer</quote> and <quote>Stability</quote> fields+      should be obvious. An alternative spelling for the+      <quote>License</quote> field is accepted as+      <quote>Licence</quote> but the output will always prefer+      <quote>License</quote>.</para>++      <para>The <quote>Portability</quote> field has seen varied use+      by different library authors. Some people put down things like+      operating system constraints there while others put down which GHC+      extensions are used in the module. Note that you might want to+      consider using the <quote>show-extensions</quote> module flag for the+      latter.</para>++      <para>Finally, a module may contain a documentation comment+      before the module header, in which case this comment is+      interpreted by Haddock as an overall description of the module+      itself, and placed in a section entitled+      <quote>Description</quote> in the documentation for the module.+      All usual Haddock markup is valid in this comment.</para>++      <para>All fields are optional but they must be in order if they+      do appear. Multi-line fields are accepted but the consecutive+      lines have to start indented more than their label. If your+      label is indented one space as is often the case with+      <quote>--</quote> syntax, the consecutive lines have to start at+      two spaces at the very least. Please note that we do not enforce+      the format for any of the fields and the established formats are+      just a convention.</para>++    </section>++    <section>+      <title>Controlling the documentation structure</title>++      <para>Haddock produces interface documentation that lists only+      the entities actually exported by the module.  The documentation+      for a module will include <emphasis>all</emphasis> entities+      exported by that module, even if they were re-exported by+      another module.  The only exception is when Haddock can't see+      the declaration for the re-exported entity, perhaps because it+      isn't part of the batch of modules currently being+      processed.</para>++      <para>However, to Haddock the export list has even more+      significance than just specifying the entities to be included in+      the documentation.  It also specifies the+      <emphasis>order</emphasis> that entities will be listed in the+      generated documentation.  This leaves the programmer free to+      implement functions in any order he/she pleases, and indeed in+      any <emphasis>module</emphasis> he/she pleases, but still+      specify the order that the functions should be documented in the+      export list.  Indeed, many programmers already do this: the+      export list is often used as a kind of ad-hoc interface+      documentation, with headings, groups of functions, type+      signatures and declarations in comments.</para>++      <para>You can insert headings and sub-headings in the+      documentation by including annotations at the appropriate point+      in the export list.  For example:</para>++<programlisting>+module Foo (+  -- * Classes+  C(..),+  -- * Types+  -- ** A data type+  T,+  -- ** A record+  R,+  -- * Some functions+  f, g+  ) where+</programlisting>++      <para>Headings are introduced with the syntax+      <quote><literal>--&nbsp;*</literal></quote>,+      <quote><literal>--&nbsp;**</literal></quote> and so on, where+      the number of <literal>*</literal>s indicates the level of the+      heading (section, sub-section, sub-sub-section, etc.).</para>++      <para>If you use section headings, then Haddock will generate a+      table of contents at the top of the module documentation for+      you.</para>++      <para>The alternative style of placing the commas at the+      beginning of each line is also supported. eg.:</para>++<programlisting>+module Foo (+  -- * Classes+  , C(..)+  -- * Types+  -- ** A data type+  , T+  -- ** A record+  , R+  -- * Some functions+  , f+  , g+  ) where+</programlisting>++      <section>+        <title>Re-exporting an entire module</title>++        <para>Haskell allows you to re-export the entire contents of a+        module (or at least, everything currently in scope that was+        imported from a given module) by listing it in the export+        list:</para>++<programlisting>+module A (+  module B,+  module C+ ) where+</programlisting>++        <para>What will the Haddock-generated documentation for this+        module look like?  Well, it depends on how the modules+        <literal>B</literal> and <literal>C</literal> are imported.+        If they are imported wholly and without any+        <literal>hiding</literal> qualifiers, then the documentation+        will just contain a cross-reference to the documentation for+        <literal>B</literal> and <literal>C</literal>.  However, if+        the modules are not <emphasis>completely</emphasis>+        re-exported, for example:</para>++<programlisting>+module A (+  module B,+  module C+ ) where++import B hiding (f)+import C (a, b)+</programlisting>++        <para>then Haddock behaves as if the set of entities+        re-exported from <literal>B</literal> and <literal>C</literal>+        had been listed explicitly in the export+        list<footnote><para>NOTE: this is not fully implemented at the+        time of writing (version 0.2).  At the moment, Haddock always+        inserts a cross-reference.</para>+          </footnote>.</para>++        <para>The exception to this rule is when the re-exported+        module is declared with the <literal>hide</literal> attribute+        (<xref linkend="module-attributes"/>), in which case the module+        is never cross-referenced; the contents are always expanded in+        place in the re-exporting module.</para>+      </section>++      <section>+        <title>Omitting the export list</title>++        <para>If there is no export list in the module, how does+        Haddock generate documentation?  Well, when the export list is+        omitted, e.g.:</para>++<programlisting>module Foo where</programlisting>++        <para>this is equivalent to an export list which mentions+        every entity defined at the top level in this module, and+        Haddock treats it in the same way.  Furthermore, the generated+        documentation will retain the order in which entities are+        defined in the module.  In this special case the module body+        may also include section headings (normally they would be+        ignored by Haddock).</para>++<programlisting>+module Foo where++-- * This heading will now appear before foo.++-- | Documentation for 'foo'.+foo :: Integer+foo = 5+</programlisting>++      </section>+    </section>++    <section>+      <title>Named chunks of documentation</title>++      <para>Occasionally it is desirable to include a chunk of+      documentation which is not attached to any particular Haskell+      declaration.  There are two ways to do this:</para>++      <itemizedlist>+        <listitem>+          <para>The documentation can be included in the export list+          directly, e.g.:</para>++<programlisting>+module Foo (+   -- * A section heading++   -- | Some documentation not attached to a particular Haskell entity+   ...+ ) where+</programlisting>+        </listitem>++        <listitem>+          <para>If the documentation is large and placing it inline in+          the export list might bloat the export list and obscure the+          structure, then it can be given a name and placed out of+          line in the body of the module.  This is achieved with a+          special form of documentation annotation+          <quote><literal>--&nbsp;$</literal></quote>:</para>++<programlisting>+module Foo (+   -- * A section heading++   -- $doc+   ...+ ) where++-- $doc+-- Here is a large chunk of documentation which may be referred to by+-- the name $doc.+</programlisting>++          <para>The documentation chunk is given a name, which is the+          sequence of alphanumeric characters directly after the+          <quote><literal>--&nbsp;$</literal></quote>, and it may be+          referred to by the same name in the export list.</para>+        </listitem>+      </itemizedlist>+    </section>++    <section id="hyperlinking">+      <title>Hyperlinking and re-exported entities</title>++      <para>When Haddock renders a type in the generated+      documentation, it hyperlinks all the type constructors and class+      names in that type to their respective definitions.  But for a+      given type constructor or class there may be several modules+      re-exporting it, and therefore several modules whose+      documentation contains the definition of that type or class+      (possibly including the current module!) so which one do we link+      to?</para>++      <para>Let's look at an example.  Suppose we have three modules+      <literal>A</literal>, <literal>B</literal> and+      <literal>C</literal> defined as follows:</para>++<programlisting>+module A (T) where+data T a = C a++module B (f) where+import A+f :: T Int -> Int+f (C i) = i++module C (T, f) where+import A+import B+</programlisting>++      <para>Module <literal>A</literal> exports a datatype+      <literal>T</literal>.  Module <literal>B</literal> imports+      <literal>A</literal> and exports a function <literal>f</literal>+      whose type refers to <literal>T</literal>.  Also, both+        <literal>T</literal> and <literal>f</literal> are re-exported from+        module C.</para>++      <para>Haddock takes the view that each entity has a+        <emphasis>home</emphasis> module; that is, the module that the library+        designer would most like to direct the user to, to find the+        documentation for that entity.  So, Haddock makes all links to an entity+        point to the home module.  The one exception is when the entity is also+      exported by the current module: Haddock makes a local link if it+        can.</para>++      <para>How is the home module for an entity determined?+        Haddock uses the following rules:</para>++      <itemizedlist>+        <listitem>+          <para>If modules A and B both export the entity, and module A imports+            (directly or indirectly) module B, then B is preferred.</para>+        </listitem>+        <listitem>+          <para>A module with the <literal>hide</literal> attribute is never+            chosen as the home.</para>+        </listitem>+        <listitem>+          <para>A module with the <literal>not-home</literal> attribute is only+            chosen if there are no other modules to choose.</para>+        </listitem>+      </itemizedlist>++      <para>If multiple modules fit the criteria, then one is chosen at+        random.  If no modules fit the criteria (because the candidates are all+      hidden), then Haddock will issue a warning for each reference to an+        entity without a home.</para>++      <para>In the example above, module <literal>A</literal> is chosen as the+        home for <literal>T</literal> because it does not import any other+        module that exports <literal>T</literal>.  The link from+        <literal>f</literal>'s+        type in module <literal>B</literal> will therefore point to+        <literal>A.T</literal>.  However, <literal>C</literal> also exports+        <literal>T</literal> and <literal>f</literal>, and the link from+        <literal>f</literal>'s type in <literal>C</literal> will therefore+        point locally to <literal>C.T</literal>.</para>+    </section>++    <section id="module-attributes">+      <title>Module Attributes</title>++      <para>Certain attributes may be specified for each module which+      affects the way that Haddock generates documentation for that+      module.  Attributes are specified in a comma-separated list in an+      <literal>{-# OPTIONS_HADDOCK ... #-}</literal> pragma at the+      top of the module, either before or after the module+      description.  For example:</para>++<programlisting>+{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}++-- |Module description+module A where+...+</programlisting>++      <para>The options and module description can be in either order.</para>++      <para>The following attributes are currently understood by+      Haddock:</para>++      <variablelist>+        <varlistentry>+          <term>+            <indexterm><primary><literal>hide</literal></primary></indexterm>+            <literal>hide</literal>+          </term>+          <listitem>+            <para>Omit this module from the generated documentation,+            but nevertheless propagate definitions and documentation+            from within this module to modules that re-export those+            definitions.</para>+          </listitem>+        </varlistentry>++        <varlistentry>+          <term>+            <indexterm><primary><literal>hide</literal></primary></indexterm>+            <literal>prune</literal>+          </term>+          <listitem>+            <para>Omit definitions that have no documentation+            annotations from the generated documentation.</para>+          </listitem>+        </varlistentry>++        <varlistentry>+          <term>+            <indexterm><primary><literal>ignore-exports</literal></primary></indexterm>+            <literal>ignore-exports</literal>+          </term>+          <listitem>+            <para>Ignore the export list.  Generate documentation as+            if the module had no export list - i.e. all the top-level+            declarations are exported, and section headings may be+            given in the body of the module.</para>+          </listitem>+        </varlistentry>++        <varlistentry>+          <term>+            <indexterm><primary><literal>not-home</literal></primary></indexterm>+      <literal>not-home</literal>+          </term>+          <listitem>+            <para>Indicates that the current module should not be considered to+              be the home module for each entity it exports,+              unless that entity is not exported from any other module.  See+              <xref linkend="hyperlinking" /> for more details.</para>+          </listitem>+        </varlistentry>++        <varlistentry>+          <term>+            <indexterm><primary><literal>show-extensions</literal></primary></indexterm>+      <literal>show-extensions</literal>+          </term>+          <listitem>+            <para>Indicates that we should render the extensions used in this module in the+            resulting documentation. This will only render if the output format supports it.+            If Language is set, it will be shown as well and all the extensions implied by it won't.+            All enabled extensions will be rendered, including those implied by their more powerful versions.</para>+          </listitem>+        </varlistentry>++      </variablelist>++    </section>++    <section>+      <title>Markup</title>++      <para>Haddock understands certain textual cues inside+      documentation annotations that tell it how to render the+      documentation.  The cues (or <quote>markup</quote>) have been+      designed to be simple and mnemonic in ASCII so that the+      programmer doesn't have to deal with heavyweight annotations+      when editing documentation comments.</para>++      <section>+        <title>Paragraphs</title>++        <para>One or more blank lines separates two paragraphs in a+        documentation comment.</para>+      </section>++      <section>+        <title>Special characters</title>++        <para>The following characters have special meanings in+        documentation comments: <literal>\</literal>, <literal>/</literal>,+        <literal>'</literal>, <literal>`</literal>,+        <literal>"</literal>, <literal>@</literal>,+        <literal>&lt;</literal>.  To insert a literal occurrence of+        one of these special characters, precede it with a backslash+        (<literal>\</literal>).</para>++        <para>Additionally, the character <literal>&gt;</literal> has+        a special meaning at the beginning of a line, and the+        following characters have special meanings at the beginning of+        a paragraph:+        <literal>*</literal>, <literal>-</literal>.  These characters+        can also be escaped using <literal>\</literal>.</para>++        <para>Furthermore, the character sequence <literal>&gt;&gt;&gt;</literal>+        has a special meaning at the beginning of a line. To+        escape it, just prefix the characters in the sequence with a+        backslash.</para>+      </section>++      <section>+        <title>Character references</title>++        <para>Although Haskell source files may contain any character+        from the Unicode character set, the encoding of these characters+        as bytes varies between systems, so that only source files+        restricted to the ASCII character set are portable.  Other+        characters may be specified in character and string literals+        using Haskell character escapes.  To represent such characters+        in documentation comments, Haddock supports SGML-style numeric+        character references of the forms+        <literal>&amp;#</literal><replaceable>D</replaceable><literal>;</literal>+        and+        <literal>&amp;#x</literal><replaceable>H</replaceable><literal>;</literal>+        where <replaceable>D</replaceable> and <replaceable>H</replaceable>+        are decimal and hexadecimal numbers denoting a code position+        in Unicode (or ISO 10646).  For example, the references+        <literal>&amp;#x3BB;</literal>, <literal>&amp;#x3bb;</literal>+        and <literal>&amp;#955;</literal> all represent the lower-case+        letter lambda.</para>+      </section>++      <section>+        <title>Code Blocks</title>++        <para>Displayed blocks of code are indicated by surrounding a+        paragraph with <literal>@...@</literal> or by preceding each+        line of a paragraph with <literal>&gt;</literal> (we often+        call these &ldquo;bird tracks&rdquo;).  For+        example:</para>++<programlisting>+-- | This documentation includes two blocks of code:+--+-- @+--     f x = x + x+-- @+--+-- &gt;  g x = x * 42+</programlisting>++        <para>There is an important difference between the two forms+        of code block: in the bird-track form, the text to the right+        of the &lsquo;<literal>></literal>&rsquo; is interpreted+        literally, whereas the <literal>@...@</literal> form+        interprets markup as normal inside the code block.</para>+      </section>++      <section>+        <title>Examples</title>++        <para> Haddock has markup support for examples of interaction with a+  <emphasis>read-eval-print loop (REPL)</emphasis>.  An+        example is introduced with+        <literal>&gt;&gt;&gt;</literal> followed by an expression followed+        by zero or more result lines:</para>++<programlisting>+-- | Two examples are given below:+--+-- &gt;&gt;&gt; fib 10+-- 55+--+-- &gt;&gt;&gt; putStrLn "foo\nbar"+-- foo+-- bar+</programlisting>+        <para>Result lines that only contain the string+        <literal>&lt;BLANKLINE&gt;</literal> are rendered as blank lines in the+        generated documentation.</para>+      </section>++      <section>+        <title>Properties</title>+        <para>+          Haddock provides markup for properties:+<programlisting>+-- | Addition is commutative:+--+-- prop> a + b = b + a+</programlisting>+          This allows third-party applications to extract and verify them.+        </para>+      </section>++      <section>+        <title>Hyperlinked Identifiers</title>++        <para>Referring to a Haskell identifier, whether it be a type,+        class, constructor, or function, is done by surrounding it+        with single quotes:</para>++<programlisting>+-- | This module defines the type 'T'.+</programlisting>++        <para>If there is an entity <literal>T</literal> in scope in+        the current module, then the documentation will hyperlink the+        reference in the text to the definition of+        <literal>T</literal> (if the output format supports+        hyperlinking, of course; in a printed format it might instead+        insert a page reference to the definition).</para>++        <para>It is also possible to refer to entities that are not in+        scope in the current module, by giving the full qualified name+        of the entity:</para>++<programlisting>+-- | The identifier 'M.T' is not in scope+</programlisting>++        <para>If <literal>M.T</literal> is not otherwise in scope,+        then Haddock will simply emit a link pointing to the entity+        <literal>T</literal> exported from module <literal>M</literal>+        (without checking to see whether either <literal>M</literal>+        or <literal>M.T</literal> exist).</para>++        <para>To make life easier for documentation writers, a quoted+        identifier is only interpreted as such if the quotes surround+        a lexically valid Haskell identifier.  This means, for+        example, that it normally isn't necessary to escape the single+        quote when used as an apostrophe:</para>++<programlisting>+-- | I don't have to escape my apostrophes; great, isn't it?+</programlisting>++        <para>Nothing special is needed to hyperlink identifiers which+        contain apostrophes themselves: to hyperlink+        <literal>foo'</literal> one would simply type+        <literal>'foo''</literal>.</para>++        <para>For compatibility with other systems, the following+        alternative form of markup is accepted<footnote><para>+        We chose not to use this as the primary markup for+        identifiers because strictly speaking the <literal>`</literal>+        character should not be used as a left quote, it is a grave accent.</para>+          </footnote>: <literal>`T'</literal>.</para>+      </section>++      <section>+        <title>Emphasis, Bold and Monospaced text</title>++        <para>Emphasis may be added by surrounding text with+        <literal>/.../</literal>. Other markup is valid inside emphasis. To have a forward+        slash inside of emphasis, just escape it: <literal>/fo\/o/</literal></para>++        <para>Bold (strong) text is indicated by surrounding it with <literal>__...__</literal>.+        Other markup is valid inside bold. For example, <literal>__/foo/__</literal> will make the emphasised+        text <literal>foo</literal> bold. You don't have to escape a single underscore if you need it bold:+        <literal>__This_text_with_underscores_is_bold__</literal>.+        </para>++        <para>Monospaced (or typewriter) text is indicated by+        surrounding it with <literal>@...@</literal>.  Other markup is+        valid inside a monospaced span: for example+        <literal>@'f'&nbsp;a&nbsp;b@</literal> will hyperlink the+        identifier <literal>f</literal> inside the code fragment.</para>+      </section>++      <section>+        <title>Linking to modules</title>++        <para>Linking to a module is done by surrounding the module+        name with double quotes:</para>++<programlisting>+-- | This is a reference to the "Foo" module.+</programlisting>++        <para>A basic check is done on the syntax of the header name to ensure that it is valid+        before turning it into a link but unlike with identifiers, whether the module is in scope isn't checked+        and will always be turned into a link.+        </para>++      </section>++      <section>+        <title>Itemized and Enumerated lists</title>++        <para>A bulleted item is represented by preceding a paragraph+        with either <quote><literal>*</literal></quote> or+        <quote><literal>-</literal></quote>.  A sequence of bulleted+        paragraphs is rendered as an itemized list in the generated+        documentation, eg.:</para>++<programlisting>+-- | This is a bulleted list:+--+--     * first item+--+--     * second item+</programlisting>++        <para>An enumerated list is similar, except each paragraph+        must be preceded by either+        <quote><literal>(<replaceable>n</replaceable>)</literal></quote>+        or+        <quote><literal><replaceable>n</replaceable>.</literal></quote>+        where <replaceable>n</replaceable> is any integer.  e.g.</para>++<programlisting>+-- | This is an enumerated list:+--+--     (1) first item+--+--     2. second item+</programlisting>++      <para>Lists of the same type don't have to be separated by a newline:</para>+<programlisting>+-- | This is an enumerated list:+--+--     (1) first item+--     2. second item+--+-- This is a bulleted list:+--+--     * first item+--     * second item+</programlisting>++      <para>You can have more than one line of content in a list element:+      </para>+<programlisting>+-- |+-- * first item+-- and more content for the first item+-- * second item+-- and more content for the second item+</programlisting>++     <para>You can even nest whole paragraphs inside of list elements. The rules+     are 4 spaces for each indentation level. You're required to use a newline before+     such nested paragraph:+     </para>+<programlisting>+{-|+* Beginning of list+This belongs to the list above!++    > nested+    > bird+    > tracks++    * Next list+    More of the indented list.++        * Deeper++            @+            even code blocks work+            @++            * Deeper++                    1. Even deeper!+                    2. No newline separation even in indented lists.+-}+</programlisting>++      </section>++      <section>+        <title>Definition lists</title>++        <para>Definition lists are written as follows:</para>++<programlisting>+-- | This is a definition list:+--+--   [@foo@] The description of @foo@.+--+--   [@bar@] The description of @bar@.+</programlisting>++        <para>To produce output something like this:</para>++        <variablelist>+          <varlistentry>+            <term><literal>foo</literal></term>+            <listitem>+              <para>The description of <literal>foo</literal>.</para>+            </listitem>+          </varlistentry>+          <varlistentry>+            <term><literal>bar</literal></term>+            <listitem>+              <para>The description of <literal>bar</literal>.</para>+            </listitem>+          </varlistentry>+        </variablelist>++        <para>Each paragraph should be preceded by the+        &ldquo;definition term&rdquo; enclosed in square brackets.+        The square bracket characters have no special meaning outside+        the beginning of a definition paragraph.  That is, if a+        paragraph begins with a <literal>[</literal> character, then+        it is assumed to be a definition paragraph, and the next+        <literal>]</literal> character found will close the definition+        term.  Other markup operators may be used freely within the+        definition term. You can escape <literal>]</literal> with a backslash as usual.</para>++      <para>Same rules about nesting and no newline separation as for bulleted and numbered lists apply.+      </para>++      </section>++      <section>+        <title>URLs</title>++        <para>A URL can be included in a documentation comment by+        surrounding it in angle brackets:+        <literal>&lt;...&gt;</literal>.  If the output format supports+        it, the URL will be turned into a hyperlink when+        rendered.</para>++        <para>The URL can be followed by an optional label:</para>+<programlisting>+&lt;http://example.com label&gt;+</programlisting>+      <para>The label is then used as a descriptive text for the hyperlink, if the+        output format supports it.</para>++      <para>If Haddock sees something that looks like a URL (such as something starting with+      <literal>http://</literal> or <literal>ssh://</literal>) where the URL markup is valid,+      it will automatically make it a hyperlink.</para>+      </section>++      <section>+        <title>Images</title>++        <para>An image can be included in a documentation comment by+        surrounding it in double angle brackets:+        <literal>&lt;&lt;...&gt;&gt;</literal>.  If the output format supports+        it, the image will be rendered inside the documentation.</para>++        <para>Title text can be included using an optional label:</para>+<programlisting>+&lt;&lt;pathtoimage.png title&gt;&gt;+</programlisting>++      </section>++      <section>+        <title>Anchors</title>++        <para>Sometimes it is useful to be able to link to a point in+        the documentation which doesn't correspond to a particular+        entity.  For that purpose, we allow <emphasis>anchors</emphasis> to be+        included in a documentation comment.  The syntax is+        <literal>#<replaceable>label</replaceable>#</literal>, where+        <replaceable>label</replaceable> is the name of the anchor.+        An anchor is invisible in the generated documentation.</para>++        <para>To link to an anchor from elsewhere, use the syntax+        <literal>"<replaceable>module</replaceable>#<replaceable>label</replaceable>"</literal>+        where <replaceable>module</replaceable> is the module name+        containing the anchor, and <replaceable>label</replaceable> is+        the anchor label. The module does not have to be local, it can+        be imported via an interface. Please note that in Haddock+        versions 2.13.x and earlier, the syntax was+        <literal>"<replaceable>module</replaceable>\#<replaceable>label</replaceable>"</literal>.+        It is considered deprecated and will be removed in the future.</para>+      </section>++      <section>+        <title>Headings</title>         <para>Headings inside of comment documentation are possible be preceding them with         a number of <literal>=</literal>s. From 1 to 6 are accepted. Extra <literal>=</literal>s will         be treated as belonging to the text of the heading. Note that it's up to the output format to decide
+ haddock-api/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
+ haddock-api/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
+ haddock-api/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 "-&gt;", 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 "#)"+-}
+ haddock-api/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 '<' = "&lt;"+        f '>' = "&gt;"+        f '&' = "&amp;"+        f x = [x]
+ haddock-api/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
+ haddock-api/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
+ haddock-api/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]
+ haddock-api/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+      }
+ haddock-api/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"
+ haddock-api/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.
+ haddock-api/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+
+ haddock-api/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
+ haddock-api/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
+ haddock-api/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
+ haddock-api/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
+ haddock-api/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+
+ haddock-api/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)
+ haddock-api/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
+ haddock-api/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
+ haddock-api/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))
+ haddock-api/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
+ haddock-api/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')
+ haddock-api/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"
+ haddock-api/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]
+ haddock-api/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)
+ haddock-api/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
+ haddock-api/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))
+ haddock-api/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
+ haddock-api/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
+ haddock-api/src/haddock.sh view
@@ -0,0 +1,7 @@+# Mini-driver for Haddock++# needs the following variables:+#	HADDOCKLIB+#	HADDOCKBIN++$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}
+ haddock-library/src/Documentation/Haddock/Doc.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Documentation.Haddock.Doc (docParagraph, docAppend, docConcat) where++import Documentation.Haddock.Types+import Data.Char (isSpace)++docConcat :: [DocH mod id] -> DocH mod id+docConcat = foldr docAppend DocEmpty++docAppend :: DocH mod id -> DocH mod id -> DocH mod id+docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d+docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2)+docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2)+docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) = DocAppend (DocUnorderedList (ds1++ds2)) d+docAppend DocEmpty d = d+docAppend d DocEmpty = d+docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2)+docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2))+docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d+docAppend d1 d2 = DocAppend d1 d2++-- again to make parsing easier - we spot a paragraph whose only item+-- is a DocMonospaced and make it into a DocCodeBlock+docParagraph :: DocH mod id -> DocH mod id+docParagraph (DocMonospaced p)+  = DocCodeBlock (docCodeBlock p)+docParagraph (DocAppend (DocString s1) (DocMonospaced p))+  | all isSpace s1+  = DocCodeBlock (docCodeBlock p)+docParagraph (DocAppend (DocString s1)+    (DocAppend (DocMonospaced p) (DocString s2)))+  | all isSpace s1 && all isSpace s2+  = DocCodeBlock (docCodeBlock p)+docParagraph (DocAppend (DocMonospaced p) (DocString s2))+  | all isSpace s2+  = DocCodeBlock (docCodeBlock p)+docParagraph p+  = DocParagraph p+++-- 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
+ haddock-library/src/Documentation/Haddock/Parser.hs view
@@ -0,0 +1,492 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE IncoherentInstances #-}+-- |+-- Module      :  Documentation.Haddock.Parser+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,+--                    Simon Hengel      2013+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Parser used for Haddock comments. For external users of this+-- library, the most commonly used combination of functions is going+-- to be+--+-- @'toRegular' . 'parseParas'@+module Documentation.Haddock.Parser ( parseString, parseParas+                                    , overIdentifier, toRegular, Identifier+                                    ) where++import           Control.Applicative+import           Control.Arrow (first)+import           Control.Monad (void, mfilter)+import           Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine)+import qualified Data.ByteString.Char8 as BS+import           Data.Char (chr, isAsciiUpper)+import           Data.List (stripPrefix, intercalate, unfoldr)+import           Data.Maybe (fromMaybe)+import           Data.Monoid+import           Documentation.Haddock.Doc+import           Documentation.Haddock.Parser.Util+import           Documentation.Haddock.Types+import           Documentation.Haddock.Utf8+import           Prelude hiding (takeWhile)++-- $setup+-- >>> :set -XOverloadedStrings++-- | Identifier string surrounded with opening and closing quotes/backticks.+type Identifier = (Char, String, Char)++-- | Drops the quotes/backticks around all identifiers, as if they+-- were valid but still 'String's.+toRegular :: DocH mod Identifier -> DocH mod String+toRegular = fmap (\(_, x, _) -> x)++-- | Maps over 'DocIdentifier's over 'String' with potentially failing+-- conversion using user-supplied function. If the conversion fails,+-- the identifier is deemed to not be valid and is treated as a+-- regular string.+overIdentifier :: (String -> Maybe a)+               -> DocH mod Identifier+               -> DocH mod a+overIdentifier f d = g d+  where+    g (DocIdentifier (o, x, e)) = case f x of+      Nothing -> DocString $ o : x ++ [e]+      Just x' -> DocIdentifier x'+    g DocEmpty = DocEmpty+    g (DocAppend x x') = DocAppend (g x) (g x')+    g (DocString x) = DocString x+    g (DocParagraph x) = DocParagraph $ g x+    g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x+    g (DocModule x) = DocModule x+    g (DocWarning x) = DocWarning $ g x+    g (DocEmphasis x) = DocEmphasis $ g x+    g (DocMonospaced x) = DocMonospaced $ g x+    g (DocBold x) = DocBold $ g x+    g (DocUnorderedList x) = DocUnorderedList $ fmap g x+    g (DocOrderedList x) = DocOrderedList $ fmap g x+    g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x+    g (DocCodeBlock x) = DocCodeBlock $ g x+    g (DocHyperlink x) = DocHyperlink x+    g (DocPic x) = DocPic x+    g (DocAName x) = DocAName x+    g (DocProperty x) = DocProperty x+    g (DocExamples x) = DocExamples x+    g (DocHeader (Header l x)) = DocHeader . Header l $ g x++parse :: Parser a -> BS.ByteString -> a+parse p = either err id . parseOnly (p <* endOfInput)+  where+    err = error . ("Haddock.Parser.parse: " ++)++-- | Main entry point to the parser. Appends the newline character+-- to the input string.+parseParas :: String -- ^ String to parse+           -> DocH mod Identifier+parseParas = parse (p <* skipSpace) . encodeUtf8 . (++ "\n")+  where+    p :: Parser (DocH mod Identifier)+    p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n")++-- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which+-- drops leading whitespace and encodes the string to UTF8 first.+parseString :: String -> DocH mod Identifier+parseString = parseStringBS . encodeUtf8 . dropWhile isSpace++parseStringBS :: BS.ByteString -> DocH mod Identifier+parseStringBS = parse p+  where+    p :: Parser (DocH mod Identifier)+    p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName+                            <|> picture <|> hyperlink <|> bold+                            <|> emphasis <|> encodedChar <|> string'+                            <|> skipSpecialChar)++-- | Parses and processes+-- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references>+--+-- >>> parseOnly encodedChar "&#65;"+-- Right (DocString "A")+encodedChar :: Parser (DocH mod a)+encodedChar = "&#" *> c <* ";"+  where+    c = DocString . return . chr <$> num+    num = hex <|> decimal+    hex = ("x" <|> "X") *> hexadecimal++-- | List of characters that we use to delimit any special markup.+-- Once we have checked for any of these and tried to parse the+-- relevant markup, we can assume they are used as regular text.+specialChar :: [Char]+specialChar = "_/<@\"&'`# "++-- | Plain, regular parser for text. Called as one of the last parsers+-- to ensure that we have already given a chance to more meaningful parsers+-- before capturing their characers.+string' :: Parser (DocH mod a)+string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (`notElem` specialChar)+  where+    unescape "" = ""+    unescape ('\\':x:xs) = x : unescape xs+    unescape (x:xs) = x : unescape xs++-- | Skips a single special character and treats it as a plain string.+-- This is done to skip over any special characters belonging to other+-- elements but which were not deemed meaningful at their positions.+skipSpecialChar :: Parser (DocH mod a)+skipSpecialChar = DocString . return <$> satisfy (`elem` specialChar)++-- | Emphasis parser.+--+-- >>> parseOnly emphasis "/Hello world/"+-- Right (DocEmphasis (DocString "Hello world"))+emphasis :: Parser (DocH mod Identifier)+emphasis = DocEmphasis . parseStringBS <$>+  mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/")++-- | Bold parser.+--+-- >>> parseOnly bold "__Hello world__"+-- Right (DocBold (DocString "Hello world"))+bold :: Parser (DocH mod Identifier)+bold = DocBold . parseStringBS <$> disallowNewline ("__" *> takeUntil "__")++disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString+disallowNewline = mfilter ('\n' `BS.notElem`)++-- | Like `takeWhile`, but unconditionally take escaped characters.+takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString+takeWhile_ p = scan False p_+  where+    p_ escaped c+      | escaped = Just False+      | not $ p c = Nothing+      | otherwise = Just (c == '\\')++-- | Like `takeWhile1`, but unconditionally take escaped characters.+takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString+takeWhile1_ = mfilter (not . BS.null) . takeWhile_++-- | Text anchors to allow for jumping around the generated documentation.+--+-- >>> parseOnly anchor "#Hello world#"+-- Right (DocAName "Hello world")+anchor :: Parser (DocH mod a)+anchor = DocAName . decodeUtf8 <$>+         disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")++-- | Monospaced strings.+--+-- >>> parseOnly monospace "@cruel@"+-- Right (DocMonospaced (DocString "cruel"))+monospace :: Parser (DocH mod Identifier)+monospace = DocMonospaced . parseStringBS <$> ("@" *> takeWhile1_ (/= '@') <* "@")++moduleName :: Parser (DocH mod a)+moduleName = DocModule <$> (char '"' *> modid <* char '"')+  where+    modid = intercalate "." <$> conid `sepBy1` "."+    conid = (:)+      <$> satisfy isAsciiUpper+      -- NOTE: According to Haskell 2010 we should actually only+      -- accept {small | large | digit | ' } here.  But as we can't+      -- match on unicode characters, this is currently not possible.+      -- Note that we allow ‘#’ to suport anchors.+      <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!|@/;,^?\"\n"))++-- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify+-- a title for the picture.+--+-- >>> parseOnly picture "<<hello.png>>"+-- Right (DocPic (Picture {pictureUri = "hello.png", pictureTitle = Nothing}))+-- >>> parseOnly picture "<<hello.png world>>"+-- Right (DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"}))+picture :: Parser (DocH mod a)+picture = DocPic . makeLabeled Picture . decodeUtf8+          <$> disallowNewline ("<<" *> takeUntil ">>")++-- | Paragraph parser, called by 'parseParas'.+paragraph :: Parser (DocH mod Identifier)+paragraph = examples <|> skipSpace *> (list <|> birdtracks <|> codeblock+                                       <|> property <|> header+                                       <|> textParagraph)++-- | Headers inside the comment denoted with @=@ signs, up to 6 levels+-- deep.+--+-- >>> parseOnly header "= Hello"+-- Right (DocHeader (Header {headerLevel = 1, headerTitle = DocString "Hello"}))+-- >>> parseOnly header "== World"+-- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"}))+header :: Parser (DocH mod Identifier)+header = do+  let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1]+      pser = foldl1 (<|>) psers+  delim <- decodeUtf8 <$> pser+  line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString+  rest <- paragraph <|> return DocEmpty+  return $ DocHeader (Header (length delim) line) `docAppend` rest++textParagraph :: Parser (DocH mod Identifier)+textParagraph = docParagraph . parseString . intercalate "\n" <$> many1 nonEmptyLine++-- | List parser, called by 'paragraph'.+list :: Parser (DocH mod Identifier)+list = DocUnorderedList <$> unorderedList+       <|> DocOrderedList <$> orderedList+       <|> DocDefList <$> definitionList++-- | Parses unordered (bullet) lists.+unorderedList :: Parser [DocH mod Identifier]+unorderedList = ("*" <|> "-") *> innerList unorderedList++-- | Parses ordered lists (numbered or dashed).+orderedList :: Parser [DocH mod Identifier]+orderedList = (paren <|> dot) *> innerList orderedList+  where+    dot = (decimal :: Parser Int) <* "."+    paren = "(" *> decimal <* ")"++-- | Generic function collecting any further lines belonging to the+-- list entry and recursively collecting any further lists in the+-- same paragraph. Usually used as+--+-- > someListFunction = listBeginning *> innerList someListFunction+innerList :: Parser [DocH mod Identifier] -> Parser [DocH mod Identifier]+innerList item = do+  c <- takeLine+  (cs, items) <- more item+  let contents = docParagraph . parseString . dropNLs . unlines $ c : cs+  return $ case items of+    Left p -> [contents `docAppend` p]+    Right i -> contents : i++-- | Parses definition lists.+definitionList :: Parser [(DocH mod Identifier, DocH mod Identifier)]+definitionList = do+  label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` "]\n")) <* "]"+  c <- takeLine+  (cs, items) <- more definitionList+  let contents = parseString . dropNLs . unlines $ c : cs+  return $ case items of+    Left p -> [(label, contents `docAppend` p)]+    Right i -> (label, contents) : i++-- | Drops all trailing newlines.+dropNLs :: String -> String+dropNLs = reverse . dropWhile (== '\n') . reverse++-- | Main worker for 'innerList' and 'definitionList'.+-- We need the 'Either' here to be able to tell in the respective functions+-- whether we're dealing with the next list or a nested paragraph.+more :: Monoid a => Parser a+     -> Parser ([String], Either (DocH mod Identifier) a)+more item = innerParagraphs <|> moreListItems item+            <|> moreContent item <|> pure ([], Right mempty)++-- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs.+innerParagraphs :: Parser ([String], Either (DocH mod Identifier) a)+innerParagraphs = (,) [] . Left <$> ("\n" *> indentedParagraphs)++-- | Attempts to fetch the next list if possibly. Used by 'innerList' and+-- 'definitionList' to recursively grab lists that aren't separated by a whole+-- paragraph.+moreListItems :: Parser a+              -> Parser ([String], Either (DocH mod Identifier) a)+moreListItems item = (,) [] . Right <$> (skipSpace *> item)++-- | Helper for 'innerList' and 'definitionList' which simply takes+-- a line of text and attempts to parse more list content with 'more'.+moreContent :: Monoid a => Parser a+            -> Parser ([String], Either (DocH mod Identifier) a)+moreContent item = first . (:) <$> nonEmptyLine <*> more item++-- | Runs the 'parseParas' parser on an indented paragraph.+-- The indentation is 4 spaces.+indentedParagraphs :: Parser (DocH mod Identifier)+indentedParagraphs = parseParas . concat <$> dropFrontOfPara "    "++-- | Grab as many fully indented paragraphs as we can.+dropFrontOfPara :: Parser BS.ByteString -> Parser [String]+dropFrontOfPara sp = do+  currentParagraph <- some (sp *> takeNonEmptyLine)+  followingParagraphs <-+    skipHorizontalSpace *> nextPar -- we have more paragraphs to take+    <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline+    <|> endOfInput *> return [] -- nothing more to take at all+  return (currentParagraph ++ followingParagraphs)+  where+    nextPar = (++) <$> nlList <*> dropFrontOfPara sp+    nlList = "\n" *> return ["\n"]++nonSpace :: BS.ByteString -> Parser BS.ByteString+nonSpace xs+  | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line"+  | otherwise = return xs++-- | Takes a non-empty, not fully whitespace line.+--+--  Doesn't discard the trailing newline.+takeNonEmptyLine :: Parser String+takeNonEmptyLine = do+    (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n"++-- | Blocks of text of the form:+--+-- >> foo+-- >> bar+-- >> baz+--+birdtracks :: Parser (DocH mod a)+birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line+  where+    line = skipHorizontalSpace *> ">" *> takeLine++stripSpace :: [String] -> [String]+stripSpace = fromMaybe <*> mapM strip'+  where+    strip' (' ':xs') = Just xs'+    strip' "" = Just ""+    strip' _  = Nothing++-- | Parses examples. Examples are a paragraph level entitity (separated by an empty line).+-- Consecutive examples are accepted.+examples :: Parser (DocH mod a)+examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go)+  where+    go :: Parser [Example]+    go = do+      prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>"+      expr <- takeLine+      (rs, es) <- resultAndMoreExamples+      return (makeExample prefix expr rs : es)+      where+        resultAndMoreExamples :: Parser ([String], [Example])+        resultAndMoreExamples = moreExamples <|> result <|> pure ([], [])+          where+            moreExamples :: Parser ([String], [Example])+            moreExamples = (,) [] <$> go++            result :: Parser ([String], [Example])+            result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples++    makeExample :: String -> String -> [String] -> Example+    makeExample prefix expression res =+      Example (strip expression) result+      where+        result = map (substituteBlankLine . tryStripPrefix) res++        tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs)++        substituteBlankLine "<BLANKLINE>" = ""+        substituteBlankLine xs = xs++nonEmptyLine :: Parser String+nonEmptyLine = mfilter (any (not . isSpace)) takeLine++takeLine :: Parser String+takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine++endOfLine :: Parser ()+endOfLine = void "\n" <|> endOfInput++-- | Property parser.+--+-- >>> parseOnly property "prop> hello world"+-- Right (DocProperty "hello world")+property :: Parser (DocH mod a)+property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n'))++-- |+-- Paragraph level codeblock. Anything between the two delimiting \@ is parsed+-- for markup.+codeblock :: Parser (DocH mod Identifier)+codeblock =+  DocCodeBlock . parseStringBS . dropSpaces+  <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")+  where+    dropSpaces xs =+      let rs = decodeUtf8 xs+      in case splitByNl rs of+        [] -> xs+        ys -> case last ys of+          ' ':_ -> case mapM dropSpace ys of+            Nothing -> xs+            Just zs -> encodeUtf8 $ intercalate "\n" zs+          _ -> xs++    -- This is necessary because ‘lines’ swallows up a trailing newline+    -- and we lose information about whether the last line belongs to @ or to+    -- text which we need to decide whether we actually want to be dropping+    -- anything at all.+    splitByNl = unfoldr (\x -> case x of+                                 '\n':s -> Just (span (/= '\n') s)+                                 _      -> Nothing)+                . ('\n' :)++    dropSpace "" = Just ""+    dropSpace (' ':xs) = Just xs+    dropSpace _ = Nothing++    block' = scan False p+      where+        p isNewline c+          | isNewline && c == '@' = Nothing+          | isNewline && isSpace c = Just isNewline+          | otherwise = Just $ c == '\n'++-- | Parses links that were specifically marked as such.+hyperlink :: Parser (DocH mod a)+hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8+              <$> disallowNewline ("<" *> takeUntil ">")+            <|> autoUrl++-- | Looks for URL-like things to automatically hyperlink even if they+-- weren't marked as links.+autoUrl :: Parser (DocH mod a)+autoUrl = mkLink <$> url+  where+    url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace)+    mkLink :: BS.ByteString -> DocH mod a+    mkLink s = case unsnoc s of+      Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x]+      _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing)++-- | Parses strings between identifier delimiters. Consumes all input that it+-- deems to be valid in an identifier. Note that it simply blindly consumes+-- characters and does no actual validation itself.+parseValid :: Parser String+parseValid = do+  vs' <- many' $ utf8String "⋆" <|> return <$> idChar+  let vs = concat vs'+  c <- peekChar+  case c of+    Just '`' -> return vs+    Just '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> parseValid)+                 <|> return vs+    _ -> fail "outofvalid"+  where+    idChar = satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:^")+             <|> digit <|> letter_ascii++-- | Parses UTF8 strings from ByteString streams.+utf8String :: String -> Parser String+utf8String x = decodeUtf8 <$> string (encodeUtf8 x)++-- | Parses identifiers with help of 'parseValid'. Asks GHC for 'String' from the+-- string it deems valid.+identifier :: Parser (DocH mod Identifier)+identifier = do+  o <- idDelim+  vid <- parseValid+  e <- idDelim+  return $ DocIdentifier (o, vid, e)+  where+    idDelim = char '\'' <|> char '`'
+ haddock-library/src/Documentation/Haddock/Parser/Util.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      :  Documentation.Haddock.Parser.Util+-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,+--                    Simon Hengel      2013+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Various utility functions used by the parser.+module Documentation.Haddock.Parser.Util (+  unsnoc+, strip+, takeUntil+, makeLabeled+, takeHorizontalSpace+, skipHorizontalSpace+) where++import           Control.Applicative+import           Control.Monad (mfilter)+import           Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine)+import           Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import           Prelude hiding (takeWhile)++#if MIN_VERSION_bytestring(0,10,2)+import           Data.ByteString.Char8 (unsnoc)+#else+unsnoc :: ByteString -> Maybe (ByteString, Char)+unsnoc bs+  | BS.null bs = Nothing+  | otherwise = Just (BS.init bs, BS.last bs)+#endif++-- | Remove all leading and trailing whitespace+strip :: String -> String+strip = (\f -> f . f) $ dropWhile isSpace . reverse++skipHorizontalSpace :: Parser ()+skipHorizontalSpace = skipWhile (`elem` " \t\f\v\r")++takeHorizontalSpace :: Parser BS.ByteString+takeHorizontalSpace = takeWhile (`elem` " \t\f\v\r")++makeLabeled :: (String -> Maybe String -> a) -> String -> a+makeLabeled f input = case break isSpace $ removeEscapes $ strip input of+  (uri, "")    -> f uri Nothing+  (uri, label) -> f uri (Just $ dropWhile isSpace label)+  where+    -- As we don't parse these any further, we don't do any processing to the+    -- string so we at least remove escape character here. Perhaps we should+    -- actually be parsing the label at the very least?+    removeEscapes "" = ""+    removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs+    removeEscapes ('\\':xs) = removeEscapes xs+    removeEscapes (x:xs) = x : removeEscapes xs++takeUntil :: ByteString -> Parser ByteString+takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome+  where+    end = BS.unpack end_++    p :: (Bool, String) -> Char -> Maybe (Bool, String)+    p acc c = case acc of+      (True, _) -> Just (False, end)+      (_, []) -> Nothing+      (_, x:xs) | x == c -> Just (False, xs)+      _ -> Just (c == '\\', end)++    dropEnd = BS.reverse . BS.drop (length end) . BS.reverse+    requireEnd = mfilter (BS.isSuffixOf end_)++    gotSome xs+      | BS.null xs = fail "didn't get any content"+      | otherwise = return xs
+ haddock-library/src/Documentation/Haddock/Types.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable, StandaloneDeriving #-}++-- |+-- Module      :  Documentation.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+--+-- Exposes documentation data types used for (some) of Haddock.+module Documentation.Haddock.Types where++import Data.Foldable+import Data.Traversable++instance Foldable Header where+  foldMap f (Header _ a) = f a++instance Traversable Header where+  traverse f (Header l a) = Header l `fmap` f a+++deriving instance Show a => Show (Header a)+deriving instance (Show a, Show b) => Show (DocH a b)+deriving instance Eq a => Eq (Header a)+deriving instance (Eq a, Eq b) => Eq (DocH a b)++data Hyperlink = Hyperlink+  { hyperlinkUrl   :: String+  , hyperlinkLabel :: Maybe String+  } deriving (Eq, Show)+++data Picture = Picture+  { pictureUri   :: String+  , pictureTitle :: Maybe String+  } deriving (Eq, Show)++data Header id = Header+  { headerLevel :: Int+  , headerTitle :: id+  } deriving Functor++data Example = Example+  { exampleExpression :: String+  , exampleResult     :: [String]+  } deriving (Eq, Show)++data DocH mod id+  = DocEmpty+  | DocAppend (DocH mod id) (DocH mod id)+  | DocString String+  | DocParagraph (DocH mod id)+  | DocIdentifier id+  | DocIdentifierUnchecked mod+  | DocModule String+  | DocWarning (DocH mod id)+  | DocEmphasis (DocH mod id)+  | DocMonospaced (DocH mod id)+  | DocBold (DocH mod id)+  | DocUnorderedList [DocH mod id]+  | DocOrderedList [DocH mod id]+  | DocDefList [(DocH mod id, DocH mod id)]+  | DocCodeBlock (DocH mod id)+  | DocHyperlink Hyperlink+  | DocPic Picture+  | DocAName String+  | DocProperty String+  | DocExamples [Example]+  | DocHeader (Header (DocH mod id))+  deriving (Functor, Foldable, Traversable)
+ haddock-library/src/Documentation/Haddock/Utf8.hs view
@@ -0,0 +1,74 @@+module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where+import           Data.Bits ((.|.), (.&.), shiftL, shiftR)+import qualified Data.ByteString as BS+import           Data.Char (chr, ord)+import           Data.Word (Word8)++-- | Helper that encodes and packs a 'String' into a 'BS.ByteString'+encodeUtf8 :: String -> BS.ByteString+encodeUtf8 = BS.pack . encode++-- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String'+decodeUtf8 :: BS.ByteString -> String+decodeUtf8 = decode . BS.unpack++-- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding+-- | Character to use when 'encode' or 'decode' fail for a byte.+replacementCharacter :: Char+replacementCharacter = '\xfffd'++-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+encode :: String -> [Word8]+encode = concatMap (map fromIntegral . go . ord)+ where+  go oc+   | oc <= 0x7f       = [oc]++   | oc <= 0x7ff      = [ 0xc0 + (oc `shiftR` 6)+                        , 0x80 + oc .&. 0x3f+                        ]++   | oc <= 0xffff     = [ 0xe0 + (oc `shiftR` 12)+                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+                        , 0x80 + oc .&. 0x3f+                        ]+   | otherwise        = [ 0xf0 + (oc `shiftR` 18)+                        , 0x80 + ((oc `shiftR` 12) .&. 0x3f)+                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+                        , 0x80 + oc .&. 0x3f+                        ]++-- | Decode a UTF8 string packed into a list of Word8 values, directly to String+decode :: [Word8] -> String+decode [    ] = ""+decode (c:cs)+  | c < 0x80  = chr (fromEnum c) : decode cs+  | c < 0xc0  = replacementCharacter : decode cs+  | c < 0xe0  = multi1+  | c < 0xf0  = multi_byte 2 0xf  0x800+  | c < 0xf8  = multi_byte 3 0x7  0x10000+  | c < 0xfc  = multi_byte 4 0x3  0x200000+  | c < 0xfe  = multi_byte 5 0x1  0x4000000+  | otherwise = replacementCharacter : decode cs+  where+    multi1 = case cs of+      c1 : ds | c1 .&. 0xc0 == 0x80 ->+        let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|.  fromEnum (c1 .&. 0x3f)+        in if d >= 0x000080 then toEnum d : decode ds+                            else replacementCharacter : decode ds+      _ -> replacementCharacter : decode cs++    multi_byte :: Int -> Word8 -> Int -> String+    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))+      where+        aux 0 rs acc+          | overlong <= acc && acc <= 0x10ffff &&+            (acc < 0xd800 || 0xdfff < acc)     &&+            (acc < 0xfffe || 0xffff < acc)      = chr acc : decode rs+          | otherwise = replacementCharacter : decode rs++        aux n (r:rs) acc+          | r .&. 0xc0 == 0x80 = aux (n-1) rs+                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)++        aux _ rs     _ = replacementCharacter : decode rs
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec.hs view
@@ -0,0 +1,23 @@+-- |+-- Module      :  Data.Attoparsec+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient combinator parsing for+-- 'Data.ByteString.ByteString' strings, loosely based on the Parsec+-- library.+--+-- This module is deprecated. Use "Data.Attoparsec.ByteString"+-- instead.++module Data.Attoparsec+    {-# DEPRECATED "This module will be removed in the next major release." #-}+    (+      module Data.Attoparsec.ByteString+    ) where++import Data.Attoparsec.ByteString
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString.hs view
@@ -0,0 +1,223 @@+-- |+-- Module      :  Data.Attoparsec.ByteString+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient combinator parsing for 'B.ByteString' strings,+-- loosely based on the Parsec library.++module Data.Attoparsec.ByteString+    (+    -- * Differences from Parsec+    -- $parsec++    -- * Incremental input+    -- $incremental++    -- * Performance considerations+    -- $performance++    -- * Parser types+      I.Parser+    , Result+    , T.IResult(..)+    , I.compareResults++    -- * Running parsers+    , parse+    , feed+    , I.parseOnly+    , parseWith+    , parseTest++    -- ** Result conversion+    , maybeResult+    , eitherResult++    -- * Parsing individual bytes+    , I.word8+    , I.anyWord8+    , I.notWord8+    , I.satisfy+    , I.satisfyWith+    , I.skip++    -- ** Lookahead+    , I.peekWord8+    , I.peekWord8'++    -- ** Byte classes+    , I.inClass+    , I.notInClass++    -- * Efficient string handling+    , I.string+    , I.skipWhile+    , I.take+    , I.scan+    , I.takeWhile+    , I.takeWhile1+    , I.takeTill++    -- ** Consume all remaining input+    , I.takeByteString+    , I.takeLazyByteString++    -- * Combinators+    , try+    , (<?>)+    , choice+    , count+    , option+    , many'+    , many1+    , many1'+    , manyTill+    , manyTill'+    , sepBy+    , sepBy'+    , sepBy1+    , sepBy1'+    , skipMany+    , skipMany1+    , eitherP+    , I.match+    -- * State observation and manipulation functions+    , I.endOfInput+    , I.atEnd+    ) where++import Data.Attoparsec.Combinator+import qualified Data.Attoparsec.ByteString.Internal as I+import qualified Data.Attoparsec.Internal as I+import qualified Data.ByteString as B+import Data.Attoparsec.ByteString.Internal (Result, parse)+import qualified Data.Attoparsec.Internal.Types as T++-- $parsec+--+-- Compared to Parsec 3, attoparsec makes several tradeoffs.  It is+-- not intended for, or ideal for, all possible uses.+--+-- * While attoparsec can consume input incrementally, Parsec cannot.+--   Incremental input is a huge deal for efficient and secure network+--   and system programming, since it gives much more control to users+--   of the library over matters such as resource usage and the I/O+--   model to use.+--+-- * Much of the performance advantage of attoparsec is gained via+--   high-performance parsers such as 'I.takeWhile' and 'I.string'.+--   If you use complicated combinators that return lists of bytes or+--   characters, there is less performance difference between the two+--   libraries.+--+-- * Unlike Parsec 3, attoparsec does not support being used as a+--   monad transformer.+--+-- * attoparsec is specialised to deal only with strict 'B.ByteString'+--   input.  Efficiency concerns rule out both lists and lazy+--   bytestrings.  The usual use for lazy bytestrings would be to+--   allow consumption of very large input without a large footprint.+--   For this need, attoparsec's incremental input provides an+--   excellent substitute, with much more control over when input+--   takes place.  If you must use lazy bytestrings, see the+--   "Data.Attoparsec.ByteString.Lazy" module, which feeds lazy chunks+--   to a regular parser.+--+-- * Parsec parsers can produce more helpful error messages than+--   attoparsec parsers.  This is a matter of focus: attoparsec avoids+--   the extra book-keeping in favour of higher performance.++-- $incremental+--+-- attoparsec supports incremental input, meaning that you can feed it+-- a bytestring that represents only part of the expected total amount+-- of data to parse. If your parser reaches the end of a fragment of+-- input and could consume more input, it will suspend parsing and+-- return a 'T.Partial' continuation.+--+-- Supplying the 'T.Partial' continuation with a bytestring will+-- resume parsing at the point where it was suspended, with the+-- bytestring you supplied used as new input at the end of the+-- existing input. You must be prepared for the result of the resumed+-- parse to be another 'T.Partial' continuation.+--+-- To indicate that you have no more input, supply the 'T.Partial'+-- continuation with an empty bytestring.+--+-- Remember that some parsing combinators will not return a result+-- until they reach the end of input.  They may thus cause 'T.Partial'+-- results to be returned.+--+-- If you do not need support for incremental input, consider using+-- the 'I.parseOnly' function to run your parser.  It will never+-- prompt for more input.+--+-- /Note/: incremental input does /not/ imply that attoparsec will+-- release portions of its internal state for garbage collection as it+-- proceeds.  Its internal representation is equivalent to a single+-- 'ByteString': if you feed incremental input to a parser, it will+-- require memory proportional to the amount of input you supply.+-- (This is necessary to support arbitrary backtracking.)++-- $performance+--+-- If you write an attoparsec-based parser carefully, it can be+-- realistic to expect it to perform similarly to a hand-rolled C+-- parser (measuring megabytes parsed per second).+--+-- To actually achieve high performance, there are a few guidelines+-- that it is useful to follow.+--+-- Use the 'B.ByteString'-oriented parsers whenever possible,+-- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'.  There is+-- about a factor of 100 difference in performance between the two+-- kinds of parser.+--+-- For very simple byte-testing predicates, write them by hand instead+-- of using 'I.inClass' or 'I.notInClass'.  For instance, both of+-- these predicates test for an end-of-line byte, but the first is+-- much faster than the second:+--+-- >endOfLine_fast w = w == 13 || w == 10+-- >endOfLine_slow   = inClass "\r\n"+--+-- Make active use of benchmarking and profiling tools to measure,+-- find the problems with, and improve the performance of your parser.++-- | Run a parser and print its result to standard output.+parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO ()+parseTest p s = print (parse p s)++-- | Run a parser with an initial input string, and a monadic action+-- that can supply more input if needed.+parseWith :: Monad m =>+             (m B.ByteString)+          -- ^ An action that will be executed to provide the parser+          -- with more input, if necessary.  The action must return an+          -- 'B.empty' string when there is no more input available.+          -> I.Parser a+          -> B.ByteString+          -- ^ Initial input for the parser.+          -> m (Result a)+parseWith refill p s = step $ parse p s+  where step (T.Partial k) = (step . k) =<< refill+        step r             = return r+{-# INLINE parseWith #-}++-- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result+-- is treated as failure.+maybeResult :: Result r -> Maybe r+maybeResult (T.Done _ r) = Just r+maybeResult _            = Nothing++-- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'+-- result is treated as failure.+eitherResult :: Result r -> Either String r+eitherResult (T.Done _ r)     = Right r+eitherResult (T.Fail _ _ msg) = Left msg+eitherResult _                = Left "Result: incomplete input"
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Buffer.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module      :  Data.Attoparsec.ByteString.Buffer+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  GHC+--+-- An "immutable" buffer that supports cheap appends.+--+-- A Buffer is divided into an immutable read-only zone, followed by a+-- mutable area that we've preallocated, but not yet written to.+--+-- We overallocate at the end of a Buffer so that we can cheaply+-- append.  Since a user of an existing Buffer cannot see past the end+-- of its immutable zone into the data that will change during an+-- append, this is safe.+--+-- Once we run out of space at the end of a Buffer, we do the usual+-- doubling of the buffer size.+--+-- The fact of having a mutable buffer really helps with performance,+-- but it does have a consequence: if someone misuses the Partial API+-- that attoparsec uses by calling the same continuation repeatedly+-- (which never makes sense in practice), they could overwrite data.+--+-- Since the API *looks* pure, it should *act* pure, too, so we use+-- two generation counters (one mutable, one immutable) to track the+-- number of appends to a mutable buffer. If the counters ever get out+-- of sync, someone is appending twice to a mutable buffer, so we+-- duplicate the entire buffer in order to preserve the immutability+-- of its older self.+--+-- While we could go a step further and gain protection against API+-- abuse on a multicore system, by use of an atomic increment+-- instruction to bump the mutable generation counter, that would be+-- very expensive, and feels like it would also be in the realm of the+-- ridiculous.  Clients should never call a continuation more than+-- once; we lack a linear type system that could enforce this; and+-- there's only so far we should go to accommodate broken uses.++module Data.Attoparsec.ByteString.Buffer+    (+      Buffer+    , buffer+    , unbuffer+    , pappend+    , length+    , unsafeIndex+    , substring+    , unsafeDrop+    ) where++import Control.Exception (assert)+import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr)+import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)+import Data.List (foldl1')+import Data.Monoid (Monoid(..))+import Data.Word (Word8)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Storable (peek, peekByteOff, poke, sizeOf)+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import Prelude hiding (length)++data Buffer = Buf {+      _fp  :: {-# UNPACK #-} !(ForeignPtr Word8)+    , _off :: {-# UNPACK #-} !Int+    , _len :: {-# UNPACK #-} !Int+    , _cap :: {-# UNPACK #-} !Int+    , _gen :: {-# UNPACK #-} !Int+    }++instance Show Buffer where+    showsPrec p = showsPrec p . unbuffer++-- | The initial 'Buffer' has no mutable zone, so we can avoid all+-- copies in the (hopefully) common case of no further input being fed+-- to us.+buffer :: ByteString -> Buffer+buffer (PS fp off len) = Buf fp off len len 0++unbuffer :: Buffer -> ByteString+unbuffer (Buf fp off len _ _) = PS fp off len++instance Monoid Buffer where+    mempty = Buf nullForeignPtr 0 0 0 0++    mappend (Buf _ _ _ 0 _) b        = b+    mappend a (Buf _ _ _ 0 _)        = a+    mappend buf (Buf fp off len _ _) = append buf fp off len++    mconcat [] = mempty+    mconcat xs = foldl1' mappend xs++pappend :: Buffer -> ByteString -> Buffer+pappend (Buf _ _ _ 0 _) (PS fp off len) = Buf fp off len 0 0+pappend buf (PS fp off len) = append buf fp off len++append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer+append (Buf fp0 off0 len0 cap0 gen0) !fp1 !off1 !len1 =+  inlinePerformIO . withForeignPtr fp0 $ \ptr0 ->+    withForeignPtr fp1 $ \ptr1 -> do+      let genSize = sizeOf (0::Int)+          newlen  = len0 + len1+      gen <- if gen0 == 0+             then return 0+             else peek (castPtr ptr0)+      if gen == gen0 && newlen <= cap0+        then do+          let newgen = gen + 1+          poke (castPtr ptr0) newgen+          memcpy (ptr0 `plusPtr` (off0+len0))+                 (ptr1 `plusPtr` off1)+                 (fromIntegral len1)+          return (Buf fp0 off0 newlen cap0 newgen)+        else do+          let newcap = newlen * 2+          fp <- mallocPlainForeignPtrBytes (newcap + genSize)+          withForeignPtr fp $ \ptr_ -> do+            let ptr    = ptr_ `plusPtr` genSize+                newgen = 1+            poke (castPtr ptr_) newgen+            memcpy ptr (ptr0 `plusPtr` off0) (fromIntegral len0)+            memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1)+                   (fromIntegral len1)+            return (Buf fp genSize newlen newcap newgen)++length :: Buffer -> Int+length (Buf _ _ len _ _) = len+{-# INLINE length #-}++unsafeIndex :: Buffer -> Int -> Word8+unsafeIndex (Buf fp off len _ _) i = assert (i >= 0 && i < len) .+    inlinePerformIO . withForeignPtr fp $ flip peekByteOff (off+i)+{-# INLINE unsafeIndex #-}++substring :: Int -> Int -> Buffer -> ByteString+substring s l (Buf fp off len _ _) =+  assert (s >= 0 && s <= len) .+  assert (l >= 0 && l <= len-s) $+  PS fp (off+s) l+{-# INLINE substring #-}++unsafeDrop :: Int -> Buffer -> ByteString+unsafeDrop s (Buf fp off len _ _) =+  assert (s >= 0 && s <= len) $+  PS fp (off+s) (len-s)+{-# INLINE unsafeDrop #-}
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs view
@@ -0,0 +1,469 @@+{-# LANGUAGE BangPatterns, FlexibleInstances, TypeFamilies,+    TypeSynonymInstances, GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-}++-- |+-- Module      :  Data.Attoparsec.ByteString.Char8+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient, character-oriented combinator parsing for+-- 'B.ByteString' strings, loosely based on the Parsec library.++module Data.Attoparsec.ByteString.Char8+    (+    -- * Character encodings+    -- $encodings++    -- * Parser types+      Parser+    , A.Result+    , A.IResult(..)+    , I.compareResults++    -- * Running parsers+    , A.parse+    , A.feed+    , A.parseOnly+    , A.parseWith+    , A.parseTest++    -- ** Result conversion+    , A.maybeResult+    , A.eitherResult++    -- * Parsing individual characters+    , char+    , char8+    , anyChar+    , notChar+    , satisfy++    -- ** Lookahead+    , peekChar+    , peekChar'++    -- ** Special character parsers+    , digit+    , letter_iso8859_15+    , letter_ascii+    , space++    -- ** Fast predicates+    , isDigit+    , isDigit_w8+    , isAlpha_iso8859_15+    , isAlpha_ascii+    , isSpace+    , isSpace_w8++    -- *** Character classes+    , inClass+    , notInClass++    -- * Efficient string handling+    , I.string+    , stringCI+    , skipSpace+    , skipWhile+    , I.take+    , scan+    , takeWhile+    , takeWhile1+    , takeTill++    -- ** String combinators+    -- $specalt+    , (.*>)+    , (<*.)++    -- ** Consume all remaining input+    , I.takeByteString+    , I.takeLazyByteString++    -- * Text parsing+    , I.endOfLine+    , isEndOfLine+    , isHorizontalSpace++    -- * Numeric parsers+    , decimal+    , hexadecimal+    , signed+    , Number(..)++    -- * Combinators+    , try+    , (<?>)+    , choice+    , count+    , option+    , many'+    , many1+    , many1'+    , manyTill+    , manyTill'+    , sepBy+    , sepBy'+    , sepBy1+    , sepBy1'+    , skipMany+    , skipMany1+    , eitherP+    , I.match+    -- * State observation and manipulation functions+    , I.endOfInput+    , I.atEnd+    ) where++import Control.Applicative ((*>), (<*), (<$>), (<|>))+import Data.Attoparsec.ByteString.FastSet (charClass, memberChar)+import Data.Attoparsec.ByteString.Internal (Parser)+import Data.Attoparsec.Combinator+import Data.Attoparsec.Number (Number(..))+import Data.Bits (Bits, (.|.), shiftL)+import Data.ByteString.Internal (c2w, w2c)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.String (IsString(..))+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Prelude hiding (takeWhile)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Internal as I+import qualified Data.Attoparsec.Internal as I+import qualified Data.ByteString as B8+import qualified Data.ByteString.Char8 as B++instance (a ~ B.ByteString) => IsString (Parser a) where+    fromString = I.string . B.pack++-- $encodings+--+-- This module is intended for parsing text that is+-- represented using an 8-bit character set, e.g. ASCII or+-- ISO-8859-15.  It /does not/ make any attempt to deal with character+-- encodings, multibyte characters, or wide characters.  In+-- particular, all attempts to use characters above code point U+00FF+-- will give wrong answers.+--+-- Code points below U+0100 are simply translated to and from their+-- numeric values, so e.g. the code point U+00A4 becomes the byte+-- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic+-- currency sign in ISO-8859-1).  Haskell 'Char' values above U+00FF+-- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@.++-- ASCII-specific but fast, oh yes.+toLower :: Word8 -> Word8+toLower w | w >= 65 && w <= 90 = w + 32+          | otherwise          = w++-- | Satisfy a literal string, ignoring case.+stringCI :: B.ByteString -> Parser B.ByteString+stringCI = I.stringTransform (B8.map toLower)+{-# INLINE stringCI #-}++-- | Consume input as long as the predicate returns 'True', and return+-- the consumed input.+--+-- This parser requires the predicate to succeed on at least one byte+-- of input: it will fail if the predicate never returns 'True' or if+-- there is no input left.+takeWhile1 :: (Char -> Bool) -> Parser B.ByteString+takeWhile1 p = I.takeWhile1 (p . w2c)+{-# INLINE takeWhile1 #-}++-- | The parser @satisfy p@ succeeds for any byte for which the+-- predicate @p@ returns 'True'. Returns the byte that is actually+-- parsed.+--+-- >digit = satisfy isDigit+-- >    where isDigit c = c >= '0' && c <= '9'+satisfy :: (Char -> Bool) -> Parser Char+satisfy = I.satisfyWith w2c+{-# INLINE satisfy #-}++-- | Match a letter, in the ISO-8859-15 encoding.+letter_iso8859_15 :: Parser Char+letter_iso8859_15 = satisfy isAlpha_iso8859_15 <?> "letter_iso8859_15"+{-# INLINE letter_iso8859_15 #-}++-- | Match a letter, in the ASCII encoding.+letter_ascii :: Parser Char+letter_ascii = satisfy isAlpha_ascii <?> "letter_ascii"+{-# INLINE letter_ascii #-}++-- | A fast alphabetic predicate for the ISO-8859-15 encoding+--+-- /Note/: For all character encodings other than ISO-8859-15, and+-- almost all Unicode code points above U+00A3, this predicate gives+-- /wrong answers/.+isAlpha_iso8859_15 :: Char -> Bool+isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||+                       (c >= '\166' && moby c)+  where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247"+        {-# NOINLINE moby #-}+{-# INLINE isAlpha_iso8859_15 #-}++-- | A fast alphabetic predicate for the ASCII encoding+--+-- /Note/: For all character encodings other than ASCII, and+-- almost all Unicode code points above U+007F, this predicate gives+-- /wrong answers/.+isAlpha_ascii :: Char -> Bool+isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')+{-# INLINE isAlpha_ascii #-}++-- | Parse a single digit.+digit :: Parser Char+digit = satisfy isDigit <?> "digit"+{-# INLINE digit #-}++-- | A fast digit predicate.+isDigit :: Char -> Bool+isDigit c = c >= '0' && c <= '9'+{-# INLINE isDigit #-}++-- | A fast digit predicate.+isDigit_w8 :: Word8 -> Bool+isDigit_w8 w = w >= 48 && w <= 57+{-# INLINE isDigit_w8 #-}++-- | Match any character.+anyChar :: Parser Char+anyChar = satisfy $ const True+{-# INLINE anyChar #-}++-- | Match any character, to perform lookahead. Returns 'Nothing' if+-- end of input has been reached. Does not consume any input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs.  Careless use will thus result in an infinite loop.+peekChar :: Parser (Maybe Char)+peekChar = (fmap w2c) `fmap` I.peekWord8+{-# INLINE peekChar #-}++-- | Match any character, to perform lookahead.  Does not consume any+-- input, but will fail if end of input has been reached.+peekChar' :: Parser Char+peekChar' = w2c `fmap` I.peekWord8'+{-# INLINE peekChar' #-}++-- | Fast predicate for matching ASCII space characters.+--+-- /Note/: This predicate only gives correct answers for the ASCII+-- encoding.  For instance, it does not recognise U+00A0 (non-breaking+-- space) as a space character, even though it is a valid ISO-8859-15+-- byte. For a Unicode-aware and only slightly slower predicate,+-- use 'Data.Char.isSpace'+isSpace :: Char -> Bool+isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')+{-# INLINE isSpace #-}++-- | Fast 'Word8' predicate for matching ASCII space characters.+isSpace_w8 :: Word8 -> Bool+isSpace_w8 w = (w == 32) || (9 <= w && w <= 13)+{-# INLINE isSpace_w8 #-}+++-- | Parse a space character.+--+-- /Note/: This parser only gives correct answers for the ASCII+-- encoding.  For instance, it does not recognise U+00A0 (non-breaking+-- space) as a space character, even though it is a valid ISO-8859-15+-- byte.+space :: Parser Char+space = satisfy isSpace <?> "space"+{-# INLINE space #-}++-- | Match a specific character.+char :: Char -> Parser Char+char c = satisfy (== c) <?> [c]+{-# INLINE char #-}++-- | Match a specific character, but return its 'Word8' value.+char8 :: Char -> Parser Word8+char8 c = I.satisfy (== c2w c) <?> [c]+{-# INLINE char8 #-}++-- | Match any character except the given one.+notChar :: Char -> Parser Char+notChar c = satisfy (/= c) <?> "not " ++ [c]+{-# INLINE notChar #-}++-- | Match any character in a set.+--+-- >vowel = inClass "aeiou"+--+-- Range notation is supported.+--+-- >halfAlphabet = inClass "a-nA-N"+--+-- To add a literal \'-\' to a set, place it at the beginning or end+-- of the string.+inClass :: String -> Char -> Bool+inClass s = (`memberChar` mySet)+    where mySet = charClass s+{-# INLINE inClass #-}++-- | Match any character not in a set.+notInClass :: String -> Char -> Bool+notInClass s = not . inClass s+{-# INLINE notInClass #-}++-- | Consume input as long as the predicate returns 'True', and return+-- the consumed input.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'False' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs.  Careless use will thus result in an infinite loop.+takeWhile :: (Char -> Bool) -> Parser B.ByteString+takeWhile p = I.takeWhile (p . w2c)+{-# INLINE takeWhile #-}++-- | A stateful scanner.  The predicate consumes and transforms a+-- state argument, and each transformed state is passed to successive+-- invocations of the predicate on each byte of the input until one+-- returns 'Nothing' or the input ends.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'Nothing' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs.  Careless use will thus result in an infinite loop.+scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString+scan s0 p = I.scan s0 (\s -> p s . w2c)+{-# INLINE scan #-}++-- | Consume input as long as the predicate returns 'False'+-- (i.e. until it returns 'True'), and return the consumed input.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'True' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'many', because such parsers loop until a+-- failure occurs.  Careless use will thus result in an infinite loop.+takeTill :: (Char -> Bool) -> Parser B.ByteString+takeTill p = I.takeTill (p . w2c)+{-# INLINE takeTill #-}++-- | Skip past input for as long as the predicate returns 'True'.+skipWhile :: (Char -> Bool) -> Parser ()+skipWhile p = I.skipWhile (p . w2c)+{-# INLINE skipWhile #-}++-- | Skip over white space.+skipSpace :: Parser ()+skipSpace = I.skipWhile isSpace_w8+{-# INLINE skipSpace #-}++-- $specalt+--+-- If you enable the @OverloadedStrings@ language extension, you can+-- use the '*>' and '<*' combinators to simplify the common task of+-- matching a statically known string, then immediately parsing+-- something else.+--+-- Instead of writing something like this:+--+-- @+--'I.string' \"foo\" '*>' wibble+-- @+--+-- Using @OverloadedStrings@, you can omit the explicit use of+-- 'I.string', and write a more compact version:+--+-- @+-- \"foo\" '*>' wibble+-- @+--+-- (Note: the '.*>' and '<*.' combinators that were originally+-- provided for this purpose are obsolete and unnecessary, and will be+-- removed in the next major version.)++-- | /Obsolete/. A type-specialized version of '*>' for+-- 'B.ByteString'. Use '*>' instead.+(.*>) :: B.ByteString -> Parser a -> Parser a+s .*> f = I.string s *> f+{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-}++-- | /Obsolete/. A type-specialized version of '<*' for+-- 'B.ByteString'. Use '<*' instead.+(<*.) :: Parser a -> B.ByteString -> Parser a+f <*. s = f <* I.string s+{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-}++-- | A predicate that matches either a carriage return @\'\\r\'@ or+-- newline @\'\\n\'@ character.+isEndOfLine :: Word8 -> Bool+isEndOfLine w = w == 13 || w == 10+{-# INLINE isEndOfLine #-}++-- | A predicate that matches either a space @\' \'@ or horizontal tab+-- @\'\\t\'@ character.+isHorizontalSpace :: Word8 -> Bool+isHorizontalSpace w = w == 32 || w == 9+{-# INLINE isHorizontalSpace #-}++-- | Parse and decode an unsigned hexadecimal number.  The hex digits+-- @\'a\'@ through @\'f\'@ may be upper or lower case.+--+-- This parser does not accept a leading @\"0x\"@ string.+hexadecimal :: (Integral a, Bits a) => Parser a+hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit+  where+    isHexDigit w = (w >= 48 && w <= 57) ||+                   (w >= 97 && w <= 102) ||+                   (w >= 65 && w <= 70)+    step a w | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)+             | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)+             | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)+{-# SPECIALISE hexadecimal :: Parser Int #-}+{-# SPECIALISE hexadecimal :: Parser Int8 #-}+{-# SPECIALISE hexadecimal :: Parser Int16 #-}+{-# SPECIALISE hexadecimal :: Parser Int32 #-}+{-# SPECIALISE hexadecimal :: Parser Int64 #-}+{-# SPECIALISE hexadecimal :: Parser Integer #-}+{-# SPECIALISE hexadecimal :: Parser Word #-}+{-# SPECIALISE hexadecimal :: Parser Word8 #-}+{-# SPECIALISE hexadecimal :: Parser Word16 #-}+{-# SPECIALISE hexadecimal :: Parser Word32 #-}+{-# SPECIALISE hexadecimal :: Parser Word64 #-}++-- | Parse and decode an unsigned decimal number.+decimal :: Integral a => Parser a+decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig+  where isDig w  = w >= 48 && w <= 57+        step a w = a * 10 + fromIntegral (w - 48)+{-# SPECIALISE decimal :: Parser Int #-}+{-# SPECIALISE decimal :: Parser Int8 #-}+{-# SPECIALISE decimal :: Parser Int16 #-}+{-# SPECIALISE decimal :: Parser Int32 #-}+{-# SPECIALISE decimal :: Parser Int64 #-}+{-# SPECIALISE decimal :: Parser Integer #-}+{-# SPECIALISE decimal :: Parser Word #-}+{-# SPECIALISE decimal :: Parser Word8 #-}+{-# SPECIALISE decimal :: Parser Word16 #-}+{-# SPECIALISE decimal :: Parser Word32 #-}+{-# SPECIALISE decimal :: Parser Word64 #-}++-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign+-- character.+signed :: Num a => Parser a -> Parser a+{-# SPECIALISE signed :: Parser Int -> Parser Int #-}+{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-}+{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-}+{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-}+{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-}+{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-}+signed p = (negate <$> (char8 '-' *> p))+       <|> (char8 '+' *> p)+       <|> p
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/FastSet.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns, MagicHash #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Attoparsec.ByteString.FastSet+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Fast set membership tests for 'Word8' and 8-bit 'Char' values.  The+-- set representation is unboxed for efficiency.  For small sets, we+-- test for membership using a binary search.  For larger sets, we use+-- a lookup table.+--+-----------------------------------------------------------------------------+module Data.Attoparsec.ByteString.FastSet+    (+    -- * Data type+      FastSet+    -- * Construction+    , fromList+    , set+    -- * Lookup+    , memberChar+    , memberWord8+    -- * Debugging+    , fromSet+    -- * Handy interface+    , charClass+    ) where++import Data.Bits ((.&.), (.|.))+import Foreign.Storable (peekByteOff, pokeByteOff)+import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)+import GHC.Word (Word8(W8#))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Internal as I+import qualified Data.ByteString.Unsafe as U++data FastSet = Sorted { fromSet :: !B.ByteString }+             | Table  { fromSet :: !B.ByteString }+    deriving (Eq, Ord)++instance Show FastSet where+    show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s)+    show (Table _) = "FastSet Table"++-- | The lower bound on the size of a lookup table.  We choose this to+-- balance table density against performance.+tableCutoff :: Int+tableCutoff = 8++-- | Create a set.+set :: B.ByteString -> FastSet+set s | B.length s < tableCutoff = Sorted . B.sort $ s+      | otherwise                = Table . mkTable $ s++fromList :: [Word8] -> FastSet+fromList = set . B.pack++data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8++shiftR :: Int -> Int -> Int+shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)++shiftL :: Word8 -> Int -> Word8+shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))++index :: Int -> I+index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))+{-# INLINE index #-}++-- | Check the set for membership.+memberWord8 :: Word8 -> FastSet -> Bool+memberWord8 w (Table t)  =+    let I byte bit = index (fromIntegral w)+    in  U.unsafeIndex t byte .&. bit /= 0+memberWord8 w (Sorted s) = search 0 (B.length s - 1)+    where search lo hi+              | hi < lo = False+              | otherwise =+                  let mid = (lo + hi) `quot` 2+                  in case compare w (U.unsafeIndex s mid) of+                       GT -> search (mid + 1) hi+                       LT -> search lo (mid - 1)+                       _ -> True++-- | Check the set for membership.  Only works with 8-bit characters:+-- characters above code point 255 will give wrong answers.+memberChar :: Char -> FastSet -> Bool+memberChar c = memberWord8 (I.c2w c)+{-# INLINE memberChar #-}++mkTable :: B.ByteString -> B.ByteString+mkTable s = I.unsafeCreate 32 $ \t -> do+            _ <- I.memset t 0 32+            U.unsafeUseAsCStringLen s $ \(p, l) ->+              let loop n | n == l = return ()+                         | otherwise = do+                    c <- peekByteOff p n :: IO Word8+                    let I byte bit = index (fromIntegral c)+                    prev <- peekByteOff t byte :: IO Word8+                    pokeByteOff t byte (prev .|. bit)+                    loop (n + 1)+              in loop 0++charClass :: String -> FastSet+charClass = set . B8.pack . go+    where go (a:'-':b:xs) = [a..b] ++ go xs+          go (x:xs) = x : go xs+          go _ = ""
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Internal.hs view
@@ -0,0 +1,485 @@+{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings, RecordWildCards #-}+-- |+-- Module      :  Data.Attoparsec.ByteString.Internal+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient parser combinators for 'ByteString' strings,+-- loosely based on the Parsec library.++module Data.Attoparsec.ByteString.Internal+    (+    -- * Parser types+      Parser+    , Result++    -- * Running parsers+    , parse+    , parseOnly++    -- * Combinators+    , module Data.Attoparsec.Combinator++    -- * Parsing individual bytes+    , satisfy+    , satisfyWith+    , anyWord8+    , skip+    , word8+    , notWord8++    -- ** Lookahead+    , peekWord8+    , peekWord8'++    -- ** Byte classes+    , inClass+    , notInClass++    -- * Parsing more complicated structures+    , storable++    -- * Efficient string handling+    , skipWhile+    , string+    , stringTransform+    , take+    , scan+    , runScanner+    , takeWhile+    , takeWhile1+    , takeTill++    -- ** Consume all remaining input+    , takeByteString+    , takeLazyByteString++    -- * Utilities+    , endOfLine+    , endOfInput+    , match+    , atEnd+    ) where++import Control.Applicative ((<|>), (<$>))+import Control.Monad (when)+import Data.Attoparsec.ByteString.Buffer (Buffer, buffer)+import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8)+import Data.Attoparsec.Combinator ((<?>))+import Data.Attoparsec.Internal+import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)+import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success)+import Data.ByteString (ByteString)+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (castPtr, minusPtr, plusPtr)+import Foreign.Storable (Storable(peek, sizeOf))+import Prelude hiding (getChar, succ, take, takeWhile)+import qualified Data.Attoparsec.ByteString.Buffer as Buf+import qualified Data.Attoparsec.Internal.Types as T+import qualified Data.ByteString as B8+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Unsafe as B++type Parser = T.Parser ByteString+type Result = IResult ByteString+type Failure r = T.Failure ByteString Buffer r+type Success a r = T.Success ByteString Buffer a r++-- | The parser @satisfy p@ succeeds for any byte for which the+-- predicate @p@ returns 'True'. Returns the byte that is actually+-- parsed.+--+-- >digit = satisfy isDigit+-- >    where isDigit w = w >= 48 && w <= 57+satisfy :: (Word8 -> Bool) -> Parser Word8+satisfy p = do+  h <- peekWord8'+  if p h+    then advance 1 >> return h+    else fail "satisfy"+{-# INLINE satisfy #-}++-- | The parser @skip p@ succeeds for any byte for which the predicate+-- @p@ returns 'True'.+--+-- >skipDigit = skip isDigit+-- >    where isDigit w = w >= 48 && w <= 57+skip :: (Word8 -> Bool) -> Parser ()+skip p = do+  h <- peekWord8'+  if p h+    then advance 1+    else fail "skip"++-- | The parser @satisfyWith f p@ transforms a byte, and succeeds if+-- the predicate @p@ returns 'True' on the transformed value. The+-- parser returns the transformed byte that was parsed.+satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a+satisfyWith f p = do+  h <- peekWord8'+  let c = f h+  if p c+    then advance 1 >> return c+    else fail "satisfyWith"+{-# INLINE satisfyWith #-}++storable :: Storable a => Parser a+storable = hack undefined+ where+  hack :: Storable b => b -> Parser b+  hack dummy = do+    (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy)+    return . B.inlinePerformIO . withForeignPtr fp $ \p ->+        peek (castPtr $ p `plusPtr` o)++-- | Consume @n@ bytes of input, but succeed only if the predicate+-- returns 'True'.+takeWith :: Int -> (ByteString -> Bool) -> Parser ByteString+takeWith n0 p = do+  let n = max n0 0+  s <- ensure n+  if p s+    then advance n >> return s+    else fail "takeWith"++-- | Consume exactly @n@ bytes of input.+take :: Int -> Parser ByteString+take n = takeWith n (const True)+{-# INLINE take #-}++-- | @string s@ parses a sequence of bytes that identically match+-- @s@. Returns the parsed string (i.e. @s@).  This parser consumes no+-- input if it fails (even if a partial match).+--+-- /Note/: The behaviour of this parser is different to that of the+-- similarly-named parser in Parsec, as this one is all-or-nothing.+-- To illustrate the difference, the following parser will fail under+-- Parsec given an input of @\"for\"@:+--+-- >string "foo" <|> string "for"+--+-- The reason for its failure is that the first branch is a+-- partial match, and will consume the letters @\'f\'@ and @\'o\'@+-- before failing.  In attoparsec, the above parser will /succeed/ on+-- that input, because the failed first branch will consume nothing.+string :: ByteString -> Parser ByteString+string s = takeWith (B.length s) (==s)+{-# INLINE string #-}++stringTransform :: (ByteString -> ByteString) -> ByteString+                -> Parser ByteString+stringTransform f s = takeWith (B.length s) ((==f s) . f)+{-# INLINE stringTransform #-}++-- | Skip past input for as long as the predicate returns 'True'.+skipWhile :: (Word8 -> Bool) -> Parser ()+skipWhile p = go+ where+  go = do+    t <- B8.takeWhile p <$> get+    continue <- inputSpansChunks (B.length t)+    when continue go+{-# INLINE skipWhile #-}++-- | Consume input as long as the predicate returns 'False'+-- (i.e. until it returns 'True'), and return the consumed input.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'True' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'Control.Applicative.many', because such+-- parsers loop until a failure occurs.  Careless use will thus result+-- in an infinite loop.+takeTill :: (Word8 -> Bool) -> Parser ByteString+takeTill p = takeWhile (not . p)+{-# INLINE takeTill #-}++-- | Consume input as long as the predicate returns 'True', and return+-- the consumed input.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'False' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'Control.Applicative.many', because such+-- parsers loop until a failure occurs.  Careless use will thus result+-- in an infinite loop.+takeWhile :: (Word8 -> Bool) -> Parser ByteString+takeWhile p = (B.concat . reverse) `fmap` go []+ where+  go acc = do+    s <- B8.takeWhile p <$> get+    continue <- inputSpansChunks (B.length s)+    if continue+      then go (s:acc)+      else return (s:acc)+{-# INLINE takeWhile #-}++takeRest :: Parser [ByteString]+takeRest = go []+ where+  go acc = do+    input <- wantInput+    if input+      then do+        s <- get+        advance (B.length s)+        go (s:acc)+      else return (reverse acc)++-- | Consume all remaining input and return it as a single string.+takeByteString :: Parser ByteString+takeByteString = B.concat `fmap` takeRest++-- | Consume all remaining input and return it as a single string.+takeLazyByteString :: Parser L.ByteString+takeLazyByteString = L.fromChunks `fmap` takeRest++data T s = T {-# UNPACK #-} !Int s++scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s)+         -> Parser r+scan_ f s0 p = go [] s0+ where+  go acc s1 = do+    let scanner (B.PS fp off len) =+          withForeignPtr fp $ \ptr0 -> do+            let start = ptr0 `plusPtr` off+                end   = start `plusPtr` len+                inner ptr !s+                  | ptr < end = do+                    w <- peek ptr+                    case p s w of+                      Just s' -> inner (ptr `plusPtr` 1) s'+                      _       -> done (ptr `minusPtr` start) s+                  | otherwise = done (ptr `minusPtr` start) s+                done !i !s = return (T i s)+            inner start s1+    bs <- get+    let T i s' = inlinePerformIO $ scanner bs+        !h = B.unsafeTake i bs+    continue <- inputSpansChunks i+    if continue+      then go (h:acc) s'+      else f s' (h:acc)+{-# INLINE scan_ #-}++-- | A stateful scanner.  The predicate consumes and transforms a+-- state argument, and each transformed state is passed to successive+-- invocations of the predicate on each byte of the input until one+-- returns 'Nothing' or the input ends.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'Nothing' on the first byte of input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'Control.Applicative.many', because such+-- parsers loop until a failure occurs.  Careless use will thus result+-- in an infinite loop.+scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString+scan = scan_ $ \_ chunks ->+  case chunks of+    [x] -> return x+    xs  -> return $! B.concat $ reverse xs+{-# INLINE scan #-}++-- | Like 'scan', but generalized to return the final state of the+-- scanner.+runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s)+runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s)+{-# INLINE runScanner #-}++-- | Consume input as long as the predicate returns 'True', and return+-- the consumed input.+--+-- This parser requires the predicate to succeed on at least one byte+-- of input: it will fail if the predicate never returns 'True' or if+-- there is no input left.+takeWhile1 :: (Word8 -> Bool) -> Parser ByteString+takeWhile1 p = do+  (`when` demandInput) =<< endOfChunk+  s <- B8.takeWhile p <$> get+  let len = B.length s+  if len == 0+    then fail "takeWhile1"+    else do+      advance len+      eoc <- endOfChunk+      if eoc+        then (s<>) `fmap` takeWhile p+        else return s++-- | Match any byte in a set.+--+-- >vowel = inClass "aeiou"+--+-- Range notation is supported.+--+-- >halfAlphabet = inClass "a-nA-N"+--+-- To add a literal @\'-\'@ to a set, place it at the beginning or end+-- of the string.+inClass :: String -> Word8 -> Bool+inClass s = (`memberWord8` mySet)+    where mySet = charClass s+          {-# NOINLINE mySet #-}+{-# INLINE inClass #-}++-- | Match any byte not in a set.+notInClass :: String -> Word8 -> Bool+notInClass s = not . inClass s+{-# INLINE notInClass #-}++-- | Match any byte.+anyWord8 :: Parser Word8+anyWord8 = satisfy $ const True+{-# INLINE anyWord8 #-}++-- | Match a specific byte.+word8 :: Word8 -> Parser Word8+word8 c = satisfy (== c) <?> show c+{-# INLINE word8 #-}++-- | Match any byte except the given one.+notWord8 :: Word8 -> Parser Word8+notWord8 c = satisfy (/= c) <?> "not " ++ show c+{-# INLINE notWord8 #-}++-- | Match any byte, to perform lookahead. Returns 'Nothing' if end of+-- input has been reached. Does not consume any input.+--+-- /Note/: Because this parser does not fail, do not use it with+-- combinators such as 'Control.Applicative.many', because such+-- parsers loop until a failure occurs.  Careless use will thus result+-- in an infinite loop.+peekWord8 :: Parser (Maybe Word8)+peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ ->+  case () of+    _| pos_ < Buf.length t ->+       let !w = Buf.unsafeIndex t pos_+       in succ t pos more (Just w)+     | more == Complete ->+       succ t pos more Nothing+     | otherwise ->+       let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_+                                 in succ t' pos' more' (Just w)+           lose' t' pos' more' = succ t' pos' more' Nothing+       in prompt t pos more lose' succ'+{-# INLINE peekWord8 #-}++-- | Match any byte, to perform lookahead.  Does not consume any+-- input, but will fail if end of input has been reached.+peekWord8' :: Parser Word8+peekWord8' = T.Parser $ \t pos more lose succ ->+    if lengthAtLeast pos 1 t+    then succ t pos more (Buf.unsafeIndex t (fromPos pos))+    else let succ' t' pos' more' bs' = succ t' pos' more' $! B.unsafeHead bs'+         in ensureSuspended 1 t pos more lose succ'+{-# INLINE peekWord8' #-}++-- | Match either a single newline character @\'\\n\'@, or a carriage+-- return followed by a newline character @\"\\r\\n\"@.+endOfLine :: Parser ()+endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ())++-- | Terminal failure continuation.+failK :: Failure a+failK t (Pos pos) _more stack msg = Fail (Buf.unsafeDrop pos t) stack msg+{-# INLINE failK #-}++-- | Terminal success continuation.+successK :: Success a a+successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a+{-# INLINE successK #-}++-- | Run a parser.+parse :: Parser a -> ByteString -> Result a+parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK+{-# INLINE parse #-}++-- | Run a parser that cannot be resupplied via a 'Partial' result.+--+-- This function does not force a parser to consume all of its input.+-- Instead, any residual input will be discarded.  To force a parser+-- to consume all of its input, use something like this:+--+-- @+--'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput')+-- @+parseOnly :: Parser a -> ByteString -> Either String a+parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of+                  Fail _ _ err -> Left err+                  Done _ a     -> Right a+                  _            -> error "parseOnly: impossible error!"+{-# INLINE parseOnly #-}++get :: Parser ByteString+get = T.Parser $ \t pos more _lose succ ->+  succ t pos more (Buf.unsafeDrop (fromPos pos) t)+{-# INLINE get #-}++endOfChunk :: Parser Bool+endOfChunk = T.Parser $ \t pos more _lose succ ->+  succ t pos more (fromPos pos == Buf.length t)+{-# INLINE endOfChunk #-}++inputSpansChunks :: Int -> Parser Bool+inputSpansChunks i = T.Parser $ \t pos_ more _lose succ ->+  let pos = pos_ + Pos i+  in if fromPos pos < Buf.length t || more == Complete+     then succ t pos more False+     else let lose' t' pos' more' = succ t' pos' more' False+              succ' t' pos' more' = succ t' pos' more' True+          in prompt t pos more lose' succ'+{-# INLINE inputSpansChunks #-}++advance :: Int -> Parser ()+advance n = T.Parser $ \t pos more _lose succ ->+  succ t (pos + Pos n) more ()+{-# INLINE advance #-}++ensureSuspended :: Int -> Buffer -> Pos -> More+                -> Failure r+                -> Success ByteString r+                -> Result r+ensureSuspended n t pos more lose succ =+    runParser (demandInput >> go) t pos more lose succ+  where go = T.Parser $ \t' pos' more' lose' succ' ->+          if lengthAtLeast pos' n t'+          then succ' t' pos' more' (substring pos (Pos n) t')+          else runParser (demandInput >> go) t' pos' more' lose' succ'++-- | If at least @n@ elements of input are available, return the+-- current input, otherwise fail.+ensure :: Int -> Parser ByteString+ensure n = T.Parser $ \t pos more lose succ ->+    if lengthAtLeast pos n t+    then succ t pos more (substring pos (Pos n) t)+    -- The uncommon case is kept out-of-line to reduce code size:+    else ensureSuspended n t pos more lose succ+-- Non-recursive so the bounds check can be inlined:+{-# INLINE ensure #-}++-- | Return both the result of a parse and the portion of the input+-- that was consumed while it was being parsed.+match :: Parser a -> Parser (ByteString, a)+match p = T.Parser $ \t pos more lose succ ->+  let succ' t' pos' more' a =+        succ t' pos' more' (substring pos (pos'-pos) t', a)+  in runParser p t pos more lose succ'++lengthAtLeast :: Pos -> Int -> Buffer -> Bool+lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n+{-# INLINE lengthAtLeast #-}++substring :: Pos -> Pos -> Buffer -> ByteString+substring (Pos pos) (Pos n) = Buf.substring pos n+{-# INLINE substring #-}
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Combinator.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module      :  Data.Attoparsec.Combinator+-- Copyright   :  Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Useful parser combinators, similar to those provided by Parsec.+module Data.Attoparsec.Combinator+    (+    -- * Combinators+      try+    , (<?>)+    , choice+    , count+    , option+    , many'+    , many1+    , many1'+    , manyTill+    , manyTill'+    , sepBy+    , sepBy'+    , sepBy1+    , sepBy1'+    , skipMany+    , skipMany1+    , eitherP+    , feed+    , satisfyElem+    , endOfInput+    , atEnd+    ) where++import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2,+                            many, (<|>), (*>), (<$>))+import Control.Monad (MonadPlus(..))+import Data.Attoparsec.Internal.Types (Parser(..), IResult(..))+import Data.Attoparsec.Internal (endOfInput, atEnd, satisfyElem)+import Data.ByteString (ByteString)+import Data.Monoid (Monoid(mappend))+import Prelude hiding (succ)++-- | Attempt a parse, and if it fails, rewind the input so that no+-- input appears to have been consumed.+--+-- This combinator is provided for compatibility with Parsec.+-- attoparsec parsers always backtrack on failure.+try :: Parser i a -> Parser i a+try p = p+{-# INLINE try #-}++-- | Name the parser, in case failure occurs.+(<?>) :: Parser i a+      -> String                 -- ^ the name to use if parsing fails+      -> Parser i a+p <?> msg0 = Parser $ \t pos more lose succ ->+             let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg+             in runParser p t pos more lose' succ+{-# INLINE (<?>) #-}+infix 0 <?>++-- | @choice ps@ tries to apply the actions in the list @ps@ in order,+-- until one of them succeeds. Returns the value of the succeeding+-- action.+choice :: Alternative f => [f a] -> f a+choice = foldr (<|>) empty+{-# SPECIALIZE choice :: [Parser ByteString a]+                      -> Parser ByteString a #-}++-- | @option x p@ tries to apply action @p@. If @p@ fails without+-- consuming input, it returns the value @x@, otherwise the value+-- returned by @p@.+--+-- > priority  = option 0 (digitToInt <$> digit)+option :: Alternative f => a -> f a -> f a+option x p = p <|> pure x+{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-}++-- | A version of 'liftM2' that is strict in the result of its first+-- action.+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c+liftM2' f a b = do+  !x <- a+  y <- b+  return (f x y)+{-# INLINE liftM2' #-}++-- | @many' p@ applies the action @p@ /zero/ or more times. Returns a+-- list of the returned values of @p@. The value returned by @p@ is+-- forced to WHNF.+--+-- >  word  = many' letter+many' :: (MonadPlus m) => m a -> m [a]+many' p = many_p+  where many_p = some_p `mplus` return []+        some_p = liftM2' (:) p many_p+{-# INLINE many' #-}++-- | @many1 p@ applies the action @p@ /one/ or more times. Returns a+-- list of the returned values of @p@.+--+-- >  word  = many1 letter+many1 :: Alternative f => f a -> f [a]+many1 p = liftA2 (:) p (many p)+{-# INLINE many1 #-}++-- | @many1' p@ applies the action @p@ /one/ or more times. Returns a+-- list of the returned values of @p@. The value returned by @p@ is+-- forced to WHNF.+--+-- >  word  = many1' letter+many1' :: (MonadPlus m) => m a -> m [a]+many1' p = liftM2' (:) p (many' p)+{-# INLINE many1' #-}++-- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@.+--+-- > commaSep p  = p `sepBy` (symbol ",")+sepBy :: Alternative f => f a -> f s -> f [a]+sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []+{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s+                     -> Parser ByteString [a] #-}++-- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@. The value+-- returned by @p@ is forced to WHNF.+--+-- > commaSep p  = p `sepBy'` (symbol ",")+sepBy' :: (MonadPlus m) => m a -> m s -> m [a]+sepBy' p s = scan `mplus` return []+  where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])+{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s+                      -> Parser ByteString [a] #-}++-- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@.+--+-- > commaSep p  = p `sepBy1` (symbol ",")+sepBy1 :: Alternative f => f a -> f s -> f [a]+sepBy1 p s = scan+    where scan = liftA2 (:) p ((s *> scan) <|> pure [])+{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s+                      -> Parser ByteString [a] #-}++-- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@. The value+-- returned by @p@ is forced to WHNF.+--+-- > commaSep p  = p `sepBy1'` (symbol ",")+sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]+sepBy1' p s = scan+    where scan = liftM2' (:) p ((s >> scan) `mplus` return [])+{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s+                       -> Parser ByteString [a] #-}++-- | @manyTill p end@ applies action @p@ /zero/ or more times until+-- action @end@ succeeds, and returns the list of values returned by+-- @p@.  This can be used to scan comments:+--+-- >  simpleComment   = string "<!--" *> manyTill anyChar (string "-->")+--+-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@.+-- While this will work, it is not very efficient, as it will cause a+-- lot of backtracking.)+manyTill :: Alternative f => f a -> f b -> f [a]+manyTill p end = scan+    where scan = (end *> pure []) <|> liftA2 (:) p scan+{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b+                        -> Parser ByteString [a] #-}++-- | @manyTill' p end@ applies action @p@ /zero/ or more times until+-- action @end@ succeeds, and returns the list of values returned by+-- @p@.  This can be used to scan comments:+--+-- >  simpleComment   = string "<!--" *> manyTill' anyChar (string "-->")+--+-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@.+-- While this will work, it is not very efficient, as it will cause a+-- lot of backtracking.)+--+-- The value returned by @p@ is forced to WHNF.+manyTill' :: (MonadPlus m) => m a -> m b -> m [a]+manyTill' p end = scan+    where scan = (end >> return []) `mplus` liftM2' (:) p scan+{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b+                         -> Parser ByteString [a] #-}++-- | Skip zero or more instances of an action.+skipMany :: Alternative f => f a -> f ()+skipMany p = scan+    where scan = (p *> scan) <|> pure ()+{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-}++-- | Skip one or more instances of an action.+skipMany1 :: Alternative f => f a -> f ()+skipMany1 p = p *> skipMany p+{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-}++-- | Apply the given action repeatedly, returning every result.+count :: Monad m => Int -> m a -> m [a]+count n p = sequence (replicate n p)+{-# INLINE count #-}++-- | Combine two alternatives.+eitherP :: (Alternative f) => f a -> f b -> f (Either a b)+eitherP a b = (Left <$> a) <|> (Right <$> b)+{-# INLINE eitherP #-}++-- | If a parser has returned a 'T.Partial' result, supply it with more+-- input.+feed :: Monoid i => IResult i r -> i -> IResult i r+feed f@(Fail _ _ _) _ = f+feed (Partial k) d    = k d+feed (Done t r) d     = Done (mappend t d) r+{-# INLINE feed #-}
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-}+-- |+-- Module      :  Data.Attoparsec.Internal+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient parser combinators, loosely based on the Parsec+-- library.++module Data.Attoparsec.Internal+    ( compareResults+    , prompt+    , demandInput+    , wantInput+    , endOfInput+    , atEnd+    , satisfyElem+    ) where++import Control.Applicative ((<$>))+#if __GLASGOW_HASKELL__ >= 700+import Data.ByteString (ByteString)+#endif+import Data.Attoparsec.Internal.Types+import Prelude hiding (succ)++-- | Compare two 'IResult' values for equality.+--+-- If both 'IResult's are 'Partial', the result will be 'Nothing', as+-- they are incomplete and hence their equality cannot be known.+-- (This is why there is no 'Eq' instance for 'IResult'.)+compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool+compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =+    Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)+compareResults (Done t0 r0) (Done t1 r1) =+    Just (t0 == t1 && r0 == r1)+compareResults (Partial _) (Partial _) = Nothing+compareResults _ _ = Just False++-- | Ask for input.  If we receive any, pass it to a success+-- continuation, otherwise to a failure continuation.+prompt :: Chunk t+       => State t -> Pos -> More+       -> (State t -> Pos -> More -> IResult t r)+       -> (State t -> Pos -> More -> IResult t r)+       -> IResult t r+prompt t pos _more lose succ = Partial $ \s ->+  if nullChunk s+  then lose t pos Complete+  else succ (pappendChunk t s) pos Incomplete+#if __GLASGOW_HASKELL__ >= 700+{-# SPECIALIZE prompt :: State ByteString -> Pos -> More+                      -> (State ByteString -> Pos -> More+                          -> IResult ByteString r)+                      -> (State ByteString -> Pos -> More+                          -> IResult ByteString r)+                      -> IResult ByteString r #-}+#endif++-- | Immediately demand more input via a 'Partial' continuation+-- result.+demandInput :: Chunk t => Parser t ()+demandInput = Parser $ \t pos more lose succ ->+  case more of+    Complete -> lose t pos more [] "not enough input"+    _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input"+             succ' t' pos' more' = succ t' pos' more' ()+         in prompt t pos more lose' succ'+#if __GLASGOW_HASKELL__ >= 700+{-# SPECIALIZE demandInput :: Parser ByteString () #-}+#endif++-- | This parser always succeeds.  It returns 'True' if any input is+-- available either immediately or on demand, and 'False' if the end+-- of all input has been reached.+wantInput :: forall t . Chunk t => Parser t Bool+wantInput = Parser $ \t pos more _lose succ ->+  case () of+    _ | pos < atBufferEnd (undefined :: t) t -> succ t pos more True+      | more == Complete -> succ t pos more False+      | otherwise       -> let lose' t' pos' more' = succ t' pos' more' False+                               succ' t' pos' more' = succ t' pos' more' True+                           in prompt t pos more lose' succ'+{-# INLINE wantInput #-}++-- | Match only if all input has been consumed.+endOfInput :: forall t . Chunk t => Parser t ()+endOfInput = Parser $ \t pos more lose succ ->+  case () of+    _| pos < atBufferEnd (undefined :: t) t -> lose t pos more [] "endOfInput"+     | more == Complete -> succ t pos more ()+     | otherwise ->+       let lose' t' pos' more' _ctx _msg = succ t' pos' more' ()+           succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput"+       in  runParser demandInput t pos more lose' succ'+#if __GLASGOW_HASKELL__ >= 700+{-# SPECIALIZE endOfInput :: Parser ByteString () #-}+#endif++-- | Return an indication of whether the end of input has been+-- reached.+atEnd :: Chunk t => Parser t Bool+atEnd = not <$> wantInput+{-# INLINE atEnd #-}++satisfySuspended :: forall t r . Chunk t+                 => (ChunkElem t -> Bool)+                 -> State t -> Pos -> More+                 -> Failure t (State t) r+                 -> Success t (State t) (ChunkElem t) r+                 -> IResult t r+satisfySuspended p t pos more lose succ =+    runParser (demandInput >> go) t pos more lose succ+  where go = Parser $ \t' pos' more' lose' succ' ->+          case bufferElemAt (undefined :: t) pos' t' of+            Just (e, l) | p e -> succ' t' (pos' + Pos l) more' e+                        | otherwise -> lose' t' pos' more' [] "satisfyElem"+            Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ'+#if __GLASGOW_HASKELL__ >= 700+{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool)+                                -> State ByteString -> Pos -> More+                                -> Failure ByteString (State ByteString) r+                                -> Success ByteString (State ByteString)+                                           (ChunkElem ByteString) r+                                -> IResult ByteString r #-}+#endif++-- | The parser @satisfyElem p@ succeeds for any chunk element for which the+-- predicate @p@ returns 'True'. Returns the element that is+-- actually parsed.+satisfyElem :: forall t . Chunk t+            => (ChunkElem t -> Bool) -> Parser t (ChunkElem t)+satisfyElem p = Parser $ \t pos more lose succ ->+    case bufferElemAt (undefined :: t) pos t of+      Just (e, l) | p e -> succ t (pos + Pos l) more e+                  | otherwise -> lose t pos more [] "satisfyElem"+      Nothing -> satisfySuspended p t pos more lose succ+{-# INLINE satisfyElem #-}
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Fhthagn.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings,+    RecordWildCards, MagicHash, UnboxedTuples #-}++module Data.Attoparsec.Internal.Fhthagn+    (+      inlinePerformIO+    ) where++import GHC.Base (realWorld#)+import GHC.IO (IO(IO))++-- | Just like unsafePerformIO, but we inline it. Big performance gains as+-- it exposes lots of things to further inlining. /Very unsafe/. In+-- particular, you should do no memory allocation inside an+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.+inlinePerformIO :: IO a -> a+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r+{-# INLINE inlinePerformIO #-}
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings,+    Rank2Types, RecordWildCards, TypeFamilies #-}+-- |+-- Module      :  Data.Attoparsec.Internal.Types+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient parser combinators, loosely based on the Parsec+-- library.++module Data.Attoparsec.Internal.Types+    (+      Parser(..)+    , State+    , Failure+    , Success+    , Pos(..)+    , IResult(..)+    , More(..)+    , (<>)+    , Chunk(..)+    ) where++import Control.Applicative (Alternative(..), Applicative(..), (<$>))+import Control.DeepSeq (NFData(rnf))+import Control.Monad (MonadPlus(..))+import Data.Word (Word8)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Internal (w2c)+import Data.Monoid (Monoid(..))+import Prelude hiding (getChar, succ)+import qualified Data.Attoparsec.ByteString.Buffer as B++newtype Pos = Pos { fromPos :: Int }+            deriving (Eq, Ord, Show, Num)++-- | The result of a parse.  This is parameterised over the type @i@+-- of string that was processed.+--+-- This type is an instance of 'Functor', where 'fmap' transforms the+-- value in a 'Done' result.+data IResult i r =+    Fail i [String] String+    -- ^ The parse failed.  The @i@ parameter is the input that had+    -- not yet been consumed when the failure occurred.  The+    -- @[@'String'@]@ is a list of contexts in which the error+    -- occurred.  The 'String' is the message describing the error, if+    -- any.+  | Partial (i -> IResult i r)+    -- ^ Supply this continuation with more input so that the parser+    -- can resume.  To indicate that no more input is available, pass+    -- an empty string to the continuation.+    --+    -- __Note__: if you get a 'Partial' result, do not call its+    -- continuation more than once.+  | Done i r+    -- ^ The parse succeeded.  The @i@ parameter is the input that had+    -- not yet been consumed (if any) when the parse succeeded.++instance (Show i, Show r) => Show (IResult i r) where+    show (Fail t stk msg) =+      unwords [ "Fail", show t, show stk, show msg]+    show (Partial _)          = "Partial _"+    show (Done t r)       = unwords ["Done", show t, show r]++instance (NFData i, NFData r) => NFData (IResult i r) where+    rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg+    rnf (Partial _)  = ()+    rnf (Done t r)   = rnf t `seq` rnf r+    {-# INLINE rnf #-}++instance Functor (IResult i) where+    fmap _ (Fail t stk msg) = Fail t stk msg+    fmap f (Partial k)      = Partial (fmap f . k)+    fmap f (Done t r)   = Done t (f r)++-- | The core parser type.  This is parameterised over the types @i@+-- of string being processed and @t@ of internal state representation.+--+-- This type is an instance of the following classes:+--+-- * 'Monad', where 'fail' throws an exception (i.e. fails) with an+--   error message.+--+-- * 'Functor' and 'Applicative', which follow the usual definitions.+--+-- * 'MonadPlus', where 'mzero' fails (with no error message) and+--   'mplus' executes the right-hand parser if the left-hand one+--   fails.  When the parser on the right executes, the input is reset+--   to the same state as the parser on the left started with. (In+--   other words, attoparsec is a backtracking parser that supports+--   arbitrary lookahead.)+--+-- * 'Alternative', which follows 'MonadPlus'.+newtype Parser i a = Parser {+      runParser :: forall r.+                   State i -> Pos -> More+                -> Failure i (State i)   r+                -> Success i (State i) a r+                -> IResult i r+    }++type family State i+type instance State ByteString = B.Buffer++type Failure i t   r = t -> Pos -> More -> [String] -> String+                       -> IResult i r+type Success i t a r = t -> Pos -> More -> a -> IResult i r++-- | Have we read all available input?+data More = Complete | Incomplete+            deriving (Eq, Show)++instance Monoid More where+    mappend c@Complete _ = c+    mappend _ m          = m+    mempty               = Incomplete++instance Monad (Parser i) where+    fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg+      where msg = "Failed reading: " ++ err+    {-# INLINE fail #-}++    return v = Parser $ \t pos more _lose succ -> succ t pos more v+    {-# INLINE return #-}++    m >>= k = Parser $ \t !pos more lose succ ->+        let succ' t' !pos' more' a = runParser (k a) t' pos' more' lose succ+        in runParser m t pos more lose succ'+    {-# INLINE (>>=) #-}++plus :: Parser i a -> Parser i a -> Parser i a+plus f g = Parser $ \t pos more lose succ ->+  let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ+  in runParser f t pos more lose' succ++instance MonadPlus (Parser i) where+    mzero = fail "mzero"+    {-# INLINE mzero #-}+    mplus = plus++instance Functor (Parser i) where+    fmap f p = Parser $ \t pos more lose succ ->+      let succ' t' pos' more' a = succ t' pos' more' (f a)+      in runParser p t pos more lose succ'+    {-# INLINE fmap #-}++apP :: Parser i (a -> b) -> Parser i a -> Parser i b+apP d e = do+  b <- d+  a <- e+  return (b a)+{-# INLINE apP #-}++instance Applicative (Parser i) where+    pure   = return+    {-# INLINE pure #-}+    (<*>)  = apP+    {-# INLINE (<*>) #-}++    -- These definitions are equal to the defaults, but this+    -- way the optimizer doesn't have to work so hard to figure+    -- that out.+    (*>)   = (>>)+    {-# INLINE (*>) #-}+    x <* y = x >>= \a -> y >> return a+    {-# INLINE (<*) #-}++instance Monoid (Parser i a) where+    mempty  = fail "mempty"+    {-# INLINE mempty #-}+    mappend = plus+    {-# INLINE mappend #-}++instance Alternative (Parser i) where+    empty = fail "empty"+    {-# INLINE empty #-}++    (<|>) = plus+    {-# INLINE (<|>) #-}++    many v = many_v+        where many_v = some_v <|> pure []+              some_v = (:) <$> v <*> many_v+    {-# INLINE many #-}++    some v = some_v+      where+        many_v = some_v <|> pure []+        some_v = (:) <$> v <*> many_v+    {-# INLINE some #-}++(<>) :: (Monoid m) => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}++-- | A common interface for input chunks.+class Monoid c => Chunk c where+  type ChunkElem c+  -- | Test if the chunk is empty.+  nullChunk :: c -> Bool+  -- | Append chunk to a buffer.+  pappendChunk :: State c -> c -> State c+  -- | Position at the end of a buffer. The first argument is ignored.+  atBufferEnd :: c -> State c -> Pos+  -- | Return the buffer element at the given position along with its length.+  bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int)+  -- | Map an element to the corresponding character.+  --   The first argument is ignored.+  chunkElemToChar :: c -> ChunkElem c -> Char++instance Chunk ByteString where+  type ChunkElem ByteString = Word8+  nullChunk = BS.null+  {-# INLINE nullChunk #-}+  pappendChunk = B.pappend+  {-# INLINE pappendChunk #-}+  atBufferEnd _ = Pos . B.length+  {-# INLINE atBufferEnd #-}+  bufferElemAt _ (Pos i) buf+    | i < B.length buf = Just (B.unsafeIndex buf i, 1)+    | otherwise = Nothing+  {-# INLINE bufferElemAt #-}+  chunkElemToChar _ = w2c+  {-# INLINE chunkElemToChar #-}
+ haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Number.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module      :  Data.Attoparsec.Number+-- Copyright   :  Bryan O'Sullivan 2007-2014+-- License     :  BSD3+--+-- Maintainer  :  bos@serpentine.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- This module is deprecated, and both the module and 'Number' type+-- will be removed in the next major release.  Use the+-- <http://hackage.haskell.org/package/scientific scientific> package+-- and the 'Data.Scientific.Scientific' type instead.+--+-- A simple number type, useful for parsing both exact and inexact+-- quantities without losing much precision.+module Data.Attoparsec.Number+    {-# DEPRECATED "This module will be removed in the next major release." #-}+    (+      Number(..)+    ) where++import Control.DeepSeq (NFData(rnf))+import Data.Data (Data)+import Data.Function (on)+import Data.Typeable (Typeable)++-- | A numeric type that can represent integers accurately, and+-- floating point numbers to the precision of a 'Double'.+--+-- /Note/: this type is deprecated, and will be removed in the next+-- major release.  Use the 'Data.Scientific.Scientific' type instead.+data Number = I !Integer+            | D {-# UNPACK #-} !Double+              deriving (Typeable, Data)+{-# DEPRECATED Number "Use Scientific instead." #-}++instance Show Number where+    show (I a) = show a+    show (D a) = show a++instance NFData Number where+    rnf (I _) = ()+    rnf (D _) = ()+    {-# INLINE rnf #-}++binop :: (Integer -> Integer -> a) -> (Double -> Double -> a)+      -> Number -> Number -> a+binop _ d (D a) (D b) = d a b+binop i _ (I a) (I b) = i a b+binop _ d (D a) (I b) = d a (fromIntegral b)+binop _ d (I a) (D b) = d (fromIntegral a) b+{-# INLINE binop #-}++instance Eq Number where+    (==) = binop (==) (==)+    {-# INLINE (==) #-}++    (/=) = binop (/=) (/=)+    {-# INLINE (/=) #-}++instance Ord Number where+    (<) = binop (<) (<)+    {-# INLINE (<) #-}++    (<=) = binop (<=) (<=)+    {-# INLINE (<=) #-}++    (>) = binop (>) (>)+    {-# INLINE (>) #-}++    (>=) = binop (>=) (>=)+    {-# INLINE (>=) #-}++    compare = binop compare compare+    {-# INLINE compare #-}++instance Num Number where+    (+) = binop (((I$!).) . (+)) (((D$!).) . (+))+    {-# INLINE (+) #-}++    (-) = binop (((I$!).) . (-)) (((D$!).) . (-))+    {-# INLINE (-) #-}++    (*) = binop (((I$!).) . (*)) (((D$!).) . (*))+    {-# INLINE (*) #-}++    abs (I a) = I $! abs a+    abs (D a) = D $! abs a+    {-# INLINE abs #-}++    negate (I a) = I $! negate a+    negate (D a) = D $! negate a+    {-# INLINE negate #-}++    signum (I a) = I $! signum a+    signum (D a) = D $! signum a+    {-# INLINE signum #-}++    fromInteger = (I$!) . fromInteger+    {-# INLINE fromInteger #-}++instance Real Number where+    toRational (I a) = fromIntegral a+    toRational (D a) = toRational a+    {-# INLINE toRational #-}++instance Fractional Number where+    fromRational = (D$!) . fromRational+    {-# INLINE fromRational #-}++    (/) = binop (((D$!).) . (/) `on` fromIntegral)+                (((D$!).) . (/))+    {-# INLINE (/) #-}++    recip (I a) = D $! recip (fromIntegral a)+    recip (D a) = D $! recip a+    {-# INLINE recip #-}++instance RealFrac Number where+    properFraction (I a) = (fromIntegral a,0)+    properFraction (D a) = case properFraction a of+                             (i,d) -> (i,D d)+    {-# INLINE properFraction #-}+    truncate (I a) = fromIntegral a+    truncate (D a) = truncate a+    {-# INLINE truncate #-}+    round (I a) = fromIntegral a+    round (D a) = round a+    {-# INLINE round #-}+    ceiling (I a) = fromIntegral a+    ceiling (D a) = ceiling a+    {-# INLINE ceiling #-}+    floor (I a) = fromIntegral a+    floor (D a) = floor a+    {-# INLINE floor #-}
haddock.cabal view
@@ -1,5 +1,5 @@ name:                 haddock-version:              2.14.3+version:              2.15.0 synopsis:             A documentation-generation tool for Haskell libraries description:          Haddock is a documentation-generation tool for Haskell                       libraries@@ -26,54 +26,28 @@   doc/docbook-xml.mk   doc/fptools.css   doc/haddock.xml-  haddock.spec-  haskell.vim-  src/haddock.sh+  haddock-api/src/haddock.sh   html-test/src/*.hs   html-test/ref/*.html   latex-test/src/Simple/*.hs   latex-test/ref/Simple/*.tex   latex-test/ref/Simple/*.sty -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- flag in-ghc-tree   description: Are we in a GHC tree?   default: False   manual: True --- Using this disables -O2, and hence allows to use --disable-optimization,--- which is about twice as fast.  This should probably be the default, but we--- need some benchmarks first..-flag dev-  default: False-  manual: True- executable haddock   default-language:     Haskell2010   main-is:              Main.hs   hs-source-dirs:       driver-  if flag(dev)-    ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs-  else-    ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2+  ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2    build-depends:     base >= 4.3 && < 4.8   if flag(in-ghc-tree)-    hs-source-dirs: src, vendor/attoparsec-0.10.4.0+    hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src     cpp-options: -DIN_GHC_TREE     build-depends:       filepath,@@ -83,20 +57,28 @@       array,       xhtml >= 3000.2 && < 3000.3,       Cabal >= 1.10,-      ghc == 7.8.*,+      ghc == 7.8.3,       bytestring      other-modules:-      Documentation.Haddock+      Documentation.Haddock.Parser+      Documentation.Haddock.Types+      Documentation.Haddock.Doc       Data.Attoparsec       Data.Attoparsec.ByteString+      Data.Attoparsec.ByteString.Buffer       Data.Attoparsec.ByteString.Char8-      Data.Attoparsec.Combinator-      Data.Attoparsec.Number       Data.Attoparsec.ByteString.FastSet       Data.Attoparsec.ByteString.Internal+      Data.Attoparsec.Combinator       Data.Attoparsec.Internal+      Data.Attoparsec.Internal.Fhthagn       Data.Attoparsec.Internal.Types+      Data.Attoparsec.Number+      Documentation.Haddock.Utf8+      Documentation.Haddock.Parser.Util++      Documentation.Haddock       Haddock       Haddock.Interface       Haddock.Interface.Rename@@ -105,8 +87,6 @@       Haddock.Interface.LexParseRn       Haddock.Interface.ParseModuleHeader       Haddock.Parser-      Haddock.Parser.Util-      Haddock.Utf8       Haddock.Utils       Haddock.Backends.Xhtml       Haddock.Backends.Xhtml.Decl@@ -128,81 +108,7 @@       Haddock.GhcUtils       Haddock.Convert   else-    build-depends:  haddock--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.*--  if flag(in-ghc-tree)-    cpp-options: -DIN_GHC_TREE-  else-    build-depends: ghc-paths--  hs-source-dirs:       src, vendor/attoparsec-0.10.4.0-  if flag(dev)-    ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs-  else-    ghc-options:          -funbox-strict-fields -Wall -fwarn-tabs -O2--  exposed-modules:-    Documentation.Haddock--  other-modules:-    Data.Attoparsec-    Data.Attoparsec.ByteString-    Data.Attoparsec.ByteString.Char8-    Data.Attoparsec.Combinator-    Data.Attoparsec.Number-    Data.Attoparsec.ByteString.FastSet-    Data.Attoparsec.ByteString.Internal-    Data.Attoparsec.Internal-    Data.Attoparsec.Internal.Types-    Haddock-    Haddock.Interface-    Haddock.Interface.Rename-    Haddock.Interface.Create-    Haddock.Interface.AttachInstances-    Haddock.Interface.LexParseRn-    Haddock.Interface.ParseModuleHeader-    Haddock.Parser-    Haddock.Parser.Util-    Haddock.Utf8-    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--  if flag(in-ghc-tree)-    buildable: False+    build-depends:  haddock-api == 2.15.0  test-suite html-test   type:             exitcode-stdio-1.0@@ -218,34 +124,6 @@   hs-source-dirs:   latex-test   build-depends:    base, directory, process, filepath, Cabal -test-suite spec-  type:             exitcode-stdio-1.0-  default-language: Haskell2010-  main-is:          Spec.hs-  hs-source-dirs:-      test-    , src-    , vendor/attoparsec-0.10.4.0--  other-modules:-      Helper-      Haddock.ParserSpec-      Haddock.Utf8Spec-      Haddock.Parser.UtilSpec--  build-depends:-      base-    , bytestring-    , ghc-    , containers-    , deepseq-    , array-    , hspec-    , QuickCheck == 2.*--  build-depends:-      haddock- source-repository head   type:     git-  location: http://git.haskell.org/haddock.git+  location: https://github.com/haskell/haddock.git
− haddock.spec 
@@ -1,81 +0,0 @@-# This is an RPM spec file that specifies how to package-# haddock for Red Hat Linux and, possibly, similar systems.-# It has been tested on Red Hat Linux 7.2 and SuSE Linux 9.1.-#-# If this file is part of a tarball, you can build RPMs directly from-# the tarball by using the following command:-#-#    rpm -ta haddock-(VERSION).tar.gz-#-# The resulting package will be placed in the RPMS/(arch) subdirectory-# of your RPM build directory (usually /usr/src/redhat or ~/rpm), with-# the name haddock-(VERSION)-(RELEASE).noarch.rpm.  A corresponding-# source RPM package will be in the SRPMS subdirectory.-#-# NOTE TO HADDOCK MAINTAINERS: When you release a new version of-# Haskell mode, update the version definition below to match the-# version label of your release tarball.--%define name    haddock-%define version 2.14.1-%define release 1--Name:           %{name}-Version:        %{version}-Release:        %{release}-License:        BSD-like-Group:          Development/Languages/Haskell-URL:            http://haskell.org/haddock/-Source:         http://haskell.org/haddock/haddock-%{version}.tar.gz-Packager:       Sven Panne <sven.panne@aedion.de>-BuildRoot:      %{_tmppath}/%{name}-%{version}-build-Prefix:         %{_prefix}-BuildRequires:  ghc, docbook-dtd, docbook-xsl-stylesheets, libxslt, libxml2, fop, xmltex, dvips-Summary:        A documentation tool for annotated Haskell source code--%description-Haddock is a tool for automatically generating documentation from-annotated Haskell source code. It is primary intended for documenting-libraries, but it should be useful for any kind of Haskell code.--Haddock lets you write documentation annotations next to the-definitions of functions and types in the source code, in a syntax-that is easy on the eye when writing the source code (no heavyweight-mark-up). The documentation generated by Haddock is fully hyperlinked--- click on a type name in a type signature to go straight to the-definition, and documentation, for that type.--Haddock can generate documentation in multiple formats; currently HTML-is implemented, and there is partial support for generating DocBook.-The generated HTML uses stylesheets, so you need a fairly up-to-date-browser to view it properly (Mozilla, Konqueror, Opera, and IE 6-should all be ok).--%prep-%setup--%build-runhaskell Setup.lhs configure --prefix=%{_prefix} --docdir=%{_datadir}/doc/packages/%{name}-runhaskell Setup.lhs build-cd doc-test -f configure || autoreconf-./configure-make html--%install-runhaskell Setup.lhs copy --destdir=${RPM_BUILD_ROOT}--%clean-rm -rf ${RPM_BUILD_ROOT}--%files-%defattr(-,root,root)-%doc CHANGES-%doc LICENSE-%doc README-%doc TODO-%doc doc/haddock-%doc examples-%doc haskell.vim-%{prefix}/bin/haddock-%{prefix}/share/haddock-%{version}
− haskell.vim 
@@ -1,68 +0,0 @@-" Attempt to add haddock highlighting for haskell comments-" It should be placed in ~/.vim/after/syntax/haskell.vim-" Brad Bowman <haddock.vim@bereft.net>--syn match   hsHdocChunk "$\i\+" contained-syn match   hsHdocMod /"\(\i\|[.]\)\+"/ contained-syn match   hsHdocLink "'\(\i\|[.#]\)\+'" contained-syn region  hsHdocAnchor start="\\\@<!#" skip="\\#" end="\\\@<!#" contained oneline-" I think emphasis can span multiple lines-syn region  hsHdocEm start="\\\@<!/" skip="\\/" end="\\\@!/" contained oneline-syn region  hsHdocURL start="\\\@<!<" end="\\\@<!>" contained oneline-syn region  hsHdocCode start="\\\@<!@" skip="\\@" end="\\\@<!@" contained oneline-syn region  hsHdocBCodeBlock start="^@\(\s\|$\)" end="^@\s*$" contained-syn region  hsHdocLCodeBlock start="\(^\s*--\s*\)\@<=@\s*$" end="\(^\s*--\s*\)\@<=@\s*$" contained-syn match   hsHdocBHeading "^\s*\*\+" contained-syn match   hsHdocLHeading "\(^\s*--\s*\)\@<=\*\+" contained-syn match   hsHdocBTracks "^\s*>" contained-" match only the > using a look-behind-syn match   hsHdocLTracks "\(^\s*--\s*\)\@<=>" contained--" todo: numbered lists, mark haddock start separately-"syn match   hsHdocStart "\([$^|]\|\*\+\)" contained--syn cluster hsHdocSpecial -  \ contains=hsHdocMod,hsHdocLink,hsHdocEm,hsHdocCode,hsHdocURL,-  \ hsHdocAnchor,hsHdocChunk--syn region  hsHdocDef start="^\s*\(--\)\?\s*\[" end="\]" contained contains=hsHdocSpecial--syn region  hsHdocLines start="--\s*\([$\^|]\|\*\+\)" -                      \ skip="^\s*\(--.*\)$" -                      \ end="^\s*\(\$\|--\)\@!" -                      \ contains=@hsHdocSpecial,hsHdocLTracks,hsHdocLHeading,hsHdocLCodeBlock,hsHdocDef-syn region  hsHdocBlock start="{-\s*\([$\^|]\|\*\+\)" end="-}" -                      \ contains=@hsHdocSpecial,hsHdocBTracks,hsHdocBHeading,hsHdocBCodeBlock,hsHdocDef--syn sync minlines=20--if version >= 508 || !exists("did_haddock_syntax_inits")-  if version < 508-    let did_haddock_syntax_inits = 1-    command -nargs=+ HiLink hi link <args>-  else-    command -nargs=+ HiLink hi def link <args>-  endif--  HiLink hsHdocLines            hsHdoc-  HiLink hsHdocBlock            hsHdoc-  HiLink hsHdoc                 PreProc-  HiLink hsHdocAnchor           Special-  HiLink hsHdocChunk            Special-  HiLink hsHdocMod              Special-  HiLink hsHdocLink             Special-  HiLink hsHdocEm               Special-  HiLink hsHdocURL              Special-  HiLink hsHdocCode             Special-  HiLink hsHdocLHeading         Special-  HiLink hsHdocBHeading         Special-  HiLink hsHdocLTracks          Special-  HiLink hsHdocBTracks          Special-  HiLink hsHdocBCodeBlock       Special-  HiLink hsHdocLCodeBlock       Special-  HiLink hsHdocSpecial          Special--  delcommand HiLink                       -endif--" Options for vi: sw=2 sts=2 nowrap ft=vim
html-test/ref/A.html view
@@ -172,7 +172,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/AdvanceTypes.html view
@@ -90,7 +90,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/B.html view
@@ -164,7 +164,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bold.html view
@@ -17,11 +17,11 @@   ><div id="package-header"     ><ul class="links" id="page-menu"       ><li-	><a href="index.html"+	><a href="" 	  >Contents</a 	  ></li 	><li-	><a href="doc-index.html"+	><a href="" 	  >Index</a 	  ></li 	></ul@@ -46,9 +46,9 @@ 	>Synopsis</p 	><ul id="section.syn" class="hide" onclick="toggleSection('syn')" 	><li class="src short"-	  ><a href="#v:foo"+	  ><a href="" 	    >foo</a-	    > ::  t</li+	    > :: t</li 	  ></ul 	></div       ><div id="interface"@@ -58,7 +58,7 @@ 	><p class="src" 	  ><a name="v:foo" class="def" 	    >foo</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><p 	    >Some <strong@@ -90,9 +90,9 @@       ></div     ><div id="footer"     ><p-      >Produced by <a href="http://www.haskell.org/haddock/"+      >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug1.html view
@@ -95,7 +95,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug195.html view
@@ -172,7 +172,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug2.html view
@@ -58,7 +58,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug201.html view
@@ -95,7 +95,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug294.html view
@@ -158,7 +158,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug298.html view
@@ -48,19 +48,19 @@ 	><li class="src short" 	  ><a href="" 	    >(&lt;^&gt;)</a-	    > ::  (a -&gt; a) -&gt; a -&gt; a</li+	    > :: (a -&gt; a) -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><a href="" 	    >(&lt;^)</a-	    > ::  a -&gt; a -&gt; a</li+	    > :: a -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><a href="" 	    >(^&gt;)</a-	    > ::  a -&gt; a -&gt; a</li+	    > :: a -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><a href="" 	    >(&#8902;^)</a-	    > ::  a -&gt; a -&gt; a</li+	    > :: a -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><a href="" 	    >f</a@@ -74,25 +74,25 @@ 	><p class="src" 	  ><a name="v:-60--94--62-" class="def" 	    >(&lt;^&gt;)</a-	    > ::  (a -&gt; a) -&gt; a -&gt; a</p+	    > :: (a -&gt; a) -&gt; a -&gt; a</p 	  ></div 	><div class="top" 	><p class="src" 	  ><a name="v:-60--94-" class="def" 	    >(&lt;^)</a-	    > ::  a -&gt; a -&gt; a</p+	    > :: a -&gt; a -&gt; a</p 	  ></div 	><div class="top" 	><p class="src" 	  ><a name="v:-94--62-" class="def" 	    >(^&gt;)</a-	    > ::  a -&gt; a -&gt; a</p+	    > :: a -&gt; a -&gt; a</p 	  ></div 	><div class="top" 	><p class="src" 	  ><a name="v:-8902--94-" class="def" 	    >(&#8902;^)</a-	    > ::  a -&gt; a -&gt; a</p+	    > :: a -&gt; a -&gt; a</p 	  ></div 	><div class="top" 	><p class="src"
html-test/ref/Bug3.html view
@@ -75,7 +75,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
+ html-test/ref/Bug313.html view
@@ -0,0 +1,132 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml"+><head+  ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"+     /><title+    >Bug313</title+    ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean"+     /><script src="haddock-util.js" type="text/javascript"+    ></script+    ><script type="text/javascript"+    >//<![CDATA[+window.onload = function () {pageLoad();setSynopsis("mini_Bug313.html");};+//]]>+</script+    ></head+  ><body+  ><div id="package-header"+    ><ul class="links" id="page-menu"+      ><li+	><a href=""+	  >Contents</a+	  ></li+	><li+	><a href=""+	  >Index</a+	  ></li+	></ul+      ><p class="caption empty"+      >&nbsp;</p+      ></div+    ><div id="content"+    ><div id="module-header"+      ><table class="info"+	><tr+	  ><th+	    >Safe Haskell</th+	    ><td+	    >Safe-Inferred</td+	    ></tr+	  ></table+	><p class="caption"+	>Bug313</p+	></div+      ><div id="description"+      ><p class="caption"+	>Description</p+	><div class="doc"+	><p+	  >The first list is incorrectly numbered as 1. 2. 1.; the second example+ renders fine (1. 2. 3.).</p+	  ><p+	  >See <a href=""+	    >https://github.com/haskell/haddock/issues/313</a+	    ></p+	  ></div+	></div+      ><div id="synopsis"+      ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')"+	>Synopsis</p+	><ul id="section.syn" class="hide" onclick="toggleSection('syn')"+	><li class="src short"+	  ><a href=""+	    >a</a+	    > :: a</li+	  ><li class="src short"+	  ><a href=""+	    >b</a+	    > :: a</li+	  ></ul+	></div+      ><div id="interface"+      ><h1+	>Documentation</h1+	><div class="top"+	><p class="src"+	  ><a name="v:a" class="def"+	    >a</a+	    > :: a</p+	  ><div class="doc"+	  ><p+	    >Some text.</p+	    ><ol+	    ><li+	      >Item 1</li+	      ><li+	      ><p+		>Item 2</p+		><pre+		>Some code</pre+		></li+	      ><li+	      >Item 3</li+	      ></ol+	    ><p+	    >Some more text.</p+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><a name="v:b" class="def"+	    >b</a+	    > :: a</p+	  ><div class="doc"+	  ><p+	    >Some text.</p+	    ><ol+	    ><li+	      >Item 1</li+	      ><li+	      ><p+		>Item 2</p+		><pre+		>Some code</pre+		></li+	      ><li+	      >Item 3</li+	      ></ol+	    ><p+	    >Some more text.</p+	    ></div+	  ></div+	></div+      ></div+    ><div id="footer"+    ><p+      >Produced by <a href=""+	>Haddock</a+	> version 2.15.0</p+      ></div+    ></body+  ></html+>
html-test/ref/Bug4.html view
@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug6.html view
@@ -322,7 +322,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug7.html view
@@ -161,7 +161,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug8.html view
@@ -86,7 +86,7 @@ 	><p class="src" 	  ><a name="v:-45--45--62-" class="def" 	    >(--&gt;)</a-	    > ::  t -&gt; t1 -&gt; <a href="Bug8.html#t:Typ"+	    > :: t -&gt; t1 -&gt; <a href="" 	    >Typ</a 	    > <span class="fixity" 	    >infix 9</span@@ -98,9 +98,9 @@ 	><p class="src" 	  ><a name="v:-45--45--45--62-" class="def" 	    >(---&gt;)</a-	    > ::  [a] -&gt; <a href="Bug8.html#t:Typ"+	    > :: [a] -&gt; <a href="" 	    >Typ</a-	    > -&gt; <a href="Bug8.html#t:Typ"+	    > -&gt; <a href="" 	    >Typ</a 	    > <span class="fixity" 	    >infix 9</span@@ -112,19 +112,19 @@ 	><p class="src" 	  ><a name="v:s" class="def" 	    >s</a-	    > ::  t</p+	    > :: t</p 	  ></div 	><div class="top" 	><p class="src" 	  ><a name="v:t" class="def" 	    >t</a-	    > ::  t</p+	    > :: t</p 	  ></div 	><div class="top" 	><p class="src" 	  ><a name="v:main" class="def" 	    >main</a-	    > ::  t</p+	    > :: t</p 	  ></div 	></div       ></div@@ -132,7 +132,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bug85.html view
@@ -128,7 +128,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/BugDeprecated.html view
@@ -53,13 +53,13 @@ 	    ></li 	  ><li class="src short" 	  ><a href=""-	    >baz</a+	    >bar</a 	    > :: <a href="" 	    >Int</a 	    ></li 	  ><li class="src short" 	  ><a href=""-	    >bar</a+	    >baz</a 	    > :: <a href="" 	    >Int</a 	    ></li@@ -71,13 +71,13 @@ 	    ></li 	  ><li class="src short" 	  ><a href=""-	    >three</a+	    >two</a 	    > :: <a href="" 	    >Int</a 	    ></li 	  ><li class="src short" 	  ><a href=""-	    >two</a+	    >three</a 	    > :: <a href="" 	    >Int</a 	    ></li@@ -102,29 +102,29 @@ 	  ></div 	><div class="top" 	><p class="src"-	  ><a name="v:baz" class="def"-	    >baz</a+	  ><a name="v:bar" class="def"+	    >bar</a 	    > :: <a href="" 	    >Int</a 	    ></p 	  ><div class="doc" 	  ><div class="warning" 	    ><p-	      >Deprecated: for baz</p+	      >Deprecated: for bar</p 	      ></div 	    ></div 	  ></div 	><div class="top" 	><p class="src"-	  ><a name="v:bar" class="def"-	    >bar</a+	  ><a name="v:baz" class="def"+	    >baz</a 	    > :: <a href="" 	    >Int</a 	    ></p 	  ><div class="doc" 	  ><div class="warning" 	    ><p-	      >Deprecated: for bar</p+	      >Deprecated: for baz</p 	      ></div 	    ></div 	  ></div@@ -141,39 +141,35 @@ 	      >Deprecated: for one</p 	      ></div 	    ><p-	    >some documentation for one, two and three</p+	    >some documentation for one</p 	    ></div 	  ></div 	><div class="top" 	><p class="src"-	  ><a name="v:three" class="def"-	    >three</a+	  ><a name="v:two" class="def"+	    >two</a 	    > :: <a href="" 	    >Int</a 	    ></p 	  ><div class="doc" 	  ><div class="warning" 	    ><p-	      >Deprecated: for three</p+	      >Deprecated: for two</p 	      ></div-	    ><p-	    >some documentation for one, two and three</p 	    ></div 	  ></div 	><div class="top" 	><p class="src"-	  ><a name="v:two" class="def"-	    >two</a+	  ><a name="v:three" class="def"+	    >three</a 	    > :: <a href="" 	    >Int</a 	    ></p 	  ><div class="doc" 	  ><div class="warning" 	    ><p-	      >Deprecated: for two</p+	      >Deprecated: for three</p 	      ></div-	    ><p-	    >some documentation for one, two and three</p 	    ></div 	  ></div 	></div@@ -182,7 +178,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/BugExportHeadings.html view
@@ -198,7 +198,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Bugs.html view
@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/CrossPackageDocs.html view
@@ -280,7 +280,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.0</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedClass.html view
@@ -148,7 +148,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedData.html view
@@ -182,7 +182,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedFunction.html view
@@ -100,7 +100,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedFunction2.html view
@@ -76,7 +76,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedFunction3.html view
@@ -76,7 +76,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedModule.html view
@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedModule2.html view
@@ -68,7 +68,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedNewtype.html view
@@ -148,7 +148,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedReExport.html view
@@ -117,7 +117,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedRecord.html view
@@ -140,7 +140,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedTypeFamily.html view
@@ -98,7 +98,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/DeprecatedTypeSynonym.html view
@@ -106,7 +106,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Examples.html view
@@ -167,7 +167,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Extensions.html view
@@ -60,7 +60,7 @@ 	><li class="src short" 	  ><a href="" 	    >foobar</a-	    > ::  t</li+	    > :: t</li 	  ></ul 	></div       ><div id="interface"@@ -70,7 +70,7 @@ 	><p class="src" 	  ><a name="v:foobar" class="def" 	    >foobar</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><p 	    >Bar</p@@ -82,7 +82,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/FunArgs.html view
@@ -55,9 +55,7 @@ 	    ><table 	    ><tr 	      ><td class="src"-		>:: <span class="keyword"-		  >forall</span-		  > a . <a href=""+		>:: <a href="" 		  >Ord</a 		  > a</td 		><td class="doc empty"@@ -154,13 +152,129 @@ 	      ></table 	    ></div 	  ></div+	><div class="top"+	><p class="src"+	  ><a name="v:h" class="def"+	    >h</a+	    ></p+	  ><div class="subs arguments"+	  ><p class="caption"+	    >Arguments</p+	    ><table+	    ><tr+	      ><td class="src"+		>:: a</td+		><td class="doc"+		><p+		  >First argument</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; b</td+		><td class="doc"+		><p+		  >Second argument</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; c</td+		><td class="doc"+		><p+		  >Third argument</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; d</td+		><td class="doc"+		><p+		  >Result</p+		  ></td+		></tr+	      ></table+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><a name="v:i" class="def"+	    >i</a+	    ></p+	  ><div class="subs arguments"+	  ><p class="caption"+	    >Arguments</p+	    ><table+	    ><tr+	      ><td class="src"+		>:: <span class="keyword"+		  >forall</span+		  > (b :: <a href=""+		  >()</a+		  >). (d ~ <a href=""+		  >()</a+		  >)</td+		><td class="doc empty"+		>&nbsp;</td+		></tr+	      ><tr+	      ><td class="src"+		>=&gt; a b c d</td+		><td class="doc"+		><p+		  >abcd</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; ()</td+		><td class="doc"+		><p+		  >Result</p+		  ></td+		></tr+	      ></table+	    ></div+	  ></div+	><div class="top"+	><p class="src"+	  ><a name="v:j" class="def"+	    >j</a+	    ></p+	  ><div class="subs arguments"+	  ><p class="caption"+	    >Arguments</p+	    ><table+	    ><tr+	      ><td class="src"+		>:: <span class="keyword"+		  >forall</span+		  > (a :: <a href=""+		  >()</a+		  >). proxy a</td+		><td class="doc"+		><p+		  >First argument</p+		  ></td+		></tr+	      ><tr+	      ><td class="src"+		>-&gt; b</td+		><td class="doc"+		><p+		  >Result</p+		  ></td+		></tr+	      ></table+	    ></div+	  ></div 	></div       ></div     ><div id="footer"     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/GADTRecords.html view
@@ -224,7 +224,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Hash.html view
@@ -72,7 +72,7 @@ 	>Description</p 	><div class="doc" 	><p-	  >Implementation of fixed-size hash tables, with a type +	  >Implementation of fixed-size hash tables, with a type   class for constructing hash values for structured types.</p 	  ></div 	></div@@ -317,7 +317,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/HiddenInstances.html view
@@ -156,7 +156,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/HiddenInstancesB.html view
@@ -132,7 +132,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Hyperlinks.html view
@@ -80,7 +80,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/IgnoreExports.html view
@@ -92,7 +92,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/ImplicitParams.html view
@@ -94,7 +94,7 @@ 	><p class="src" 	  ><a name="v:f" class="def" 	    >f</a-	    > ::  ((?x :: <a href=""+	    > :: ((?x :: <a href="" 	    >X</a 	    >) =&gt; a) -&gt; a</p 	  ></div@@ -104,7 +104,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Minimal.html view
@@ -87,16 +87,20 @@ 	    ><p class="src" 	    ><a name="v:foo" class="def" 	      >foo</a-	      >, <a name="v:bat" class="def"-	      >bat</a-	      >, <a name="v:bar" class="def"-	      >bar</a 	      > :: a</p 	    ><div class="doc" 	    ><p 	      >Any two of these are required...</p 	      ></div 	    ><p class="src"+	    ><a name="v:bar" class="def"+	      >bar</a+	      > :: a</p+	    ><p class="src"+	    ><a name="v:bat" class="def"+	      >bat</a+	      > :: a</p+	    ><p class="src" 	    ><a name="v:fooBarBat" class="def" 	      >fooBarBat</a 	      > :: (a, a, a)</p@@ -141,19 +145,31 @@ 	    ><p class="src" 	    ><a name="v:a" class="def" 	      >a</a-	      >, <a name="v:g" class="def"-	      >g</a-	      >, <a name="v:f" class="def"-	      >f</a-	      >, <a name="v:e" class="def"-	      >e</a-	      >, <a name="v:d" class="def"-	      >d</a-	      >, <a name="v:c" class="def"-	      >c</a-	      >, <a name="v:b" class="def"+	      > :: a</p+	    ><p class="src"+	    ><a name="v:b" class="def" 	      >b</a 	      > :: a</p+	    ><p class="src"+	    ><a name="v:c" class="def"+	      >c</a+	      > :: a</p+	    ><p class="src"+	    ><a name="v:d" class="def"+	      >d</a+	      > :: a</p+	    ><p class="src"+	    ><a name="v:e" class="def"+	      >e</a+	      > :: a</p+	    ><p class="src"+	    ><a name="v:f" class="def"+	      >f</a+	      > :: a</p+	    ><p class="src"+	    ><a name="v:g" class="def"+	      >g</a+	      > :: a</p 	    ></div 	  ></div 	><div class="top"@@ -181,11 +197,15 @@ 	    ><p class="src" 	    ><a name="v:x" class="def" 	      >x</a-	      >, <a name="v:z" class="def"-	      >z</a-	      >, <a name="v:y" class="def"+	      > :: a</p+	    ><p class="src"+	    ><a name="v:y" class="def" 	      >y</a 	      > :: a</p+	    ><p class="src"+	    ><a name="v:z" class="def"+	      >z</a+	      > :: a</p 	    ></div 	  ></div 	><div class="top"@@ -203,7 +223,9 @@ 	    ><p class="src" 	    ><a name="v:aaa" class="def" 	      >aaa</a-	      >, <a name="v:bbb" class="def"+	      > :: a</p+	    ><p class="src"+	    ><a name="v:bbb" class="def" 	      >bbb</a 	      > :: a</p 	    ></div@@ -255,7 +277,9 @@ 	    ><p class="src" 	    ><a name="v:eee" class="def" 	      >eee</a-	      >, <a name="v:fff" class="def"+	      > :: a</p+	    ><p class="src"+	    ><a name="v:fff" class="def" 	      >fff</a 	      > :: a</p 	    ></div@@ -266,7 +290,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/ModuleWithWarning.html view
@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/NamedDoc.html view
@@ -60,7 +60,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Nesting.html view
@@ -48,31 +48,31 @@ 	><li class="src short" 	  ><a href="" 	    >d</a-	    > ::  t</li+	    > :: t</li 	  ><li class="src short" 	  ><a href="" 	    >e</a-	    > ::  t</li+	    > :: t</li 	  ><li class="src short" 	  ><a href="" 	    >f</a-	    > ::  t</li+	    > :: t</li 	  ><li class="src short" 	  ><a href="" 	    >g</a-	    > ::  t</li+	    > :: t</li 	  ><li class="src short" 	  ><a href="" 	    >h</a-	    > ::  t</li+	    > :: t</li 	  ><li class="src short" 	  ><a href="" 	    >i</a-	    > ::  t</li+	    > :: t</li 	  ><li class="src short" 	  ><a href="" 	    >j</a-	    > ::  t</li+	    > :: t</li 	  ></ul 	></div       ><div id="interface"@@ -82,13 +82,17 @@ 	><p class="src" 	  ><a name="v:d" class="def" 	    >d</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><ul 	    ><li-	      >We can<ul+	      ><p+		>We can</p+		><ul 		><li-		  >easily go back<ol+		  ><p+		    >easily go back</p+		    ><ol 		    ><li 		      >some indentation</li 		      ></ol@@ -110,11 +114,13 @@ 	><p class="src" 	  ><a name="v:e" class="def" 	    >e</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><ul 	    ><li-	      >Beginning of list<ul+	      ><p+		>Beginning of list</p+		><ul 		><li 		  >second list</li 		  ></ul@@ -129,11 +135,13 @@ 	><p class="src" 	  ><a name="v:f" class="def" 	    >f</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><ul 	    ><li-	      >Beginning of list<pre+	      ><p+		>Beginning of list</p+		><pre 		>nested code     we preserve the space correctly </pre@@ -145,11 +153,13 @@ 	><p class="src" 	  ><a name="v:g" class="def" 	    >g</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><ul 	    ><li-	      >Beginning of list<ul+	      ><p+		>Beginning of list</p+		><ul 		><li 		  >Nested list</li 		  ></ul@@ -161,11 +171,13 @@ 	><p class="src" 	  ><a name="v:h" class="def" 	    >h</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><ul 	    ><li-	      >Beginning of list<pre+	      ><p+		>Beginning of list</p+		><pre 		>nested bird tracks</pre@@ -177,12 +189,14 @@ 	><p class="src" 	  ><a name="v:i" class="def" 	    >i</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><ul 	    ><li-	      >Beginning of list-This belongs to the list above!<pre+	      ><p+		>Beginning of list+This belongs to the list above!</p+		><pre 		>nested bird tracks@@ -194,12 +208,18 @@   without leading space</pre 		><ul 		><li-		  >Next list-More of the indented list.<ul+		  ><p+		    >Next list+More of the indented list.</p+		    ><ul 		    ><li-		      >Deeper<ul+		      ><p+			>Deeper</p+			><ul 			><li-			  >Deeper<ul+			  ><p+			    >Deeper</p+			    ><ul 			    ><li 			      >Even deeper!</li 			      ><li@@ -219,7 +239,7 @@ 	><p class="src" 	  ><a name="v:j" class="def" 	    >j</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><dl 	    ><dt@@ -232,12 +252,16 @@ tracks</pre 		><ul 		><li-		  >Next list-with more of the indented list content.<p+		  ><p+		    >Next list+with more of the indented list content.</p+		    ><p 		    >Even more content on a new line.</p 		    ><ol 		    ><li-		      >Different type of list<ol+		      ><p+			>Different type of list</p+			><ol 			><li 			  >Deeper</li 			  ></ol@@ -261,10 +285,8 @@ 			  ><dd 			  >No newline separation even in indented lists.         We can have any paragraph level element that we normally-        can, like headers<p-			    ><h3-			      >Level 3 header</h3-			      ></p+        can, like headers<h3+			    >Level 3 header</h3 			    ><p 			    >with some content&#8230;</p 			    ><ul@@ -287,7 +309,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/NoLayout.html view
@@ -78,7 +78,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/NonGreedy.html view
@@ -48,7 +48,7 @@ 	><li class="src short" 	  ><a href="" 	    >f</a-	    > ::  a</li+	    > :: a</li 	  ></ul 	></div       ><div id="interface"@@ -58,7 +58,7 @@ 	><p class="src" 	  ><a name="v:f" class="def" 	    >f</a-	    > ::  a</p+	    > :: a</p 	  ><div class="doc" 	  ><p 	    ><a href=""@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Operators.html view
@@ -56,15 +56,15 @@ 	><li class="src short" 	  ><a href="" 	    >(+-)</a-	    > ::  a -&gt; a -&gt; a</li+	    > :: a -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><a href="" 	    >(*/)</a-	    > ::  a -&gt; a -&gt; a</li+	    > :: a -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><a href="" 	    >foo</a-	    > ::  a -&gt; a -&gt; a</li+	    > :: a -&gt; a -&gt; a</li 	  ><li class="src short" 	  ><span class="keyword" 	    >data</span@@ -176,7 +176,7 @@ 	><p class="src" 	  ><a name="v:-43--45-" class="def" 	    >(+-)</a-	    > ::  a -&gt; a -&gt; a</p+	    > :: a -&gt; a -&gt; a</p 	  ><div class="doc" 	  ><p 	    >Operator with no fixity</p@@ -186,7 +186,7 @@ 	><p class="src" 	  ><a name="v:-42--47-" class="def" 	    >(*/)</a-	    > ::  a -&gt; a -&gt; a <span class="fixity"+	    > :: a -&gt; a -&gt; a <span class="fixity" 	    >infixr 7</span 	    ><span class="rightedge" 	    ></span@@ -200,7 +200,7 @@ 	><p class="src" 	  ><a name="v:foo" class="def" 	    >foo</a-	    > ::  a -&gt; a -&gt; a <span class="fixity"+	    > :: a -&gt; a -&gt; a <span class="fixity" 	    >infixl 3</span 	    ><span class="rightedge" 	    ></span@@ -450,7 +450,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/PatternSyns.html view
@@ -234,7 +234,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Properties.html view
@@ -84,7 +84,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/PruneWithWarning.html view
@@ -63,7 +63,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/QuasiExpr.html view
@@ -214,7 +214,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/QuasiQuote.html view
@@ -58,7 +58,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/SpuriousSuperclassConstraints.html view
@@ -114,7 +114,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/TH.html view
@@ -56,7 +56,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/TH2.html view
@@ -48,7 +48,7 @@ 	><p class="src" 	  ><a name="v:f" class="def" 	    >f</a-	    > ::  t -&gt; t</p+	    > :: t -&gt; t</p 	  ></div 	></div       ></div@@ -56,7 +56,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Test.html view
@@ -487,7 +487,7 @@ 	    ><li 	      ><a href="" 		>d</a-		> ::  <a href=""+		> :: <a href="" 		>T</a 		> a b</li 	      ><li@@ -657,7 +657,7 @@ 	  ><li class="src short" 	  ><a href="" 	    >withoutType</a-	    > ::  t</li+	    > :: t</li 	  ></ul 	></div       ><div id="interface"@@ -1535,7 +1535,7 @@ 	    ><p class="src" 	    ><a name="v:d" class="def" 	      >d</a-	      > ::  <a href=""+	      > :: <a href="" 	      >T</a 	      > a b</p 	    ><p class="src"@@ -2130,7 +2130,7 @@ 	><p class="src" 	  ><a name="v:withoutType" class="def" 	    >withoutType</a-	    > ::  t</p+	    > :: t</p 	  ><div class="doc" 	  ><p 	    >Comment on a definition without type signature</p@@ -2142,7 +2142,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Ticket112.html view
@@ -48,7 +48,7 @@ 	><li class="src short" 	  ><a href="" 	    >f</a-	    > ::  a</li+	    > :: a</li 	  ></ul 	></div       ><div id="interface"@@ -58,7 +58,7 @@ 	><p class="src" 	  ><a name="v:f" class="def" 	    >f</a-	    > ::  a</p+	    > :: a</p 	  ><div class="doc" 	  ><p 	    >...given a raw <code@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Ticket253_1.html view
@@ -84,7 +84,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Ticket253_2.html view
@@ -104,7 +104,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Ticket61.html view
@@ -72,7 +72,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Ticket75.html view
@@ -108,7 +108,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/TitledPicture.html view
@@ -102,7 +102,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/TypeFamilies.html view
@@ -1046,7 +1046,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/TypeFamilies2.html view
@@ -222,7 +222,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/TypeOperators.html view
@@ -120,7 +120,7 @@ 	><p class="src" 	  ><a name="v:biO" class="def" 	    >biO</a-	    > ::  (g <a href=""+	    > :: (g <a href="" 	    >`O`</a 	    > f) a</p 	  ></div@@ -166,7 +166,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Unicode.html view
@@ -74,7 +74,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/Visible.html view
@@ -60,7 +60,7 @@     ><p       >Produced by <a href="" 	>Haddock</a-	> version 2.14.2</p+	> version 2.15.0</p       ></div     ></body   ></html
html-test/ref/mini_A.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >A</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -45,7 +45,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >X</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"
html-test/ref/mini_AdvanceTypes.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Pattern</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_B.html view
@@ -37,7 +37,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >X</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_Bug1.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >T</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_Bug6.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >A</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -33,7 +33,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >B</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -41,7 +41,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >C</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -49,7 +49,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >D</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -57,7 +57,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >E</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_Bug7.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Foo</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"
html-test/ref/mini_Bug8.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Typ</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"
html-test/ref/mini_BugDeprecated.html view
@@ -28,13 +28,13 @@       ><div class="top"       ><p class="src" 	><a href="" target="main"-	  >baz</a+	  >bar</a 	  ></p 	></div       ><div class="top"       ><p class="src" 	><a href="" target="main"-	  >bar</a+	  >baz</a 	  ></p 	></div       ><div class="top"@@ -46,13 +46,13 @@       ><div class="top"       ><p class="src" 	><a href="" target="main"-	  >three</a+	  >two</a 	  ></p 	></div       ><div class="top"       ><p class="src" 	><a href="" target="main"-	  >two</a+	  >three</a 	  ></p 	></div       ></div
html-test/ref/mini_DeprecatedData.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Foo</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -33,7 +33,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >One</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_DeprecatedNewtype.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >SomeNewType</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -33,7 +33,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >SomeOtherNewType</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_DeprecatedRecord.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Foo</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_DeprecatedTypeSynonym.html view
@@ -25,7 +25,7 @@ 	  >type</span 	  > <a href="" target="main" 	  >TypeSyn</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -33,7 +33,7 @@ 	  >type</span 	  > <a href="" target="main" 	  >OtherTypeSyn</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_HiddenInstances.html view
@@ -33,7 +33,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >VisibleData</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_HiddenInstancesB.html view
@@ -33,7 +33,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Bar</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_QuasiExpr.html view
@@ -25,7 +25,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Expr</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -33,7 +33,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >BinOp</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"
html-test/ref/mini_Test.html view
@@ -69,7 +69,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >T6</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -135,7 +135,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >R</a-	  > </p+	  ></p 	></div       ><div class="top"       ><p class="src"@@ -143,7 +143,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >R1</a-	  > </p+	  ></p 	></div       ><h1       >Class declarations</h1
html-test/ref/mini_Ticket253_2.html view
@@ -31,7 +31,7 @@ 	  >data</span 	  > <a href="" target="main" 	  >Baz</a-	  > </p+	  ></p 	></div       ></div     ></body
html-test/ref/mini_TypeFamilies.html view
@@ -22,9 +22,49 @@     ><div class="top"       ><p class="src" 	><span class="keyword"+	  >data</span+	  > <a href="" target="main"+	  >X</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><span class="keyword"+	  >data</span+	  > <a href="" target="main"+	  >Y</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><span class="keyword"+	  >data</span+	  > <a href="" target="main"+	  >Z</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><span class="keyword"+	  >class</span+	  > <a href="" target="main"+	  >Test</a+	  > a</p+	></div+      ><div class="top"+      ><p class="src"+	><span class="keyword" 	  >type family</span 	  > <a href=""-	  >G</a+	  >Foo</a+	  > a :: k</p+	></div+      ><div class="top"+      ><p class="src"+	><span class="keyword"+	  >data family</span+	  > <a href=""+	  >Bat</a 	  > a :: *</p 	></div       ><div class="top"@@ -32,7 +72,7 @@ 	><span class="keyword" 	  >class</span 	  > <a href="" target="main"-	  >A</a+	  >Assoc</a 	  > a</p 	></div       ><div class="top"@@ -40,14 +80,24 @@ 	><span class="keyword" 	  >type family</span 	  > <a href=""-	  >F</a-	  > a </p+	  >Bar</a+	  > b</p 	></div       ><div class="top"       ><p class="src"-	><a href="" target="main"-	  >g</a-	  ></p+	><span class="keyword"+	  >type family</span+	  > a <a href=""+	  >&lt;&gt;</a+	  > b :: k</p+	></div+      ><div class="top"+      ><p class="src"+	><span class="keyword"+	  >class</span+	  > a <a href="" target="main"+	  >&gt;&lt;</a+	  > b</p 	></div       ></div     ></body
html-test/ref/mini_TypeOperators.html view
@@ -19,9 +19,7 @@       >TypeOperators</p       ></div     ><div id="interface"-    ><h1-      >stuff</h1-      ><div class="top"+    ><div class="top"       ><p class="src" 	><span class="keyword" 	  >data</span@@ -55,8 +53,40 @@ 	></div       ><div class="top"       ><p class="src"+	><span class="keyword"+	  >class</span+	  > a <a href="" target="main"+	  >&lt;=&gt;</a+	  > b</p+	></div+      ><div class="top"+      ><p class="src" 	><a href="" target="main" 	  >biO</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><a href="" target="main"+	  >f</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><a href="" target="main"+	  >g</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><a href="" target="main"+	  >x</a+	  ></p+	></div+      ><div class="top"+      ><p class="src"+	><a href="" target="main"+	  >y</a 	  ></p 	></div       ></div
+ html-test/src/Bug313.hs view
@@ -0,0 +1,37 @@+-- | The first list is incorrectly numbered as 1. 2. 1.; the second example+-- renders fine (1. 2. 3.).+--+-- See https://github.com/haskell/haddock/issues/313+module Bug313 where++{- |+Some text.++1. Item 1++2. Item 2++    > Some code++3. Item 3++Some more text.+-}+a :: a+a = undefined++{- |+Some text.++1. Item 1++2. Item 2++    > Some code++3. Item 3++-}+-- | Some more text.+b :: a+b = undefined
html-test/src/BugDeprecated.hs view
@@ -1,17 +1,25 @@ module BugDeprecated where -foo, bar, baz :: Int+foo :: Int foo = 23++bar :: Int bar = 23++baz :: Int baz = 23 {-# DEPRECATED foo "for foo" #-} {-# DEPRECATED bar "for bar" #-} {-# DEPRECATED baz "for baz" #-} --- | some documentation for one, two and three-one, two, three :: Int+-- | some documentation for one+one :: Int one = 23++two :: Int two = 23++three :: Int three = 23 {-# DEPRECATED one "for one" #-} {-# DEPRECATED two "for two" #-}
html-test/src/FunArgs.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE RankNTypes, DataKinds, TypeFamilies #-} module FunArgs where  f :: forall a. Ord a@@ -15,3 +15,24 @@   -> c -- ^ Third argument   -> d -- ^ Result g = undefined+++h :: forall a b c+  .  a -- ^ First argument+  -> b -- ^ Second argument+  -> c -- ^ Third argument+  -> forall d. d -- ^ Result+h = undefined+++i :: forall a (b :: ()) d. (d ~ '())+  => forall c+  .  a b c d -- ^ abcd+  -> ()      -- ^ Result+i = undefined+++j :: forall proxy (a :: ()) b+  .  proxy a -- ^ First argument+  -> b       -- ^ Result+j = undefined
html-test/src/Hash.hs view
@@ -1,5 +1,5 @@ {- |-  Implementation of fixed-size hash tables, with a type +  Implementation of fixed-size hash tables, with a type   class for constructing hash values for structured types. -} module Hash (@@ -30,7 +30,7 @@  -- | Looks up a key in the hash table, returns @'Just' val@ if the key -- was found, or 'Nothing' otherwise.-lookup 	:: Hash key => key -> IO (Maybe val)+lookup :: Hash key => key -> IO (Maybe val) lookup = undefined  -- | A class of types which can be hashed.
html-test/src/Minimal.hs view
@@ -10,7 +10,9 @@  class Foo a where   -- | Any two of these are required...-  foo, bar, bat :: a+  foo :: a+  bar :: a+  bat :: a    -- | .. or just this   fooBarBat :: (a,a,a)@@ -18,23 +20,34 @@   {-# MINIMAL (foo, bar) | (bar, bat) | (foo, bat) | fooBarBat #-}  class Weird a where-  a,b,c,d,e,f,g :: a+  a :: a+  b :: a+  c :: a+  d :: a+  e :: a+  f :: a+  g :: a    {-# MINIMAL ((a, b), c | (d | (e, (f | g)))) #-}  class NoMins a where-  x,y,z :: a+  x :: a+  y :: a+  z :: a    -- | Has a default implementation!   z = x  class FullMin a where-  aaa,bbb :: a+  aaa :: a+  bbb :: a  class PartialMin a where-  ccc,ddd :: a+  ccc :: a+  ddd :: a  class EmptyMin a where-  eee,fff :: a+  eee :: a+  fff :: a   eee = fff   fff = undefined
− resources/html/Classic.theme/haskell_icon.gif

binary file changed (911 → absent bytes)

− resources/html/Classic.theme/minus.gif

binary file changed (56 → absent bytes)

− resources/html/Classic.theme/plus.gif

binary file changed (59 → absent bytes)

− resources/html/Classic.theme/xhaddock.css 
@@ -1,499 +0,0 @@-* {-	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

binary file changed (1684 → absent bytes)

− resources/html/Ocean.std-theme/minus.gif

binary file changed (56 → absent bytes)

− resources/html/Ocean.std-theme/ocean.css 
@@ -1,577 +0,0 @@-/* @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

binary file changed (59 → absent bytes)

− resources/html/Ocean.std-theme/synopsis.png

binary file changed (11327 → absent bytes)

− resources/html/frames.html 
@@ -1,30 +0,0 @@-<!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 
@@ -1,344 +0,0 @@-// Haddock JavaScript utilities--var rspace = /\s\s+/g,-	  rtrim = /^\s+|\s+$/g;--function spaced(s) { return (" " + s + " ").replace(rspace, " "); }-function trim(s)   { return s.replace(rtrim, ""); }--function hasClass(elem, value) {-  var className = spaced(elem.className || "");-  return className.indexOf( " " + value + " " ) >= 0;-}--function addClass(elem, value) {-  var className = spaced(elem.className || "");-  if ( className.indexOf( " " + value + " " ) < 0 ) {-    elem.className = trim(className + " " + value);-  }-}--function removeClass(elem, value) {-  var className = spaced(elem.className || "");-  className = className.replace(" " + value + " ", " ");-  elem.className = trim(className);-}--function toggleClass(elem, valueOn, valueOff, bool) {-  if (bool == null) { bool = ! hasClass(elem, valueOn); }-  if (bool) {-    removeClass(elem, valueOff);-    addClass(elem, valueOn);-  }-  else {-    removeClass(elem, valueOn);-    addClass(elem, valueOff);-  }-  return bool;-}---function makeClassToggle(valueOn, valueOff)-{-  return function(elem, bool) {-    return toggleClass(elem, valueOn, valueOff, bool);-  }-}--toggleShow = makeClassToggle("show", "hide");-toggleCollapser = makeClassToggle("collapser", "expander");--function toggleSection(id)-{-  var b = toggleShow(document.getElementById("section." + id));-  toggleCollapser(document.getElementById("control." + id), b);-  rememberCollapsed(id, 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 &#9662;</a>"-      + "<ul id='style-menu' class='hide'>" + btns + "</ul>"-      + "</div>";-    addMenuItem(h);-  }-}--function setActiveStyleSheet(title) {-  var as = styles();-  var i, a, found;-  for(i=0; a = as[i]; i++) {-    a.disabled = true;-          // need to do this always, some browsers are edge triggered-    if(a.title == title) {-      found = a;-    }-  }-  if (found) {-    found.disabled = false;-    setCookie("haddock-style", title);-  }-  else {-    as[0].disabled = false;-    clearCookie("haddock-style");-  }-  styleMenu(false);-}--function resetStyle() {-  var s = getCookie("haddock-style");-  if (s) setActiveStyleSheet(s);-}---function styleMenu(show) {-  var m = document.getElementById('style-menu');-  if (m) toggleShow(m, show);-}---function pageLoad() {-  addStyleMenu();-  adjustForFrames();-  resetStyle();-  restoreCollapsed();-}-
− resources/latex/haddock.sty 
@@ -1,57 +0,0 @@-% Default Haddock style definitions.  To use your own style, invoke-% Haddock with the option --latex-style=mystyle.--\usepackage{tabulary} % see below--% make hyperlinks in the PDF, and add an expandabale index-\usepackage[pdftex,bookmarks=true]{hyperref}--\newenvironment{haddocktitle}-  {\begin{center}\bgroup\large\bfseries}-  {\egroup\end{center}}-\newenvironment{haddockprologue}{\vspace{1in}}{}--\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}}--\newcommand{\haddockbeginheader}{\hrulefill}-\newcommand{\haddockendheader}{\noindent\hrulefill}--% a little gap before the ``Methods'' header-\newcommand{\haddockpremethods}{\vspace{2ex}}--% inserted before \\begin{verbatim}-\newcommand{\haddockverb}{\small}--% an identifier: add an index entry-\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}}--% The tabulary environment lets us have a column that takes up ``the-% rest of the space''.  Unfortunately it doesn't allow-% the \end{tabulary} to be in the expansion of a macro, it must appear-% literally in the document text, so Haddock inserts-% the \end{tabulary} itself.-\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}-\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}}--\newcommand{\haddocktt}[1]{{\small \texttt{#1}}}-\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}}--\makeatletter-\newenvironment{haddockdesc}-               {\list{}{\labelwidth\z@ \itemindent-\leftmargin-                        \let\makelabel\haddocklabel}}-               {\endlist}-\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}}-\makeatother--% after a declaration, start a new line for the documentation.-% Otherwise, the documentation starts right after the declaration,-% because we're using the list environment and the declaration is the-% ``label''.  I tried making this newline part of the label, but-% couldn't get that to work reliably (the space seemed to stretch-% sometimes).-\newcommand{\haddockbegindoc}{\hfill\\[1ex]}--% spacing between paragraphs and no \parindent looks better-\parskip=10pt plus2pt minus2pt-\setlength{\parindent}{0cm}
− src/Documentation/Haddock.hs 
@@ -1,82 +0,0 @@--------------------------------------------------------------------------------- |--- 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(..),-  Example(..),-  Hyperlink(..),-  DocMarkup(..),-  Documentation(..),-  ArgMap,-  AliasMap,-  WarningMap,-  DocMap,-  HaddockModInfo(..),-  markup,--  -- * Interface files-  InterfaceFile(..),-  readInterfaceFile,-  nameCacheFromGhc,-  freshNameCache,-  NameCacheAccessor,--  -- * Flags and options-  Flag(..),-  DocOption(..),--  -- * Program entry point-  haddock,-) 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 
@@ -1,482 +0,0 @@-{-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE CPP, ScopedTypeVariables #-}--------------------------------------------------------------------------------- |--- Module      :  Haddock--- Copyright   :  (c) Simon Marlow 2003-2006,---                    David Waern  2006-2010--- 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, 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-#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 = 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' <- withGhc' 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--  withGhc' 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) = do-      eIface <- readInterfaceFile name_cache_accessor file-      case eIface of-        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] -> do-      str <- readFile filename-      case parseParasMaybe dflags str of-        Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename-        Just doc -> return (Just doc)-    _otherwise -> throwE "multiple -p/--prologue options"---#ifdef IN_GHC_TREE--getInTreeDir :: IO String-getInTreeDir = do-  m <- getExecDir-  case m of-    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 
@@ -1,170 +0,0 @@--------------------------------------------------------------------------------- |--- 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 "-&gt;", 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 
@@ -1,331 +0,0 @@--------------------------------------------------------------------------------- |--- 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 '<' = "&lt;"-        f '>' = "&gt;"-        f '&' = "&amp;"-        f x = [x]
− src/Haddock/Backends/LaTeX.hs 
@@ -1,1221 +0,0 @@-{-# 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 
@@ -1,690 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,885 +0,0 @@-{-# 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 Explicit tvs lctxt ltype)-      = (leader <+>-          hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>-          ppLContextNoArrow lctxt unicode qual,-          Nothing, [])-        : do_largs n (darrow unicode) ltype-    do_args n leader (HsForAllTy Implicit _ lctxt ltype)-      | not (null (unLoc lctxt))-      = (leader <+> ppLContextNoArrow lctxt unicode qual,-          Nothing, [])-        : 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)-      = (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, [])]--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 <+>-                            ppForAll 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 [-                             ppForAll 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 [ppForAll 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--ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName-         -> Located (HsContext DocName) -> Unicode -> Qualification -> Html-ppForAll 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 $-    hsep [ppForAll 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 
@@ -1,143 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,235 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,171 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,209 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,37 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,218 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,394 +0,0 @@-{-# LANGUAGE 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) ->-      let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps-      in SigD $ PatSynSig (synifyName ps)-                          (fmap (synifyType WithinType) (patSynTyDetails ps))-                          (synifyType WithinType res_ty)-                          (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 
@@ -1,69 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Haddock.Doc (-  docAppend-, docParagraph-, combineDocumentation-) where--import Data.Maybe-import Data.Monoid-import Haddock.Types-import Data.Char (isSpace)---- We put it here so that we can avoid a circular import--- anything relevant imports this module anyway-instance Monoid (Doc id) where-  mempty  = DocEmpty-  mappend = docAppend--combineDocumentation :: Documentation name -> Maybe (Doc name)-combineDocumentation (Documentation Nothing Nothing) = Nothing-combineDocumentation (Documentation mDoc mWarning)   = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc)--docAppend :: Doc id -> Doc id -> Doc id-docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)-docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d-docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2)-docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2)-docAppend DocEmpty d = d-docAppend d DocEmpty = d-docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2)-docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2))-docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d-docAppend d1 d2 = DocAppend d1 d2---- again to make parsing easier - we spot a paragraph whose only item--- is a DocMonospaced and make it into a DocCodeBlock-docParagraph :: Doc id -> Doc id-docParagraph (DocMonospaced p)-  = DocCodeBlock (docCodeBlock p)-docParagraph (DocAppend (DocString s1) (DocMonospaced p))-  | all isSpace s1-  = DocCodeBlock (docCodeBlock p)-docParagraph (DocAppend (DocString s1)-    (DocAppend (DocMonospaced p) (DocString s2)))-  | all isSpace s1 && all isSpace s2-  = DocCodeBlock (docCodeBlock p)-docParagraph (DocAppend (DocMonospaced p) (DocString s2))-  | all isSpace s2-  = DocCodeBlock (docCodeBlock p)-docParagraph p-  = DocParagraph p----- 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 :: Doc id -> Doc 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 
@@ -1,304 +0,0 @@-{-# 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 
@@ -1,244 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,221 +0,0 @@-{-# 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 
@@ -1,867 +0,0 @@-{-# LANGUAGE TupleSections, BangPatterns #-}-{-# 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 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.DeepSeq-import Control.Monad-import Data.Function (on)-import qualified Data.Foldable as F-import qualified Data.Traversable as T--import qualified Packages-import qualified Module-import qualified SrcLoc-import GHC-import HscTypes-import Name-import Bag-import RdrName-import TcRnTypes-import FastString (unpackFS, 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, _) <--    liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs--  let exports0 = fmap (reverse . map unLoc) mayExports-      exports-       | OptIgnoreExports `elem` opts = Nothing-       | otherwise = exports0--  warningMap <- liftErrMsg $ 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 <- liftErrMsg $ 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] -> ErrMsgM WarningMap-mkWarningMap dflags warnings gre exps = case warnings of-  NoWarnings  -> return M.empty-  WarnAll _   -> return M.empty-  WarnSome ws -> do-    let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ-              , let n = gre_name elt, n `elem` exps ]-    M.fromList <$> mapM parse ws'-  where-    parse (n, w) = (,) n <$> parseWarning dflags gre w---moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))-moduleWarning dflags gre ws =-  case ws of-    NoWarnings -> return Nothing-    WarnSome _ -> return Nothing-    WarnAll w  -> Just <$> parseWarning dflags gre w--parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)-parseWarning dflags gre w = do-  r <- case w of-    (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg)-    (WarningTxt    msg) -> format "Warning: "    (concatFS msg)-  r `deepseq` return r-  where-    format x xs = DocWarning . DocParagraph . DocAppend (DocString x)-      .   fromMaybe (DocString . unpackFS $ xs)-      <$> 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])]-       -> ErrMsgM Maps-mkMaps dflags gre instances decls = do-  (a, b, c, d) <- unzip4 <$> mapM mappings decls-  return (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--    mappings (ldecl, docStrs) = do-      let L l decl = ldecl-      let declDoc strs m = do-            doc <- processDocStrings dflags gre strs-            m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m-            return (doc, m')-      (doc, args) <- declDoc docStrs (typeDocs decl)-      let subs = subordinates instanceMap decl-      (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs-      let ns = names l decl-          subNs = [ n | (n, _, _) <- subs ]-          dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]-          am = [ (n, args) | n <- ns ] ++ zip subNs subArgs-          sm = [ (n, subNs) | n <- ns ]-          cm = [ (n, [ldecl]) | n <- ns ++ subNs ]-      seqList ns `seq`-          seqList subNs `seq`-          doc `seq`-          seqList subDocs `seq`-          seqList subArgs `seq`-          return (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_-    defs  = mkDecls (bagToList . tcdMeths) ValD class_-    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_ ++-  mkDecls (valbinds . hs_valds)  ValD   group_-  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)  = liftErrMsg $-      ifDoc (processDocString dflags gre docStr)-            (\doc -> return [ ExportGroup lev "" doc ])-    lookupExport (IEDoc docStr)        = liftErrMsg $-      ifDoc (processDocStringParas dflags gre docStr)-            (\doc -> return [ ExportDoc doc ])-    lookupExport (IEDocNamed str)      = liftErrMsg $-      ifDoc (findNamedDoc str [ unL d | d <- decls ])-            (\docStr ->-            ifDoc (processDocStringParas dflags gre docStr)-                  (\doc -> return [ ExportDoc doc ]))---    ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b]-    ifDoc parse finish = do-      mbDoc <- parse-      case mbDoc of Nothing -> return []; Just doc -> finish 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-      mbDoc <- liftErrMsg $ processDocString dflags gre docStr-      return $ fmap (ExportGroup lev "") mbDoc-    mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do-      mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr-      return $ fmap ExportDoc mbDoc-    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 
@@ -1,161 +0,0 @@-{-# 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 qualified Data.IntSet as IS-import Haddock.Types-import Haddock.Parser-import Haddock.Interface.ParseModuleHeader-import Haddock.Doc--import Control.Applicative-import Data.List-import Data.Maybe-import FastString-import GHC-import DynFlags (ExtensionFlag(..), languageExtensions)-import Name-import Outputable-import RdrName--processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name))-processDocStrings dflags gre strs = do-  docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs-  let doc = foldl' docAppend DocEmpty docs-  case doc of-    DocEmpty -> return Nothing-    _ -> return (Just doc)---processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))-processDocStringParas = process parseParasMaybe---processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name))-processDocString = process parseStringMaybe--process :: (DynFlags -> String -> Maybe (Doc RdrName))-        -> DynFlags-        -> GlobalRdrEnv-        -> HsDocString-        -> ErrMsgM (Maybe (Doc Name))-process parse dflags gre (HsDocString fs) = do-   let str = unpackFS fs-   case parse dflags str of-     Nothing -> do-       tell [ "doc comment parse failed: " ++ str ]-       return Nothing-     Just doc -> do-       return (Just (rename dflags gre doc))---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-        case parseModuleHeader dflags str of-          Left msg -> do-            tell ["haddock module header parse failed: " ++ msg]-            return failure-          Right (hmi, doc) -> do-            let !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 (IS.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 
@@ -1,162 +0,0 @@-{-# 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 Haddock.Types-import Haddock.Parser--import RdrName-import DynFlags--import Data.Char-import Control.Monad (mplus)---- -------------------------------------------------------------------------------- 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 -> Either 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--      description1 :: Either String (Maybe (Doc RdrName))-      description1 = case descriptionOpt of-         Nothing -> Right Nothing-         Just description -> case parseStringMaybe dflags description of-            Nothing -> Left ("Cannot parse Description: " ++ description)-            Just doc -> Right (Just doc)-   in-      case description1 of-         Left mess -> Left mess-         Right docOpt -> case parseParasMaybe dflags str8 of-           Nothing -> Left "Cannot parse header documentation paragraphs"-           Just doc -> Right (HaddockModInfo {-            hmi_description = docOpt,-            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-            }, doc)---- | 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 
@@ -1,506 +0,0 @@-------------------------------------------------------------------------------- |--- 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 
@@ -1,636 +0,0 @@-{-# 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 id) => Binary (Doc 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 
@@ -1,56 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,287 +0,0 @@--------------------------------------------------------------------------------- |--- 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 
@@ -1,487 +0,0 @@-{-# 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 (parseString, parseParas, parseStringMaybe, parseParasMaybe) where--import           Prelude hiding (takeWhile)-import           Control.Arrow (first)-import           Control.Monad (void, mfilter)-import           Control.Applicative-import           Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine)-import qualified Data.ByteString.Char8 as BS-import           Data.Char (chr, isAsciiUpper)-import           Data.List (stripPrefix, intercalate, unfoldr)-import           Data.Maybe (fromMaybe)-import           Data.Monoid-import           DynFlags-import           FastString (mkFastString)-import           Haddock.Doc-import           Haddock.Types-import           Lexer (mkPState, unP, ParseResult(POk))-import           Parser (parseIdentifier)-import           RdrName-import           SrcLoc (mkRealSrcLoc, unLoc)-import           StringBuffer (stringToStringBuffer)-import           Haddock.Utf8-import           Haddock.Parser.Util--{-# DEPRECATED parseParasMaybe "use `parseParas` instead" #-}-parseParasMaybe :: DynFlags -> String -> Maybe (Doc RdrName)-parseParasMaybe d = Just . parseParas d--{-# DEPRECATED parseStringMaybe "use `parseString` instead" #-}-parseStringMaybe :: DynFlags -> String -> Maybe (Doc RdrName)-parseStringMaybe d = Just . parseString d--parse :: Parser a -> BS.ByteString -> a-parse p = either err id . parseOnly (p <* endOfInput)-  where-    err = error . ("Haddock.Parser.parse: " ++)---- | Main entry point to the parser. Appends the newline character--- to the input string.-parseParas :: DynFlags-              -> String -- ^ String to parse-              -> Doc RdrName-parseParas d = parse (p <* skipSpace) . encodeUtf8 . (++ "\n")-  where-    p :: Parser (Doc RdrName)-    p = mconcat <$> paragraph d `sepBy` many (skipHorizontalSpace *> "\n")---- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which--- drops leading whitespace and encodes the string to UTF8 first.-parseString :: DynFlags -> String -> Doc RdrName-parseString d = parseStringBS d . encodeUtf8 . dropWhile isSpace--parseStringBS :: DynFlags -> BS.ByteString -> Doc RdrName-parseStringBS d = parse p-  where-    p :: Parser (Doc RdrName)-    p = mconcat <$> many (monospace d <|> anchor <|> identifier d-                          <|> moduleName <|> picture <|> hyperlink <|> autoUrl <|> bold d-                          <|> emphasis d <|> encodedChar <|> string' <|> skipSpecialChar)---- | Parses and processes--- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references>------ >>> parseOnly encodedChar "&#65;&#66;&#67;"--- Right (DocString "ABC")-encodedChar :: Parser (Doc a)-encodedChar = "&#" *> c <* ";"-  where-    c = DocString . return . chr <$> num-    num = hex <|> decimal-    hex = ("x" <|> "X") *> hexadecimal---- | List of characters that we use to delimit any special markup.--- Once we have checked for any of these and tried to parse the--- relevant markup, we can assume they are used as regular text.-specialChar :: [Char]-specialChar = "_/<@\"&'`#"---- | Plain, regular parser for text. Called as one of the last parsers--- to ensure that we have already given a chance to more meaningful parsers--- before capturing their characers.-string' :: Parser (Doc a)-string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (`notElem` specialChar)-  where-    unescape "" = ""-    unescape ('\\':x:xs) = x : unescape xs-    unescape (x:xs) = x : unescape xs---- | Skips a single special character and treats it as a plain string.--- This is done to skip over any special characters belonging to other--- elements but which were not deemed meaningful at their positions.-skipSpecialChar :: Parser (Doc a)-skipSpecialChar = DocString . return <$> satisfy (`elem` specialChar)---- | Emphasis parser.------ >>> parseOnly emphasis "/Hello world/"--- Right (DocEmphasis (DocString "Hello world"))-emphasis :: DynFlags -> Parser (Doc RdrName)-emphasis d = DocEmphasis . parseStringBS d <$>-  mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/")---- | Bold parser.------ >>> parseOnly bold "__Hello world__"--- Right (DocBold (DocString "Hello world"))-bold :: DynFlags -> Parser (Doc RdrName)-bold d = DocBold . parseStringBS d <$> disallowNewline ("__" *> takeUntil "__")--disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString-disallowNewline = mfilter ('\n' `BS.notElem`)---- | Like `takeWhile`, but unconditionally take escaped characters.-takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString-takeWhile_ p = scan False p_-  where-    p_ escaped c-      | escaped = Just False-      | not $ p c = Nothing-      | otherwise = Just (c == '\\')---- | Like `takeWhile1`, but unconditionally take escaped characters.-takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString-takeWhile1_ = mfilter (not . BS.null) . takeWhile_---- | Text anchors to allow for jumping around the generated documentation.------ >>> parseOnly anchor "#Hello world#"--- Right (DocAName "Hello world")-anchor :: Parser (Doc a)-anchor = DocAName . decodeUtf8 <$>-         disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")---- | Monospaced strings.------ >>> parseOnly (monospace dynflags) "@cruel@"--- Right (DocMonospaced (DocString "cruel"))-monospace :: DynFlags -> Parser (Doc RdrName)-monospace d = DocMonospaced . parseStringBS d <$> ("@" *> takeWhile1_ (/= '@') <* "@")--moduleName :: Parser (Doc a)-moduleName = DocModule <$> (char '"' *> modid <* char '"')-  where-    modid = intercalate "." <$> conid `sepBy1` "."-    conid = (:)-      <$> satisfy isAsciiUpper-      -- NOTE: According to Haskell 2010 we shouldd actually only-      -- accept {small | large | digit | ' } here.  But as we can't-      -- match on unicode characters, this is currently not possible.-      -- Note that we allow ‘#’ to suport anchors.-      <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!|@/;,^?\"\n"))---- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify--- a title for the picture.------ >>> parseOnly picture "<<hello.png>>"--- Right (DocPic (Picture "hello.png" Nothing))--- >>> parseOnly picture "<<hello.png world>>"--- Right (DocPic (Picture "hello.png" (Just "world")))-picture :: Parser (Doc a)-picture = DocPic . makeLabeled Picture . decodeUtf8-          <$> disallowNewline ("<<" *> takeUntil ">>")---- | Paragraph parser, called by 'parseParas'.-paragraph :: DynFlags -> Parser (Doc RdrName)-paragraph d = examples <|> skipSpace *> (list d <|> birdtracks <|> codeblock d-                                         <|> property <|> header d-                                         <|> textParagraph d)--header :: DynFlags -> Parser (Doc RdrName)-header d = do-  let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1]-      pser = foldl1 (<|>) psers-  delim <- decodeUtf8 <$> pser-  line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString d-  rest <- paragraph d <|> return mempty-  return $ docAppend (DocParagraph (DocHeader (Header (length delim) line))) rest--textParagraph :: DynFlags -> Parser (Doc RdrName)-textParagraph d = docParagraph . parseString d . intercalate "\n" <$> many1 nonEmptyLine---- | List parser, called by 'paragraph'.-list :: DynFlags -> Parser (Doc RdrName)-list d = DocUnorderedList <$> unorderedList d-         <|> DocOrderedList <$> orderedList d-         <|> DocDefList <$> definitionList d---- | Parses unordered (bullet) lists.-unorderedList :: DynFlags -> Parser [Doc RdrName]-unorderedList d = ("*" <|> "-") *> innerList (unorderedList d) d---- | Parses ordered lists (numbered or dashed).-orderedList :: DynFlags -> Parser [Doc RdrName]-orderedList d = (paren <|> dot) *> innerList (orderedList d) d-  where-    dot = (decimal :: Parser Int) <* "."-    paren = "(" *> decimal <* ")"---- | Generic function collecting any further lines belonging to the--- list entry and recursively collecting any further lists in the--- same paragraph. Usually used as------ > someListFunction dynflags = listBeginning *> innerList someListFunction dynflags-innerList :: Parser [Doc RdrName] -> DynFlags -> Parser [Doc RdrName]-innerList item d = do-  c <- takeLine-  (cs, items) <- more item d-  let contents = docParagraph . parseString d . dropNLs . unlines $ c : cs-  return $ case items of-    Left p -> [contents `joinPara` p]-    Right i -> contents : i---- | Parses definition lists.-definitionList :: DynFlags -> Parser [(Doc RdrName, Doc RdrName)]-definitionList d = do-  label <- "[" *> (parseStringBS d <$> takeWhile1 (`notElem` "]\n")) <* "]"-  c <- takeLine-  (cs, items) <- more (definitionList d) d-  let contents = parseString d . dropNLs . unlines $ c : cs-  return $ case items of-    Left p -> [(label, contents `joinPara` p)]-    Right i -> (label, contents) : i---- | If possible, appends two 'Doc's under a 'DocParagraph' rather than--- outside of it. This allows to get structures like------ @DocParagraph (DocAppend … …)@------ rather than------ @DocAppend (DocParagraph …) …@-joinPara :: Doc id -> Doc id -> Doc id-joinPara (DocParagraph p) c = docParagraph $ docAppend p c-joinPara d p = docAppend d p---- | Drops all trailing newlines.-dropNLs :: String -> String-dropNLs = reverse . dropWhile (== '\n') . reverse---- | Main worker for 'innerList' and 'definitionList'.--- We need the 'Either' here to be able to tell in the respective functions--- whether we're dealing with the next list or a nested paragraph.-more :: Monoid a => Parser a -> DynFlags-     -> Parser ([String], Either (Doc RdrName) a)-more item d = innerParagraphs d <|> moreListItems item-              <|> moreContent item d <|> pure ([], Right mempty)---- | Use by 'innerList' and 'definitionList' to parse any nested paragraphs.-innerParagraphs :: DynFlags-                -> Parser ([String], Either (Doc RdrName) a)-innerParagraphs d = (,) [] . Left <$> ("\n" *> indentedParagraphs d)---- | Attemps to fetch the next list if possibly. Used by 'innerList' and--- 'definitionList' to recursivly grab lists that aren't separated by a whole--- paragraph.-moreListItems :: Parser a-              -> Parser ([String], Either (Doc RdrName) a)-moreListItems item = (,) [] . Right <$> (skipSpace *> item)---- | Helper for 'innerList' and 'definitionList' which simply takes--- a line of text and attempts to parse more list content with 'more'.-moreContent :: Monoid a => Parser a -> DynFlags-            -> Parser ([String], Either (Doc RdrName) a)-moreContent item d = first . (:) <$> nonEmptyLine <*> more item d---- | Runs the 'parseParas' parser on an indented paragraph.--- The indentation is 4 spaces.-indentedParagraphs :: DynFlags -> Parser (Doc RdrName)-indentedParagraphs d = parseParas d . concat <$> dropFrontOfPara "    "---- | Grab as many fully indented paragraphs as we can.-dropFrontOfPara :: Parser BS.ByteString -> Parser [String]-dropFrontOfPara sp = do-  currentParagraph <- some (sp *> takeNonEmptyLine)-  followingParagraphs <--    skipHorizontalSpace *> nextPar -- we have more paragraphs to take-    <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline-    <|> endOfInput *> return [] -- nothing more to take at all-  return (currentParagraph ++ followingParagraphs)-  where-    nextPar = (++) <$> nlList <*> dropFrontOfPara sp-    nlList = "\n" *> return ["\n"]--nonSpace :: BS.ByteString -> Parser BS.ByteString-nonSpace xs-  | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line"-  | otherwise = return xs---- | Takes a non-empty, not fully whitespace line.------  Doesn't discard the trailing newline.-takeNonEmptyLine :: Parser String-takeNonEmptyLine = do-    (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n"--birdtracks :: Parser (Doc a)-birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line-  where-    line = skipHorizontalSpace *> ">" *> takeLine--stripSpace :: [String] -> [String]-stripSpace = fromMaybe <*> mapM strip'-  where-    strip' (' ':xs') = Just xs'-    strip' "" = Just ""-    strip' _  = Nothing---- | Parses examples. Examples are a paragraph level entitity (separated by an empty line).--- Consecutive examples are accepted.-examples :: Parser (Doc a)-examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go)-  where-    go :: Parser [Example]-    go = do-      prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>"-      expr <- takeLine-      (rs, es) <- resultAndMoreExamples-      return (makeExample prefix expr rs : es)-      where-        resultAndMoreExamples :: Parser ([String], [Example])-        resultAndMoreExamples = moreExamples <|> result <|> pure ([], [])-          where-            moreExamples :: Parser ([String], [Example])-            moreExamples = (,) [] <$> go--            result :: Parser ([String], [Example])-            result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples--    makeExample :: String -> String -> [String] -> Example-    makeExample prefix expression res =-      Example (strip expression) result-      where-        result = map (substituteBlankLine . tryStripPrefix) res--        tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs)--        substituteBlankLine "<BLANKLINE>" = ""-        substituteBlankLine xs = xs--nonEmptyLine :: Parser String-nonEmptyLine = mfilter (any (not . isSpace)) takeLine--takeLine :: Parser String-takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine--endOfLine :: Parser ()-endOfLine = void "\n" <|> endOfInput---- | Property parser.------ >>> parseOnly property "prop> hello world"--- Right (DocProperty "hello world")-property :: Parser (Doc a)-property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n'))---- |--- Paragraph level codeblock. Anything between the two delimiting @ is parsed--- for markup.-codeblock :: DynFlags -> Parser (Doc RdrName)-codeblock d =-  DocCodeBlock . parseStringBS d . dropSpaces-  <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")-  where-    dropSpaces xs =-      let rs = decodeUtf8 xs-      in case splitByNl rs of-        [] -> xs-        ys -> case last ys of-          ' ':_ -> case mapM dropSpace ys of-            Nothing -> xs-            Just zs -> encodeUtf8 $ intercalate "\n" zs-          _ -> xs--    -- This is necessary because ‘lines’ swallows up a trailing newline-    -- and we lose information about whether the last line belongs to @ or to-    -- text which we need to decide whether we actually want to be dropping-    -- anything at all.-    splitByNl = unfoldr (\case '\n':s -> Just (span (/= '\n') s)-                               _ -> Nothing)-                . ('\n' :)--    dropSpace "" = Just ""-    dropSpace (' ':xs) = Just xs-    dropSpace _ = Nothing--    block' = scan False p-      where-        p isNewline c-          | isNewline && c == '@' = Nothing-          | isNewline && isSpace c = Just isNewline-          | otherwise = Just $ c == '\n'--hyperlink :: Parser (Doc a)-hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8-              <$> disallowNewline ("<" *> takeUntil ">")-            <|> autoUrl--autoUrl :: Parser (Doc a)-autoUrl = mkLink <$> url-  where-    url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace)-    mkLink :: BS.ByteString -> Doc a-    mkLink s = case BS.unsnoc s of-      Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) <> DocString [x]-      _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing)---- | Parses strings between identifier delimiters. Consumes all input that it--- deems to be valid in an identifier. Note that it simply blindly consumes--- characters and does no actual validation itself.-parseValid :: Parser String-parseValid = do-  vs' <- many' $ utf8String "⋆" <|> return <$> idChar-  let vs = concat vs'-  c <- peekChar-  case c of-    Just '`' -> return vs-    Just '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> parseValid)-                 <|> return vs-    _ -> fail "outofvalid"-  where-    idChar = satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:^")-             <|> digit <|> letter_ascii---- | Parses UTF8 strings from ByteString streams.-utf8String :: String -> Parser String-utf8String x = decodeUtf8 <$> string (encodeUtf8 x)---- | Parses identifiers with help of 'parseValid'. Asks GHC for 'RdrName' from the--- string it deems valid.-identifier :: DynFlags -> Parser (Doc RdrName)-identifier dflags = do-  o <- idDelim-  vid <- parseValid-  e <- idDelim-  return $ validIdentifier o vid e-  where-    idDelim = char '\'' <|> char '`'-    validIdentifier o ident e = case parseIdent ident of-      Just identName -> DocIdentifier identName-      Nothing -> DocString $ o : ident ++ [e]--    parseIdent :: String -> Maybe RdrName-    parseIdent 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---- | Remove all leading and trailing whitespace-strip :: String -> String-strip = (\f -> f . f) $ dropWhile isSpace . reverse--skipHorizontalSpace :: Parser ()-skipHorizontalSpace = skipWhile (`elem` " \t\f\v\r")--takeHorizontalSpace :: Parser BS.ByteString-takeHorizontalSpace = takeWhile (`elem` " \t\f\v\r")--makeLabeled :: (String -> Maybe String -> a) -> String -> a-makeLabeled f input = case break isSpace $ removeEscapes $ strip input of-  (uri, "")    -> f uri Nothing-  (uri, label) -> f uri (Just $ dropWhile isSpace label)-  where-    -- As we don't parse these any further, we don't do any processing to the-    -- string so we at least remove escape character here. Perhaps we should-    -- actually be parsing the label at the very least?-    removeEscapes "" = ""-    removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs-    removeEscapes ('\\':xs) = removeEscapes xs-    removeEscapes (x:xs) = x : removeEscapes xs
− src/Haddock/Parser/Util.hs 
@@ -1,26 +0,0 @@-module Haddock.Parser.Util where--import           Control.Applicative-import           Control.Monad-import           Data.Attoparsec.ByteString.Char8-import           Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS--takeUntil :: ByteString -> Parser ByteString-takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome-  where-    end = BS.unpack end_--    p :: (Bool, String) -> Char -> Maybe (Bool, String)-    p acc c = case acc of-      (True, _) -> Just (False, end)-      (_, []) -> Nothing-      (_, x:xs) | x == c -> Just (False, xs)-      _ -> Just (c == '\\', end)--    dropEnd = BS.reverse . BS.drop (length end) . BS.reverse-    requireEnd = mfilter (BS.isSuffixOf end_)--    gotSome xs-      | BS.null xs = fail "didn't get any content"-      | otherwise = return xs
− src/Haddock/Types.hs 
@@ -1,604 +0,0 @@-{-# 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(..)- ) where--import Data.Foldable-import Data.Traversable-import Control.Exception-import Control.Arrow hiding ((<+>))-import Control.DeepSeq-import Data.Typeable-import Data.Map (Map)-import qualified Data.Map as Map-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)---data Doc id-  = DocEmpty-  | DocAppend (Doc id) (Doc id)-  | DocString String-  | DocParagraph (Doc id)-  | DocIdentifier id-  | DocIdentifierUnchecked (ModuleName, OccName)-  | DocModule String-  | DocWarning (Doc id)-  | DocEmphasis (Doc id)-  | DocMonospaced (Doc id)-  | DocBold (Doc id)-  | DocUnorderedList [Doc id]-  | DocOrderedList [Doc id]-  | DocDefList [(Doc id, Doc id)]-  | DocCodeBlock (Doc id)-  | DocHyperlink Hyperlink-  | DocPic Picture-  | DocAName String-  | DocProperty String-  | DocExamples [Example]-  | DocHeader (Header (Doc id))-  deriving (Functor, Foldable, Traversable)--instance Foldable Header where-  foldMap f (Header _ a) = f a--instance Traversable Header where-  traverse f (Header l a) = Header l `fmap` f a--instance NFData a => NFData (Doc 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---data Hyperlink = Hyperlink-  { hyperlinkUrl   :: String-  , hyperlinkLabel :: Maybe String-  } deriving (Eq, Show)---data Picture = Picture-  { pictureUri   :: String-  , pictureTitle :: Maybe String-  } deriving (Eq, Show)--data Header id = Header-  { headerLevel :: Int-  , headerTitle :: id-  } deriving Functor--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` ()---data Example = Example-  { exampleExpression :: String-  , exampleResult     :: [String]-  } deriving (Eq, Show)---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/Utf8.hs 
@@ -1,74 +0,0 @@-module Haddock.Utf8 (encodeUtf8, decodeUtf8) where-import           Data.Bits ((.|.), (.&.), shiftL, shiftR)-import qualified Data.ByteString as BS-import           Data.Char (chr, ord)-import           Data.Word (Word8)---- | Helper that encodes and packs a 'String' into a 'BS.ByteString'-encodeUtf8 :: String -> BS.ByteString-encodeUtf8 = BS.pack . encode---- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String'-decodeUtf8 :: BS.ByteString -> String-decodeUtf8 = decode . BS.unpack---- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding--- | Character to use when 'encode' or 'decode' fail for a byte.-replacementCharacter :: Char-replacementCharacter = '\xfffd'---- | Encode a Haskell String to a list of Word8 values, in UTF8 format.-encode :: String -> [Word8]-encode = concatMap (map fromIntegral . go . ord)- where-  go oc-   | oc <= 0x7f       = [oc]--   | oc <= 0x7ff      = [ 0xc0 + (oc `shiftR` 6)-                        , 0x80 + oc .&. 0x3f-                        ]--   | oc <= 0xffff     = [ 0xe0 + (oc `shiftR` 12)-                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)-                        , 0x80 + oc .&. 0x3f-                        ]-   | otherwise        = [ 0xf0 + (oc `shiftR` 18)-                        , 0x80 + ((oc `shiftR` 12) .&. 0x3f)-                        , 0x80 + ((oc `shiftR` 6) .&. 0x3f)-                        , 0x80 + oc .&. 0x3f-                        ]---- | Decode a UTF8 string packed into a list of Word8 values, directly to String-decode :: [Word8] -> String-decode [    ] = ""-decode (c:cs)-  | c < 0x80  = chr (fromEnum c) : decode cs-  | c < 0xc0  = replacementCharacter : decode cs-  | c < 0xe0  = multi1-  | c < 0xf0  = multi_byte 2 0xf  0x800-  | c < 0xf8  = multi_byte 3 0x7  0x10000-  | c < 0xfc  = multi_byte 4 0x3  0x200000-  | c < 0xfe  = multi_byte 5 0x1  0x4000000-  | otherwise = replacementCharacter : decode cs-  where-    multi1 = case cs of-      c1 : ds | c1 .&. 0xc0 == 0x80 ->-        let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|.  fromEnum (c1 .&. 0x3f)-        in if d >= 0x000080 then toEnum d : decode ds-                            else replacementCharacter : decode ds-      _ -> replacementCharacter : decode cs--    multi_byte :: Int -> Word8 -> Int -> String-    multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))-      where-        aux 0 rs acc-          | overlong <= acc && acc <= 0x10ffff &&-            (acc < 0xd800 || 0xdfff < acc)     &&-            (acc < 0xfffe || 0xffff < acc)      = chr acc : decode rs-          | otherwise = replacementCharacter : decode rs--        aux n (r:rs) acc-          | r .&. 0xc0 == 0x80 = aux (n-1) rs-                               $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)--        aux _ rs     _ = replacementCharacter : decode rs
− src/Haddock/Utils.hs 
@@ -1,480 +0,0 @@-{-# 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 
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- 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--import Paths_haddock ( version )-import Data.Version  ( showVersion )--projectName, projectUrl :: String-projectName = "Haddock"-projectUrl  = "http://www.haskell.org/haddock/"--projectVersion :: String-projectVersion = showVersion version
− src/haddock.sh 
@@ -1,7 +0,0 @@-# Mini-driver for Haddock--# needs the following variables:-#	HADDOCKLIB-#	HADDOCKBIN--$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}
− test/Haddock/Parser/UtilSpec.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Haddock.Parser.UtilSpec (main, spec) where--import           Test.Hspec-import           Data.Either--import           Data.Attoparsec.ByteString.Char8-import           Haddock.Parser.Util--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "takeUntil" $ do-    it "takes everything until a specified byte sequence" $ do-      parseOnly (takeUntil "end") "someend" `shouldBe` Right "some"--    it "requires the end sequence" $ do-      parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft--    it "takes escaped bytes unconditionally" $ do-      parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end"
− test/Haddock/ParserSpec.hs 
@@ -1,839 +0,0 @@-{-# LANGUAGE OverloadedStrings, StandaloneDeriving-             , FlexibleInstances, UndecidableInstances-             , IncoherentInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Haddock.ParserSpec (main, spec) where--import           Data.Monoid-import           Data.String-import qualified Haddock.Parser as Parse-import           Haddock.Types-import           Outputable (Outputable, showSDoc, ppr)-import           RdrName (RdrName, mkVarUnqual)-import           FastString (fsLit)-import           StaticFlags (initStaticOpts)-import           Test.Hspec-import           Test.QuickCheck--import           Helper--instance Outputable a => Show a where-  show = showSDoc dynFlags . ppr--deriving instance Show a => Show (Header a)-deriving instance Show a => Show (Doc a)-deriving instance Eq a => Eq (Header a)-deriving instance Eq a => Eq (Doc a)--instance IsString RdrName where-  fromString = mkVarUnqual . fsLit--instance IsString (Doc RdrName) where-  fromString = DocString--instance IsString a => IsString (Maybe a) where-  fromString = Just . fromString--parseParas :: String -> Doc RdrName-parseParas = Parse.parseParas dynFlags--parseString :: String -> Doc RdrName-parseString = Parse.parseString dynFlags--main :: IO ()-main = hspec spec--spec :: Spec-spec = before initStaticOpts $ do-  describe "parseString" $ do-    let infix 1 `shouldParseTo`-        shouldParseTo :: String -> Doc RdrName -> Expectation-        shouldParseTo input ast = parseString input `shouldBe` ast--    it "is total" $ do-      property $ \xs ->-        (length . show . parseString) xs `shouldSatisfy` (> 0)--    context "when parsing text" $ do-      it "can handle unicode" $ do-        "灼眼のシャナ" `shouldParseTo` "灼眼のシャナ"--      it "accepts numeric character references" $ do-        "foo b&#97;r b&#97;z &#955;" `shouldParseTo` "foo bar baz λ"--      it "accepts hexadecimal character references" $ do-        "&#x65;" `shouldParseTo` "e"--      it "allows to backslash-escape characters" $ do-        property $ \x -> ['\\', x] `shouldParseTo` DocString [x]--      context "when parsing strings contaning numeric character references" $ do-        it "will implicitly convert digits to characters" $ do-          "&#65;&#65;&#65;&#65;" `shouldParseTo` "AAAA"--          "&#28796;&#30524;&#12398;&#12471;&#12515;&#12490;"-            `shouldParseTo` "灼眼のシャナ"--        it "will implicitly convert hex encoded characters" $ do-          "&#x65;&#x65;&#x65;&#x65;" `shouldParseTo` "eeee"--    context "when parsing identifiers" $ do-      it "parses identifiers enclosed within single ticks" $ do-        "'foo'" `shouldParseTo` DocIdentifier "foo"--      it "parses identifiers enclosed within backticks" $ do-        "`foo`" `shouldParseTo` DocIdentifier "foo"--      it "parses a word with an one of the delimiters in it as DocString" $ do-          "don't" `shouldParseTo` "don't"--      it "doesn't pass pairs of delimiters with spaces between them" $ do-        "hel'lo w'orld" `shouldParseTo` "hel'lo w'orld"--      it "don't use apostrophe's in the wrong place's" $ do-        " don't use apostrophe's in the wrong place's" `shouldParseTo`-          "don't use apostrophe's in the wrong place's"--    context "when parsing URLs" $ do-      let hyperlink :: String -> Maybe String -> Doc RdrName-          hyperlink url = DocHyperlink . Hyperlink url--      it "parses a URL" $ do-        "<http://example.com/>" `shouldParseTo` hyperlink "http://example.com/" Nothing--      it "accepts an optional label" $ do-        "<http://example.com/ some link>" `shouldParseTo` hyperlink "http://example.com/" "some link"--      it "does not accept newlines in label" $ do-        "<foo bar\nbaz>" `shouldParseTo` "<foo bar\nbaz>"--      -- new behaviour test, this will be now consistent with other markup-      it "allows us to escape > inside the URL" $ do-        "<http://examp\\>le.com>" `shouldParseTo`-          hyperlink "http://examp>le.com" Nothing--        "<http://exa\\>mp\\>le.com>" `shouldParseTo`-          hyperlink "http://exa>mp>le.com" Nothing--        -- Likewise in label-        "<http://example.com f\\>oo>" `shouldParseTo`-          hyperlink "http://example.com" "f>oo"--      it "parses inline URLs" $ do-        "foo <http://example.com/> bar" `shouldParseTo`-          "foo " <> hyperlink "http://example.com/" Nothing <> " bar"--      it "doesn't allow for multi-line link tags" $ do-        "<ba\nz aar>" `shouldParseTo` "<ba\nz aar>"--      context "when autolinking URLs" $ do-        it "autolinks HTTP URLs" $ do-          "http://example.com/" `shouldParseTo` hyperlink "http://example.com/" Nothing--        it "autolinks HTTPS URLs" $ do-          "https://www.example.com/" `shouldParseTo` hyperlink "https://www.example.com/" Nothing--        it "autolinks FTP URLs" $ do-          "ftp://example.com/" `shouldParseTo` hyperlink "ftp://example.com/" Nothing--        it "does not include a trailing comma" $ do-          "http://example.com/, Some other sentence." `shouldParseTo`-            hyperlink "http://example.com/" Nothing <> ", Some other sentence."--        it "does not include a trailing dot" $ do-          "http://example.com/. Some other sentence." `shouldParseTo`-            hyperlink "http://example.com/" Nothing <> ". Some other sentence."--        it "does not include a trailing exclamation mark" $ do-          "http://example.com/! Some other sentence." `shouldParseTo`-            hyperlink "http://example.com/" Nothing <> "! Some other sentence."--        it "does not include a trailing question mark" $ do-          "http://example.com/? Some other sentence." `shouldParseTo`-            hyperlink "http://example.com/" Nothing <> "? Some other sentence."--    context "when parsing pictures" $ do-      let picture :: String -> Maybe String -> Doc RdrName-          picture uri = DocPic . Picture uri--      it "parses a simple picture" $ do-        "<<baz>>" `shouldParseTo` picture "baz" Nothing--      it "parses a picture with a title" $ do-        "<<b a z>>" `shouldParseTo` picture "b" (Just "a z")--      it "parses a picture with unicode" $ do-        "<<灼眼のシャナ>>" `shouldParseTo` picture "灼眼のシャナ" Nothing--      it "allows for escaping of the closing tags" $ do-        "<<ba\\>>z>>" `shouldParseTo` picture "ba>>z" Nothing--      it "doesn't allow for multi-line picture tags" $ do-        "<<ba\nz aar>>" `shouldParseTo` "<<ba\nz aar>>"--    context "when parsing anchors" $ do-      it "parses a single word anchor" $ do-        "#foo#" `shouldParseTo` DocAName "foo"--      it "parses a multi word anchor" $ do-        "#foo bar#" `shouldParseTo` DocAName "foo bar"--      it "parses a unicode anchor" $ do-        "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ"--      it "does not accept newlines in anchors" $ do-        "#foo\nbar#" `shouldParseTo` "#foo\nbar#"--      it "accepts anchors mid-paragraph" $ do-        "Hello #someAnchor# world!"-          `shouldParseTo` "Hello " <> DocAName "someAnchor" <> " world!"--      it "does not accept empty anchors" $ do-        "##" `shouldParseTo` "##"--    context "when parsing emphasised text" $ do-      it "emphasises a word on its own" $ do-        "/foo/" `shouldParseTo` DocEmphasis "foo"--      it "emphasises inline correctly" $ do-        "foo /bar/ baz" `shouldParseTo` "foo " <> DocEmphasis "bar" <> " baz"--      it "emphasises unicode" $ do-        "/灼眼のシャナ/" `shouldParseTo` DocEmphasis "灼眼のシャナ"--      it "does not emphasise multi-line strings" $ do-        " /foo\nbar/" `shouldParseTo` "/foo\nbar/"--      it "does not emphasise the empty string" $ do-        "//" `shouldParseTo` "//"--      it "parses escaped slashes literally" $ do-        "/foo\\/bar/" `shouldParseTo` DocEmphasis "foo/bar"--      it "recognizes other markup constructs within emphasised text" $ do-        "/foo @bar@ baz/" `shouldParseTo`-          DocEmphasis ("foo " <> DocMonospaced "bar" <> " baz")--      it "allows other markup inside of emphasis" $ do-        "/__inner bold__/" `shouldParseTo` DocEmphasis (DocBold "inner bold")--      it "doesn't mangle inner markup unicode" $ do-        "/__灼眼のシャナ &#65;__/" `shouldParseTo` DocEmphasis (DocBold "灼眼のシャナ A")--      it "properly converts HTML escape sequences" $ do-        "/&#65;&#65;&#65;&#65;/" `shouldParseTo` DocEmphasis "AAAA"--      it "allows to escape the emphasis delimiter inside of emphasis" $ do-        "/empha\\/sis/" `shouldParseTo` DocEmphasis "empha/sis"--    context "when parsing monospaced text" $ do-      it "parses simple monospaced text" $ do-        "@foo@" `shouldParseTo` DocMonospaced "foo"--      it "parses inline monospaced text" $ do-        "foo @bar@ baz" `shouldParseTo` "foo " <> DocMonospaced "bar" <> " baz"--      it "allows to escape @" $ do-        "@foo \\@ bar@" `shouldParseTo` DocMonospaced "foo @ bar"--      it "accepts unicode" $ do-        "@foo 灼眼のシャナ bar@" `shouldParseTo` DocMonospaced "foo 灼眼のシャナ bar"--      it "accepts other markup in monospaced text" $ do-        "@/foo/@" `shouldParseTo` DocMonospaced (DocEmphasis "foo")--      it "requires the closing @" $ do-        "@foo /bar/ baz" `shouldParseTo` "@foo " <> DocEmphasis "bar" <> " baz"--    context "when parsing bold strings" $ do-      it "allows for a bold string on its own" $ do-        "__bold string__" `shouldParseTo`-          DocBold "bold string"--      it "bolds inline correctly" $ do-        "hello __everyone__ there" `shouldParseTo`-          "hello "-           <> DocBold "everyone" <> " there"--      it "bolds unicode" $ do-        "__灼眼のシャナ__" `shouldParseTo`-          DocBold "灼眼のシャナ"--      it "does not do __multi-line\\n bold__" $ do-        " __multi-line\n bold__" `shouldParseTo` "__multi-line\n bold__"--      it "allows other markup inside of bold" $ do-        "__/inner emphasis/__" `shouldParseTo`-          (DocBold $ DocEmphasis "inner emphasis")--      it "doesn't mangle inner markup unicode" $ do-        "__/灼眼のシャナ &#65;/__" `shouldParseTo`-          (DocBold $ DocEmphasis "灼眼のシャナ A")--      it "properly converts HTML escape sequences" $ do-        "__&#65;&#65;&#65;&#65;__" `shouldParseTo`-          DocBold "AAAA"--      it "allows to escape the bold delimiter inside of bold" $ do-        "__bo\\__ld__" `shouldParseTo`-          DocBold "bo__ld"--      it "doesn't allow for empty bold" $ do-        "____" `shouldParseTo` "____"--    context "when parsing module strings" $ do-      it "should parse a module on its own" $ do-        "\"Module\"" `shouldParseTo`-          DocModule "Module"--      it "should parse a module inline" $ do-        "This is a \"Module\"." `shouldParseTo`-          "This is a " <> DocModule "Module" <> "."--      it "can accept a simple module name" $ do-        "\"Hello\"" `shouldParseTo` DocModule "Hello"--      it "can accept a module name with dots" $ do-        "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World"--      it "can accept a module name with unicode" $ do-        "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ"--      it "parses a module name with a trailing dot as regular quoted string" $ do-        "\"Hello.\"" `shouldParseTo` "\"Hello.\""--      it "parses a module name with a space as regular quoted string" $ do-        "\"Hello World\"" `shouldParseTo` "\"Hello World\""--      it "parses a module name with invalid characters as regular quoted string" $ do-        "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\""--      it "accepts a module name with unicode" $ do-        "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ"--      it "treats empty module name as regular double quotes" $ do-        "\"\"" `shouldParseTo` "\"\""--      it "accepts anchor reference syntax as DocModule" $ do-        "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar"--      it "accepts old anchor reference syntax as DocModule" $ do-        "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar"--  describe "parseParas" $ do-    let infix 1 `shouldParseTo`-        shouldParseTo :: String -> Doc RdrName -> Expectation-        shouldParseTo input ast = parseParas input `shouldBe` ast--    it "is total" $ do-      property $ \xs ->-        (length . show . parseParas) xs `shouldSatisfy` (> 0)--    context "when parsing text paragraphs" $ do-      let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String))--      it "parses an empty paragraph" $ do-        "" `shouldParseTo` DocEmpty--      it "parses a simple text paragraph" $ do-        "foo bar baz" `shouldParseTo` DocParagraph "foo bar baz"--      it "accepts markup in text paragraphs" $ do-        "foo /bar/ baz" `shouldParseTo` DocParagraph ("foo " <> DocEmphasis "bar" <> " baz")--      it "preserve all regular characters" $ do-        property $ \xs -> let input = filterSpecial xs in (not . null) input ==>-          input `shouldParseTo` DocParagraph (DocString input)--      it "separates paragraphs by empty lines" $ do-        unlines [-            "foo"-          , " \t "-          , "bar"-          ] `shouldParseTo` DocParagraph "foo" <> DocParagraph "bar"--      context "when a pragraph only contains monospaced text" $ do-        it "turns it into a code block" $ do-          "@foo@" `shouldParseTo` DocCodeBlock "foo"--    context "when parsing birdtracks" $ do-      it "parses them as a code block" $ do-        unlines [-            ">foo"-          , ">bar"-          , ">baz"-          ] `shouldParseTo` DocCodeBlock "foo\nbar\nbaz"--      it "ignores leading whitespace" $ do-        unlines [-            " >foo"-          , " \t >bar"-          , " >baz"-          ]-        `shouldParseTo` DocCodeBlock "foo\nbar\nbaz"--      it "strips one leading space from each line of the block" $ do-        unlines [-            "> foo"-          , ">  bar"-          , "> baz"-          ] `shouldParseTo` DocCodeBlock "foo\n bar\nbaz"--      it "ignores empty lines when stripping spaces" $ do-        unlines [-            "> foo"-          , ">"-          , "> bar"-          ] `shouldParseTo` DocCodeBlock "foo\n\nbar"--      context "when any non-empty line does not start with a space" $ do-        it "does not strip any spaces" $ do-          unlines [-              ">foo"-            , ">  bar"-            ] `shouldParseTo` DocCodeBlock "foo\n  bar"--      it "ignores nested markup" $ do-        unlines [-            ">/foo/"-          ] `shouldParseTo` DocCodeBlock "/foo/"--      it "treats them as regular text inside text paragraphs" $ do-        unlines [-            "foo"-          , ">bar"-          ] `shouldParseTo` DocParagraph "foo\n>bar"--    context "when parsing code blocks" $ do-      it "accepts a simple code block" $ do-        unlines [-            "@"-          , "foo"-          , "bar"-          , "baz"-          , "@"-          ] `shouldParseTo` DocCodeBlock "foo\nbar\nbaz\n"--      it "ignores trailing whitespace after the opening @" $ do-        unlines [-            "@   "-          , "foo"-          , "@"-          ] `shouldParseTo` DocCodeBlock "foo\n"--      it "rejects code blocks that are not closed" $ do-        unlines [-            "@"-          , "foo"-          ] `shouldParseTo` DocParagraph "@\nfoo"--      it "accepts nested markup" $ do-        unlines [-            "@"-          , "/foo/"-          , "@"-          ] `shouldParseTo` DocCodeBlock (DocEmphasis "foo" <> "\n")--      it "allows to escape the @" $ do-        unlines [-            "@"-          , "foo"-          , "\\@"-          , "bar"-          , "@"-          ] `shouldParseTo` DocCodeBlock "foo\n@\nbar\n"--      it "accepts horizontal space before the @" $ do-        unlines [ "     @"-                , "foo"-                , ""-                , "bar"-                , "@"-                ] `shouldParseTo` DocCodeBlock "foo\n\nbar\n"--      it "strips a leading space from a @ block if present" $ do-        unlines [ " @"-                , " hello"-                , " world"-                , " @"-                ] `shouldParseTo` DocCodeBlock "hello\nworld\n"--        unlines [ " @"-                , " hello"-                , ""-                , " world"-                , " @"-                ] `shouldParseTo` DocCodeBlock "hello\n\nworld\n"--      it "only drops whitespace if there's some before closing @" $ do-        unlines [ "@"-                , "    Formatting"-                , "        matters."-                , "@"-                ]-          `shouldParseTo` DocCodeBlock "    Formatting\n        matters.\n"--      it "accepts unicode" $ do-        "@foo 灼眼のシャナ bar@" `shouldParseTo` DocCodeBlock "foo 灼眼のシャナ bar"--      it "requires the closing @" $ do-        "@foo /bar/ baz"-          `shouldParseTo` DocParagraph ("@foo " <> DocEmphasis "bar" <> " baz")---    context "when parsing examples" $ do-      it "parses a simple example" $ do-        ">>> foo" `shouldParseTo` DocExamples [Example "foo" []]--      it "parses an example with result" $ do-        unlines [-            ">>> foo"-          , "bar"-          , "baz"-          ] `shouldParseTo` DocExamples [Example "foo" ["bar", "baz"]]--      it "parses consecutive examples" $ do-        unlines [-            ">>> fib 5"-          , "5"-          , ">>> fib 10"-          , "55"-          ] `shouldParseTo` DocExamples [-            Example "fib 5" ["5"]-          , Example "fib 10" ["55"]-          ]--      it ("requires an example to be separated"-          ++ " from a previous paragraph by an empty line") $ do-        "foobar\n\n>>> fib 10\n55" `shouldParseTo`-          DocParagraph "foobar"-                <> DocExamples [Example "fib 10" ["55"]]--      it "parses bird-tracks inside of paragraphs as plain strings" $ do-        let xs = "foo\n>>> bar"-        xs `shouldParseTo` DocParagraph (DocString xs)--      it "skips empty lines in front of an example" $ do-        "\n   \n\n>>> foo" `shouldParseTo` DocExamples [Example "foo" []]--      it "terminates example on empty line" $ do-        unlines [-            ">>> foo"-          , "bar"-          , "    "-          , "baz"-          ]-        `shouldParseTo`-          DocExamples [Example "foo" ["bar"]] <> DocParagraph "baz"--      it "parses a <BLANKLINE> result as an empty result" $ do-        unlines [-            ">>> foo"-          , "bar"-          , "<BLANKLINE>"-          , "baz"-          ]-        `shouldParseTo` DocExamples [Example "foo" ["bar", "", "baz"]]--      it "accepts unicode in examples" $ do-        ">>> 灼眼\nシャナ" `shouldParseTo` DocExamples [Example "灼眼" ["シャナ"]]--      context "when prompt is prefixed by whitespace" $ do-        it "strips the exact same amount of whitespace from result lines" $ do-          unlines [-              "   >>> foo"-            , "   bar"-            , "   baz"-            ] `shouldParseTo` DocExamples [Example "foo" ["bar", "baz"]]--        it "preserves additional whitespace" $ do-          unlines [-              "   >>> foo"-            , "    bar"-            ] `shouldParseTo` DocExamples [Example "foo" [" bar"]]--        it "keeps original if stripping is not possible" $ do-          unlines [-              "   >>> foo"-            , " bar"-            ] `shouldParseTo` DocExamples [Example "foo" [" bar"]]---    context "when parsing paragraphs nested in lists" $ do-      it "can nest the same type of list" $ do-        "* foo\n\n    * bar" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocUnorderedList [DocParagraph "bar"]]--      it "can nest another type of list inside" $ do-        "* foo\n\n    1. bar" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocOrderedList [DocParagraph "bar"]]--      it "can nest a code block inside" $ do-        "* foo\n\n    @foo bar baz@" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocCodeBlock "foo bar baz"]--        "* foo\n\n    @\n    foo bar baz\n    @" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocCodeBlock "foo bar baz\n"]--      it "can nest more than one level" $ do-        "* foo\n\n    * bar\n\n        * baz\n        qux" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocUnorderedList [ DocParagraph $ "bar"-                                                   <> DocUnorderedList [DocParagraph "baz\nqux"]-                                                 ]-                           ]--      it "won't fail on not fully indented paragraph" $ do-        "* foo\n\n    * bar\n\n        * qux\nquux" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocUnorderedList [ DocParagraph "bar" ]-                           , DocParagraph "qux\nquux"]---      it "can nest definition lists" $ do-        "[a] foo\n\n    [b] bar\n\n        [c] baz\n        qux" `shouldParseTo`-          DocDefList [ ("a", "foo"-                             <> DocDefList [ ("b", "bar"-                                                   <> DocDefList [("c", "baz\nqux")])-                                           ])-                     ]--      it "can come back to top level with a different list" $ do-        "* foo\n\n    * bar\n\n1. baz" `shouldParseTo`-          DocUnorderedList [ DocParagraph $ "foo"-                             <> DocUnorderedList [ DocParagraph "bar" ]-                           ]-          <> DocOrderedList [ DocParagraph "baz" ]--      it "definition lists can come back to top level with a different list" $ do-        "[foo] foov\n\n    [bar] barv\n\n1. baz" `shouldParseTo`-          DocDefList [ ("foo", "foov"-                               <> DocDefList [ ("bar", "barv") ])-                     ]-          <> DocOrderedList [ DocParagraph "baz" ]--    context "when parsing properties" $ do-      it "can parse a single property" $ do-        "prop> 23 == 23" `shouldParseTo` DocProperty "23 == 23"--      it "can parse multiple subsequent properties" $ do-        unlines [-              "prop> 23 == 23"-            , "prop> 42 == 42"-            ]-        `shouldParseTo`-          DocProperty "23 == 23" <> DocProperty "42 == 42"--      it "accepts unicode in properties" $ do-        "prop> 灼眼のシャナ ≡ 愛" `shouldParseTo`-          DocProperty "灼眼のシャナ ≡ 愛"--      it "can deal with whitespace before and after the prop> prompt" $ do-        "  prop>     xs == (reverse $ reverse xs)  " `shouldParseTo`-          DocProperty "xs == (reverse $ reverse xs)"--    context "when parsing unordered lists" $ do-      it "parses a simple list" $ do-        unlines [-            " * one"-          , " * two"-          , " * three"-          ]-        `shouldParseTo` DocUnorderedList [-            DocParagraph "one"-          , DocParagraph "two"-          , DocParagraph "three"-          ]--      it "ignores empty lines between list items" $ do-        unlines [-            "* one"-          , ""-          , "* two"-          ]-        `shouldParseTo` DocUnorderedList [-            DocParagraph "one"-          , DocParagraph "two"-          ]--      it "accepts an empty list item" $ do-        "*" `shouldParseTo` DocUnorderedList [DocParagraph DocEmpty]--      it "accepts multi-line list items" $ do-        unlines [-            "* point one"-          , "  more one"-          , "* point two"-          , "more two"-          ]-        `shouldParseTo` DocUnorderedList [-            DocParagraph "point one\n  more one"-          , DocParagraph "point two\nmore two"-          ]--      it "accepts markup in list items" $ do-        "* /foo/" `shouldParseTo` DocUnorderedList [DocParagraph (DocEmphasis "foo")]--      it "requires empty lines between list and other paragraphs" $ do-        unlines [-            "foo"-          , ""-          , "* bar"-          , ""-          , "baz"-          ]-        `shouldParseTo` DocParagraph "foo" <> DocUnorderedList [DocParagraph "bar"] <> DocParagraph "baz"--    context "when parsing ordered lists" $ do-      it "parses a simple list" $ do-        unlines [-            " 1. one"-          , " (1) two"-          , " 3. three"-          ]-        `shouldParseTo` DocOrderedList [-            DocParagraph "one"-          , DocParagraph "two"-          , DocParagraph "three"-          ]--      it "ignores empty lines between list items" $ do-        unlines [-            "1. one"-          , ""-          , "2. two"-          ]-        `shouldParseTo` DocOrderedList [-            DocParagraph "one"-          , DocParagraph "two"-          ]--      it "accepts an empty list item" $ do-        "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty]--      it "accepts multi-line list items" $ do-        unlines [-            "1. point one"-          , "  more one"-          , "1. point two"-          , "more two"-          ]-        `shouldParseTo` DocOrderedList [-            DocParagraph "point one\n  more one"-          , DocParagraph "point two\nmore two"-          ]--      it "accepts markup in list items" $ do-        "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")]--      it "requires empty lines between list and other paragraphs" $ do-        unlines [-            "foo"-          , ""-          , "1. bar"-          , ""-          , "baz"-          ]-        `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz"--    context "when parsing definition lists" $ do-      it "parses a simple list" $ do-        unlines [-            " [foo] one"-          , " [bar] two"-          , " [baz] three"-          ]-        `shouldParseTo` DocDefList [-            ("foo", "one")-          , ("bar", "two")-          , ("baz", "three")-          ]--      it "ignores empty lines between list items" $ do-        unlines [-            "[foo] one"-          , ""-          , "[bar] two"-          ]-        `shouldParseTo` DocDefList [-            ("foo", "one")-          , ("bar", "two")-          ]--      it "accepts an empty list item" $ do-        "[foo]" `shouldParseTo` DocDefList [("foo", DocEmpty)]--      it "accepts multi-line list items" $ do-        unlines [-            "[foo] point one"-          , "  more one"-          , "[bar] point two"-          , "more two"-          ]-        `shouldParseTo` DocDefList [-            ("foo", "point one\n  more one")-          , ("bar", "point two\nmore two")-          ]--      it "accepts markup in list items" $ do-        "[foo] /foo/" `shouldParseTo` DocDefList [("foo", DocEmphasis "foo")]--      it "accepts markup for the label" $ do-        "[/foo/] bar" `shouldParseTo` DocDefList [(DocEmphasis "foo", "bar")]--      it "requires empty lines between list and other paragraphs" $ do-        unlines [-            "foo"-          , ""-          , "[foo] bar"-          , ""-          , "baz"-          ]-        `shouldParseTo` DocParagraph "foo" <> DocDefList [("foo", "bar")] <> DocParagraph "baz"--    context "when parsing consecutive paragraphs" $ do-      it "will not capture irrelevant consecutive lists" $ do-        unlines [ "   * bullet"-                , ""-                , ""-                , "   - different bullet"-                , ""-                , ""-                , "   (1) ordered"-                , " "-                , "   2. different bullet"-                , "   "-                , "   [cat] kitten"-                , "   "-                , "   [pineapple] fruit"-                ] `shouldParseTo`-          DocUnorderedList [ DocParagraph "bullet"-                           , DocParagraph "different bullet"]-          <> DocOrderedList [ DocParagraph "ordered"-                            , DocParagraph "different bullet"-                            ]-          <> DocDefList [ ("cat", "kitten")-                        , ("pineapple", "fruit")-                        ]--    context "when parsing function documentation headers" $ do-      it "can parse a simple header" $ do-        "= Header 1\nHello." `shouldParseTo`-          DocParagraph (DocHeader (Header 1 "Header 1"))-          <> DocParagraph "Hello."--      it "allow consecutive headers" $ do-        "= Header 1\n== Header 2" `shouldParseTo`-          DocParagraph (DocHeader (Header 1 "Header 1"))-          <> DocParagraph (DocHeader (Header 2 "Header 2"))--      it "accepts markup in the header" $ do-        "= /Header/ __1__\nFoo" `shouldParseTo`-          DocParagraph (DocHeader-                        (Header 1 (DocEmphasis "Header" <> " " <> DocBold "1")))-          <> DocParagraph "Foo"
− test/Haddock/Utf8Spec.hs 
@@ -1,15 +0,0 @@-module Haddock.Utf8Spec (main, spec) where--import           Test.Hspec-import           Test.QuickCheck--import           Haddock.Utf8--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "decodeUtf8" $ do-    it "is inverse to encodeUtf8" $ do-      property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs
− test/Helper.hs 
@@ -1,183 +0,0 @@-module Helper where-import           DynFlags (Settings(..), DynFlags, defaultDynFlags)-import           Platform-import           PlatformConstants--dynFlags :: DynFlags-dynFlags = defaultDynFlags settings-  where-    settings = Settings {-        sTargetPlatform = platform-      , sGhcUsagePath = error "Haddock.ParserSpec.sGhcUsagePath"-      , sGhciUsagePath = error "Haddock.ParserSpec.sGhciUsagePath"-      , sTopDir = error "Haddock.ParserSpec.sTopDir"-      , sTmpDir = error "Haddock.ParserSpec.sTmpDir"-      , sRawSettings = []-      , sExtraGccViaCFlags = error "Haddock.ParserSpec.sExtraGccViaCFlags"-      , sSystemPackageConfig = error "Haddock.ParserSpec.sSystemPackageConfig"-      , sPgm_L = error "Haddock.ParserSpec.sPgm_L"-      , sPgm_P = error "Haddock.ParserSpec.sPgm_P"-      , sPgm_F = error "Haddock.ParserSpec.sPgm_F"-      , sPgm_c = error "Haddock.ParserSpec.sPgm_c"-      , sPgm_s = error "Haddock.ParserSpec.sPgm_s"-      , sPgm_a = error "Haddock.ParserSpec.sPgm_a"-      , sPgm_l = error "Haddock.ParserSpec.sPgm_l"-      , sPgm_dll = error "Haddock.ParserSpec.sPgm_dll"-      , sPgm_T = error "Haddock.ParserSpec.sPgm_T"-      , sPgm_sysman = error "Haddock.ParserSpec.sPgm_sysman"-      , sPgm_windres = error "Haddock.ParserSpec.sPgm_windres"-      , sPgm_libtool = error "Haddock.ParserSpec.sPgm_libtool"-      , sPgm_lo = error "Haddock.ParserSpec.sPgm_lo"-      , sPgm_lc = error "Haddock.ParserSpec.sPgm_lc"-      , sOpt_L = []-      , sOpt_P = []-      , sOpt_F = []-      , sOpt_c = []-      , sOpt_a = []-      , sOpt_l = []-      , sOpt_windres = []-      , sOpt_lo = []-      , sOpt_lc = []-      , sLdSupportsCompactUnwind = error "Haddock.ParserSpec.sLdSupportsCompactUnwind"-      , sLdSupportsBuildId  = error "Haddock.ParserSpec.sLdSupportsBuildId "-      , sLdSupportsFilelist  = error "Haddock.ParserSpec.sLdSupportsFilelist "-      , sLdIsGnuLd = error "Haddock.ParserSpec.sLdIsGnuLd"-      , sPlatformConstants = platformConstants-      }-    platform = Platform {-        platformArch = ArchUnknown-      , platformOS = OSUnknown-      , platformWordSize = 64-      , platformHasGnuNonexecStack = False-      , platformHasIdentDirective = False-      , platformHasSubsectionsViaSymbols = False-      , platformUnregisterised = error "Haddock.ParserSpec.platformUnregisterised"-      }--    platformConstants = PlatformConstants {-        pc_platformConstants = ()-      , pc_STD_HDR_SIZE = 0-      , pc_PROF_HDR_SIZE = 0-      , pc_BLOCK_SIZE = 0-      , pc_BLOCKS_PER_MBLOCK = 0-      , pc_OFFSET_StgRegTable_rR1 = 0-      , pc_OFFSET_StgRegTable_rR2 = 0-      , pc_OFFSET_StgRegTable_rR3 = 0-      , pc_OFFSET_StgRegTable_rR4 = 0-      , pc_OFFSET_StgRegTable_rR5 = 0-      , pc_OFFSET_StgRegTable_rR6 = 0-      , pc_OFFSET_StgRegTable_rR7 = 0-      , pc_OFFSET_StgRegTable_rR8 = 0-      , pc_OFFSET_StgRegTable_rR9 = 0-      , pc_OFFSET_StgRegTable_rR10 = 0-      , pc_OFFSET_StgRegTable_rF1 = 0-      , pc_OFFSET_StgRegTable_rF2 = 0-      , pc_OFFSET_StgRegTable_rF3 = 0-      , pc_OFFSET_StgRegTable_rF4 = 0-      , pc_OFFSET_StgRegTable_rF5 = 0-      , pc_OFFSET_StgRegTable_rF6 = 0-      , pc_OFFSET_StgRegTable_rD1 = 0-      , pc_OFFSET_StgRegTable_rD2 = 0-      , pc_OFFSET_StgRegTable_rD3 = 0-      , pc_OFFSET_StgRegTable_rD4 = 0-      , pc_OFFSET_StgRegTable_rD5 = 0-      , pc_OFFSET_StgRegTable_rD6 = 0-      , pc_OFFSET_StgRegTable_rXMM1 = 0-      , pc_OFFSET_StgRegTable_rXMM2 = 0-      , pc_OFFSET_StgRegTable_rXMM3 = 0-      , pc_OFFSET_StgRegTable_rXMM4 = 0-      , pc_OFFSET_StgRegTable_rXMM5 = 0-      , pc_OFFSET_StgRegTable_rXMM6 = 0-      , pc_OFFSET_StgRegTable_rL1 = 0-      , pc_OFFSET_StgRegTable_rSp = 0-      , pc_OFFSET_StgRegTable_rSpLim = 0-      , pc_OFFSET_StgRegTable_rHp = 0-      , pc_OFFSET_StgRegTable_rHpLim = 0-      , pc_OFFSET_StgRegTable_rCCCS = 0-      , pc_OFFSET_StgRegTable_rCurrentTSO = 0-      , pc_OFFSET_StgRegTable_rCurrentNursery = 0-      , pc_OFFSET_StgRegTable_rHpAlloc = 0-      , pc_OFFSET_stgEagerBlackholeInfo = 0-      , pc_OFFSET_stgGCEnter1 = 0-      , pc_OFFSET_stgGCFun = 0-      , pc_OFFSET_Capability_r = 0-      , pc_OFFSET_bdescr_start = 0-      , pc_OFFSET_bdescr_free = 0-      , pc_OFFSET_bdescr_blocks = 0-      , pc_SIZEOF_CostCentreStack = 0-      , pc_OFFSET_CostCentreStack_mem_alloc = 0-      , pc_REP_CostCentreStack_mem_alloc = 0-      , pc_OFFSET_CostCentreStack_scc_count = 0-      , pc_REP_CostCentreStack_scc_count = 0-      , pc_OFFSET_StgHeader_ccs = 0-      , pc_OFFSET_StgHeader_ldvw = 0-      , pc_SIZEOF_StgSMPThunkHeader = 0-      , pc_OFFSET_StgEntCounter_allocs = 0-      , pc_REP_StgEntCounter_allocs = 0-      , pc_OFFSET_StgEntCounter_allocd = 0-      , pc_REP_StgEntCounter_allocd = 0-      , pc_OFFSET_StgEntCounter_registeredp = 0-      , pc_OFFSET_StgEntCounter_link = 0-      , pc_OFFSET_StgEntCounter_entry_count = 0-      , pc_SIZEOF_StgUpdateFrame_NoHdr = 0-      , pc_SIZEOF_StgMutArrPtrs_NoHdr = 0-      , pc_OFFSET_StgMutArrPtrs_ptrs = 0-      , pc_OFFSET_StgMutArrPtrs_size = 0-      , pc_SIZEOF_StgArrWords_NoHdr = 0-      , pc_OFFSET_StgTSO_cccs = 0-      , pc_OFFSET_StgTSO_stackobj = 0-      , pc_OFFSET_StgStack_sp = 0-      , pc_OFFSET_StgStack_stack = 0-      , pc_OFFSET_StgUpdateFrame_updatee = 0-      , pc_SIZEOF_StgFunInfoExtraRev = 0-      , pc_MAX_SPEC_SELECTEE_SIZE = 0-      , pc_MAX_SPEC_AP_SIZE = 0-      , pc_MIN_PAYLOAD_SIZE = 0-      , pc_MIN_INTLIKE = 0-      , pc_MAX_INTLIKE = 0-      , pc_MIN_CHARLIKE = 0-      , pc_MAX_CHARLIKE = 0-      , pc_MUT_ARR_PTRS_CARD_BITS = 0-      , pc_MAX_Vanilla_REG = 0-      , pc_MAX_Float_REG = 0-      , pc_MAX_Double_REG = 0-      , pc_MAX_Long_REG = 0-      , pc_MAX_XMM_REG = 0-      , pc_MAX_Real_Vanilla_REG = 0-      , pc_MAX_Real_Float_REG = 0-      , pc_MAX_Real_Double_REG = 0-      , pc_MAX_Real_XMM_REG = 0-      , pc_MAX_Real_Long_REG = 0-      , pc_RESERVED_C_STACK_BYTES = 0-      , pc_RESERVED_STACK_WORDS = 0-      , pc_AP_STACK_SPLIM = 0-      , pc_WORD_SIZE = 0-      , pc_DOUBLE_SIZE = 0-      , pc_CINT_SIZE = 0-      , pc_CLONG_SIZE = 0-      , pc_CLONG_LONG_SIZE = 0-      , pc_BITMAP_BITS_SHIFT = 0-      , pc_TAG_BITS = 0-      , pc_WORDS_BIGENDIAN = False-      , pc_DYNAMIC_BY_DEFAULT = False-      , pc_LDV_SHIFT = 0-      , pc_ILDV_CREATE_MASK = 0-      , pc_ILDV_STATE_CREATE = 0-      , pc_ILDV_STATE_USE = 0-      , pc_OFFSET_StgRegTable_rYMM1 = 0-      , pc_OFFSET_StgRegTable_rYMM2 = 0-      , pc_OFFSET_StgRegTable_rYMM3 = 0-      , pc_OFFSET_StgRegTable_rYMM4 = 0-      , pc_OFFSET_StgRegTable_rYMM5 = 0-      , pc_OFFSET_StgRegTable_rYMM6 = 0-      , pc_OFFSET_StgRegTable_rZMM1 = 0-      , pc_OFFSET_StgRegTable_rZMM2 = 0-      , pc_OFFSET_StgRegTable_rZMM3 = 0-      , pc_OFFSET_StgRegTable_rZMM4 = 0-      , pc_OFFSET_StgRegTable_rZMM5 = 0-      , pc_OFFSET_StgRegTable_rZMM6 = 0-      , pc_OFFSET_StgFunInfoExtraFwd_arity = 0-      , pc_REP_StgFunInfoExtraFwd_arity = 0-      , pc_OFFSET_StgFunInfoExtraRev_arity = 0-      , pc_REP_StgFunInfoExtraRev_arity = 0-      }
− test/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− vendor/attoparsec-0.10.4.0/Data/Attoparsec.hs 
@@ -1,18 +0,0 @@--- |--- Module      :  Data.Attoparsec--- Copyright   :  Bryan O'Sullivan 2007-2011--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient combinator parsing for 'ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec-    (-      module Data.Attoparsec.ByteString-    ) where--import Data.Attoparsec.ByteString
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString.hs 
@@ -1,205 +0,0 @@--- |--- Module      :  Data.Attoparsec.ByteString--- Copyright   :  Bryan O'Sullivan 2007-2011--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient combinator parsing for 'B.ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec.ByteString-    (-    -- * Differences from Parsec-    -- $parsec--    -- * Incremental input-    -- $incremental--    -- * Performance considerations-    -- $performance--    -- * Parser types-      I.Parser-    , Result-    , T.IResult(..)-    , I.compareResults--    -- * Running parsers-    , parse-    , feed-    , I.parseOnly-    , parseWith-    , parseTest--    -- ** Result conversion-    , maybeResult-    , eitherResult--    -- * Combinators-    , (I.<?>)-    , I.try-    , module Data.Attoparsec.Combinator--    -- * Parsing individual bytes-    , I.word8-    , I.anyWord8-    , I.notWord8-    , I.peekWord8-    , I.satisfy-    , I.satisfyWith-    , I.skip--    -- ** Byte classes-    , I.inClass-    , I.notInClass--    -- * Efficient string handling-    , I.string-    , I.skipWhile-    , I.take-    , I.scan-    , I.takeWhile-    , I.takeWhile1-    , I.takeTill--    -- ** Consume all remaining input-    , I.takeByteString-    , I.takeLazyByteString--    -- * State observation and manipulation functions-    , I.endOfInput-    , I.atEnd-    ) where--import Data.Attoparsec.Combinator-import qualified Data.Attoparsec.ByteString.Internal as I-import qualified Data.Attoparsec.Internal as I-import qualified Data.ByteString as B-import Data.Attoparsec.ByteString.Internal (Result, parse)-import qualified Data.Attoparsec.Internal.Types as T---- $parsec------ Compared to Parsec 3, Attoparsec makes several tradeoffs.  It is--- not intended for, or ideal for, all possible uses.------ * While Attoparsec can consume input incrementally, Parsec cannot.---   Incremental input is a huge deal for efficient and secure network---   and system programming, since it gives much more control to users---   of the library over matters such as resource usage and the I/O---   model to use.------ * Much of the performance advantage of Attoparsec is gained via---   high-performance parsers such as 'I.takeWhile' and 'I.string'.---   If you use complicated combinators that return lists of bytes or---   characters, there is less performance difference between the two---   libraries.------ * Unlike Parsec 3, Attoparsec does not support being used as a---   monad transformer.------ * Attoparsec is specialised to deal only with strict 'B.ByteString'---   input.  Efficiency concerns rule out both lists and lazy---   bytestrings.  The usual use for lazy bytestrings would be to---   allow consumption of very large input without a large footprint.---   For this need, Attoparsec's incremental input provides an---   excellent substitute, with much more control over when input---   takes place.  If you must use lazy bytestrings, see the 'Lazy'---   module, which feeds lazy chunks to a regular parser.------ * Parsec parsers can produce more helpful error messages than---   Attoparsec parsers.  This is a matter of focus: Attoparsec avoids---   the extra book-keeping in favour of higher performance.---- $incremental------ Attoparsec supports incremental input, meaning that you can feed it--- a bytestring that represents only part of the expected total amount--- of data to parse. If your parser reaches the end of a fragment of--- input and could consume more input, it will suspend parsing and--- return a 'T.Partial' continuation.------ Supplying the 'T.Partial' continuation with another bytestring will--- resume parsing at the point where it was suspended. You must be--- prepared for the result of the resumed parse to be another--- 'T.Partial' continuation.------ To indicate that you have no more input, supply the 'T.Partial'--- continuation with an empty bytestring.------ Remember that some parsing combinators will not return a result--- until they reach the end of input.  They may thus cause 'T.Partial'--- results to be returned.------ If you do not need support for incremental input, consider using--- the 'I.parseOnly' function to run your parser.  It will never--- prompt for more input.---- $performance------ If you write an Attoparsec-based parser carefully, it can be--- realistic to expect it to perform within a factor of 2 of a--- hand-rolled C parser (measuring megabytes parsed per second).------ To actually achieve high performance, there are a few guidelines--- that it is useful to follow.------ Use the 'B.ByteString'-oriented parsers whenever possible,--- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'.  There is--- about a factor of 100 difference in performance between the two--- kinds of parser.------ For very simple byte-testing predicates, write them by hand instead--- of using 'I.inClass' or 'I.notInClass'.  For instance, both of--- these predicates test for an end-of-line byte, but the first is--- much faster than the second:------ >endOfLine_fast w = w == 13 || w == 10--- >endOfLine_slow   = inClass "\r\n"------ Make active use of benchmarking and profiling tools to measure,--- find the problems with, and improve the performance of your parser.---- | If a parser has returned a 'T.Partial' result, supply it with more--- input.-feed :: Result r -> B.ByteString -> Result r-feed f@(T.Fail _ _ _) _ = f-feed (T.Partial k) d    = k d-feed (T.Done bs r) d    = T.Done (B.append bs d) r-{-# INLINE feed #-}---- | Run a parser and print its result to standard output.-parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO ()-parseTest p s = print (parse p s)---- | Run a parser with an initial input string, and a monadic action--- that can supply more input if needed.-parseWith :: Monad m =>-             (m B.ByteString)-          -- ^ An action that will be executed to provide the parser-          -- with more input, if necessary.  The action must return an-          -- 'B.empty' string when there is no more input available.-          -> I.Parser a-          -> B.ByteString-          -- ^ Initial input for the parser.-          -> m (Result a)-parseWith refill p s = step $ parse p s-  where step (T.Partial k) = (step . k) =<< refill-        step r             = return r-{-# INLINE parseWith #-}---- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result--- is treated as failure.-maybeResult :: Result r -> Maybe r-maybeResult (T.Done _ r) = Just r-maybeResult _            = Nothing---- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'--- result is treated as failure.-eitherResult :: Result r -> Either String r-eitherResult (T.Done _ r)     = Right r-eitherResult (T.Fail _ _ msg) = Left msg-eitherResult _                = Left "Result: incomplete input"
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Char8.hs 
@@ -1,549 +0,0 @@-{-# LANGUAGE BangPatterns, FlexibleInstances, TypeFamilies,-    TypeSynonymInstances, GADTs #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- |--- Module      :  Data.Attoparsec.ByteString.Char8--- Copyright   :  Bryan O'Sullivan 2007-2011--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient, character-oriented combinator parsing for--- 'B.ByteString' strings, loosely based on the Parsec library.--module Data.Attoparsec.ByteString.Char8-    (-    -- * Character encodings-    -- $encodings--    -- * Parser types-      Parser-    , A.Result-    , A.IResult(..)-    , I.compareResults--    -- * Running parsers-    , A.parse-    , A.feed-    , A.parseOnly-    , A.parseTest-    , A.parseWith--    -- ** Result conversion-    , A.maybeResult-    , A.eitherResult--    -- * Combinators-    , (I.<?>)-    , I.try-    , module Data.Attoparsec.Combinator--    -- * Parsing individual characters-    , char-    , char8-    , anyChar-    , notChar-    , peekChar-    , satisfy--    -- ** Special character parsers-    , digit-    , letter_iso8859_15-    , letter_ascii-    , space--    -- ** Fast predicates-    , isDigit-    , isDigit_w8-    , isAlpha_iso8859_15-    , isAlpha_ascii-    , isSpace-    , isSpace_w8--    -- *** Character classes-    , inClass-    , notInClass--    -- * Efficient string handling-    , I.string-    , stringCI-    , skipSpace-    , skipWhile-    , I.take-    , scan-    , takeWhile-    , takeWhile1-    , takeTill--    -- ** String combinators-    -- $specalt-    , (.*>)-    , (<*.)--    -- ** Consume all remaining input-    , I.takeByteString-    , I.takeLazyByteString--    -- * Text parsing-    , I.endOfLine-    , isEndOfLine-    , isHorizontalSpace--    -- * Numeric parsers-    , decimal-    , hexadecimal-    , signed-    , double-    , Number(..)-    , number-    , rational--    -- * State observation and manipulation functions-    , I.endOfInput-    , I.atEnd-    ) where--import Control.Applicative ((*>), (<*), (<$>), (<|>))-import Data.Attoparsec.ByteString.FastSet (charClass, memberChar)-import Data.Attoparsec.ByteString.Internal (Parser, (<?>))-import Data.Attoparsec.Combinator-import Data.Attoparsec.Number (Number(..))-import Data.Bits (Bits, (.|.), shiftL)-import Data.ByteString.Internal (c2w, w2c)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Ratio ((%))-import Data.String (IsString(..))-import Data.Word (Word8, Word16, Word32, Word64, Word)-import Prelude hiding (takeWhile)-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.ByteString.Internal as I-import qualified Data.Attoparsec.Internal as I-import qualified Data.ByteString as B8-import qualified Data.ByteString.Char8 as B--instance (a ~ B.ByteString) => IsString (Parser a) where-    fromString = I.string . B.pack---- $encodings------ This module is intended for parsing text that is--- represented using an 8-bit character set, e.g. ASCII or--- ISO-8859-15.  It /does not/ make any attempt to deal with character--- encodings, multibyte characters, or wide characters.  In--- particular, all attempts to use characters above code point U+00FF--- will give wrong answers.------ Code points below U+0100 are simply translated to and from their--- numeric values, so e.g. the code point U+00A4 becomes the byte--- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic--- currency sign in ISO-8859-1).  Haskell 'Char' values above U+00FF--- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@.---- ASCII-specific but fast, oh yes.-toLower :: Word8 -> Word8-toLower w | w >= 65 && w <= 90 = w + 32-          | otherwise          = w---- | Satisfy a literal string, ignoring case.-stringCI :: B.ByteString -> Parser B.ByteString-stringCI = I.stringTransform (B8.map toLower)-{-# INLINE stringCI #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser requires the predicate to succeed on at least one byte--- of input: it will fail if the predicate never returns 'True' or if--- there is no input left.-takeWhile1 :: (Char -> Bool) -> Parser B.ByteString-takeWhile1 p = I.takeWhile1 (p . w2c)-{-# INLINE takeWhile1 #-}---- | The parser @satisfy p@ succeeds for any byte for which the--- predicate @p@ returns 'True'. Returns the byte that is actually--- parsed.------ >digit = satisfy isDigit--- >    where isDigit c = c >= '0' && c <= '9'-satisfy :: (Char -> Bool) -> Parser Char-satisfy = I.satisfyWith w2c-{-# INLINE satisfy #-}---- | Match a letter, in the ISO-8859-15 encoding.-letter_iso8859_15 :: Parser Char-letter_iso8859_15 = satisfy isAlpha_iso8859_15 <?> "letter_iso8859_15"-{-# INLINE letter_iso8859_15 #-}---- | Match a letter, in the ASCII encoding.-letter_ascii :: Parser Char-letter_ascii = satisfy isAlpha_ascii <?> "letter_ascii"-{-# INLINE letter_ascii #-}---- | A fast alphabetic predicate for the ISO-8859-15 encoding------ /Note/: For all character encodings other than ISO-8859-15, and--- almost all Unicode code points above U+00A3, this predicate gives--- /wrong answers/.-isAlpha_iso8859_15 :: Char -> Bool-isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||-                       (c >= '\166' && moby c)-  where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247"-        {-# NOINLINE moby #-}-{-# INLINE isAlpha_iso8859_15 #-}---- | A fast alphabetic predicate for the ASCII encoding------ /Note/: For all character encodings other than ASCII, and--- almost all Unicode code points above U+007F, this predicate gives--- /wrong answers/.-isAlpha_ascii :: Char -> Bool-isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')-{-# INLINE isAlpha_ascii #-}---- | Parse a single digit.-digit :: Parser Char-digit = satisfy isDigit <?> "digit"-{-# INLINE digit #-}---- | A fast digit predicate.-isDigit :: Char -> Bool-isDigit c = c >= '0' && c <= '9'-{-# INLINE isDigit #-}---- | A fast digit predicate.-isDigit_w8 :: Word8 -> Bool-isDigit_w8 w = w >= 48 && w <= 57-{-# INLINE isDigit_w8 #-}---- | Match any character.-anyChar :: Parser Char-anyChar = satisfy $ const True-{-# INLINE anyChar #-}---- | Match any character. Returns 'Nothing' if end of input has been--- reached. Does not consume any input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-peekChar :: Parser (Maybe Char)-peekChar = (fmap w2c) `fmap` I.peekWord8-{-# INLINE peekChar #-}---- | Fast predicate for matching ASCII space characters.------ /Note/: This predicate only gives correct answers for the ASCII--- encoding.  For instance, it does not recognise U+00A0 (non-breaking--- space) as a space character, even though it is a valid ISO-8859-15--- byte. For a Unicode-aware and only slightly slower predicate,--- use 'Data.Char.isSpace'-isSpace :: Char -> Bool-isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')-{-# INLINE isSpace #-}---- | Fast 'Word8' predicate for matching ASCII space characters.-isSpace_w8 :: Word8 -> Bool-isSpace_w8 w = (w == 32) || (9 <= w && w <= 13)-{-# INLINE isSpace_w8 #-}----- | Parse a space character.------ /Note/: This parser only gives correct answers for the ASCII--- encoding.  For instance, it does not recognise U+00A0 (non-breaking--- space) as a space character, even though it is a valid ISO-8859-15--- byte.-space :: Parser Char-space = satisfy isSpace <?> "space"-{-# INLINE space #-}---- | Match a specific character.-char :: Char -> Parser Char-char c = satisfy (== c) <?> [c]-{-# INLINE char #-}---- | Match a specific character, but return its 'Word8' value.-char8 :: Char -> Parser Word8-char8 c = I.satisfy (== c2w c) <?> [c]-{-# INLINE char8 #-}---- | Match any character except the given one.-notChar :: Char -> Parser Char-notChar c = satisfy (/= c) <?> "not " ++ [c]-{-# INLINE notChar #-}---- | Match any character in a set.------ >vowel = inClass "aeiou"------ Range notation is supported.------ >halfAlphabet = inClass "a-nA-N"------ To add a literal \'-\' to a set, place it at the beginning or end--- of the string.-inClass :: String -> Char -> Bool-inClass s = (`memberChar` mySet)-    where mySet = charClass s-{-# INLINE inClass #-}---- | Match any character not in a set.-notInClass :: String -> Char -> Bool-notInClass s = not . inClass s-{-# INLINE notInClass #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'False' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-takeWhile :: (Char -> Bool) -> Parser B.ByteString-takeWhile p = I.takeWhile (p . w2c)-{-# INLINE takeWhile #-}---- | A stateful scanner.  The predicate consumes and transforms a--- state argument, and each transformed state is passed to successive--- invocations of the predicate on each byte of the input until one--- returns 'Nothing' or the input ends.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'Nothing' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString-scan s0 p = I.scan s0 (\s -> p s . w2c)-{-# INLINE scan #-}---- | Consume input as long as the predicate returns 'False'--- (i.e. until it returns 'True'), and return the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'True' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-takeTill :: (Char -> Bool) -> Parser B.ByteString-takeTill p = I.takeTill (p . w2c)-{-# INLINE takeTill #-}---- | Skip past input for as long as the predicate returns 'True'.-skipWhile :: (Char -> Bool) -> Parser ()-skipWhile p = I.skipWhile (p . w2c)-{-# INLINE skipWhile #-}---- | Skip over white space.-skipSpace :: Parser ()-skipSpace = I.skipWhile isSpace_w8-{-# INLINE skipSpace #-}---- $specalt------ The '.*>' and '<*.' combinators are intended for use with the--- @OverloadedStrings@ language extension.  They simplify the common--- task of matching a statically known string, then immediately--- parsing something else.------ An example makes this easier to understand:------ @{-\# LANGUAGE OverloadedStrings #-}------ shoeSize = \"Shoe size: \" '.*>' 'decimal'--- @------ If we were to try to use '*>' above instead, the type checker would--- not be able to tell which 'IsString' instance to use for the text--- in quotes.  We would have to be explicit, using either a type--- signature or the 'I.string' parser.---- | Type-specialized version of '*>' for 'B.ByteString'.-(.*>) :: B.ByteString -> Parser a -> Parser a-s .*> f = I.string s *> f---- | Type-specialized version of '<*' for 'B.ByteString'.-(<*.) :: Parser a -> B.ByteString -> Parser a-f <*. s = f <* I.string s---- | A predicate that matches either a carriage return @\'\\r\'@ or--- newline @\'\\n\'@ character.-isEndOfLine :: Word8 -> Bool-isEndOfLine w = w == 13 || w == 10-{-# INLINE isEndOfLine #-}---- | A predicate that matches either a space @\' \'@ or horizontal tab--- @\'\\t\'@ character.-isHorizontalSpace :: Word8 -> Bool-isHorizontalSpace w = w == 32 || w == 9-{-# INLINE isHorizontalSpace #-}---- | Parse and decode an unsigned hexadecimal number.  The hex digits--- @\'a\'@ through @\'f\'@ may be upper or lower case.------ This parser does not accept a leading @\"0x\"@ string.-hexadecimal :: (Integral a, Bits a) => Parser a-hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit-  where-    isHexDigit w = (w >= 48 && w <= 57) ||-                   (w >= 97 && w <= 102) ||-                   (w >= 65 && w <= 70)-    step a w | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)-             | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)-             | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)-{-# SPECIALISE hexadecimal :: Parser Int #-}-{-# SPECIALISE hexadecimal :: Parser Int8 #-}-{-# SPECIALISE hexadecimal :: Parser Int16 #-}-{-# SPECIALISE hexadecimal :: Parser Int32 #-}-{-# SPECIALISE hexadecimal :: Parser Int64 #-}-{-# SPECIALISE hexadecimal :: Parser Integer #-}-{-# SPECIALISE hexadecimal :: Parser Word #-}-{-# SPECIALISE hexadecimal :: Parser Word8 #-}-{-# SPECIALISE hexadecimal :: Parser Word16 #-}-{-# SPECIALISE hexadecimal :: Parser Word32 #-}-{-# SPECIALISE hexadecimal :: Parser Word64 #-}---- | Parse and decode an unsigned decimal number.-decimal :: Integral a => Parser a-decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig-  where isDig w  = w >= 48 && w <= 57-        step a w = a * 10 + fromIntegral (w - 48)-{-# SPECIALISE decimal :: Parser Int #-}-{-# SPECIALISE decimal :: Parser Int8 #-}-{-# SPECIALISE decimal :: Parser Int16 #-}-{-# SPECIALISE decimal :: Parser Int32 #-}-{-# SPECIALISE decimal :: Parser Int64 #-}-{-# SPECIALISE decimal :: Parser Integer #-}-{-# SPECIALISE decimal :: Parser Word #-}-{-# SPECIALISE decimal :: Parser Word8 #-}-{-# SPECIALISE decimal :: Parser Word16 #-}-{-# SPECIALISE decimal :: Parser Word32 #-}-{-# SPECIALISE decimal :: Parser Word64 #-}---- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign--- character.-signed :: Num a => Parser a -> Parser a-{-# SPECIALISE signed :: Parser Int -> Parser Int #-}-{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-}-{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-}-{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-}-{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-}-{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-}-signed p = (negate <$> (char8 '-' *> p))-       <|> (char8 '+' *> p)-       <|> p---- | Parse a rational number.------ This parser accepts an optional leading sign character, followed by--- at least one decimal digit.  The syntax similar to that accepted by--- the 'read' function, with the exception that a trailing @\'.\'@ or--- @\'e\'@ /not/ followed by a number is not consumed.------ Examples with behaviour identical to 'read', if you feed an empty--- continuation to the first result:------ >rational "3"     == Done 3.0 ""--- >rational "3.1"   == Done 3.1 ""--- >rational "3e4"   == Done 30000.0 ""--- >rational "3.1e4" == Done 31000.0, ""------ Examples with behaviour identical to 'read':------ >rational ".3"    == Fail "input does not start with a digit"--- >rational "e3"    == Fail "input does not start with a digit"------ Examples of differences from 'read':------ >rational "3.foo" == Done 3.0 ".foo"--- >rational "3e"    == Done 3.0 "e"------ This function does not accept string representations of \"NaN\" or--- \"Infinity\".-rational :: Fractional a => Parser a-{-# SPECIALIZE rational :: Parser Double #-}-{-# SPECIALIZE rational :: Parser Float #-}-{-# SPECIALIZE rational :: Parser Rational #-}-rational = floaty $ \real frac fracDenom -> fromRational $-                     real % 1 + frac % fracDenom---- | Parse a rational number.------ The syntax accepted by this parser is the same as for 'rational'.------ /Note/: This function is almost ten times faster than 'rational',--- but is slightly less accurate.------ The 'Double' type supports about 16 decimal places of accuracy.--- For 94.2% of numbers, this function and 'rational' give identical--- results, but for the remaining 5.8%, this function loses precision--- around the 15th decimal place.  For 0.001% of numbers, this--- function will lose precision at the 13th or 14th decimal place.------ This function does not accept string representations of \"NaN\" or--- \"Infinity\".-double :: Parser Double-double = floaty asDouble--asDouble :: Integer -> Integer -> Integer -> Double-asDouble real frac fracDenom =-    fromIntegral real + fromIntegral frac / fromIntegral fracDenom-{-# INLINE asDouble #-}---- | Parse a number, attempting to preserve both speed and precision.------ The syntax accepted by this parser is the same as for 'rational'.------ /Note/: This function is almost ten times faster than 'rational'.--- On integral inputs, it gives perfectly accurate answers, and on--- floating point inputs, it is slightly less accurate than--- 'rational'.------ This function does not accept string representations of \"NaN\" or--- \"Infinity\".-number :: Parser Number-number = floaty $ \real frac fracDenom ->-         if frac == 0 && fracDenom == 0-         then I real-         else D (asDouble real frac fracDenom)-{-# INLINE number #-}--data T = T !Integer !Int--floaty :: Fractional a => (Integer -> Integer -> Integer -> a) -> Parser a-{-# INLINE floaty #-}-floaty f = do-  let minus = 45-      plus  = 43-  !positive <- ((== plus) <$> I.satisfy (\c -> c == minus || c == plus)) <|>-               return True-  real <- decimal-  let tryFraction = do-        let dot = 46-        _ <- I.satisfy (==dot)-        ds <- I.takeWhile isDigit_w8-        case I.parseOnly decimal ds of-                Right n -> return $ T n (B.length ds)-                _       -> fail "no digits after decimal"-  T fraction fracDigits <- tryFraction <|> return (T 0 0)-  let littleE = 101-      bigE    = 69-      e w = w == littleE || w == bigE-  power <- (I.satisfy e *> signed decimal) <|> return (0::Int)-  let n = if fracDigits == 0-          then if power == 0-               then fromIntegral real-               else fromIntegral real * (10 ^^ power)-          else if power == 0-               then f real fraction (10 ^ fracDigits)-               else f real fraction (10 ^ fracDigits) * (10 ^^ power)-  return $ if positive-           then n-           else -n
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/FastSet.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Attoparsec.ByteString.FastSet--- Copyright   :  Bryan O'Sullivan 2008--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Fast set membership tests for 'Word8' and 8-bit 'Char' values.  The--- set representation is unboxed for efficiency.  For small sets, we--- test for membership using a binary search.  For larger sets, we use--- a lookup table.----------------------------------------------------------------------------------module Data.Attoparsec.ByteString.FastSet-    (-    -- * Data type-      FastSet-    -- * Construction-    , fromList-    , set-    -- * Lookup-    , memberChar-    , memberWord8-    -- * Debugging-    , fromSet-    -- * Handy interface-    , charClass-    ) where--import Data.Bits ((.&.), (.|.))-import Foreign.Storable (peekByteOff, pokeByteOff)-import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)-import GHC.Word (Word8(W8#))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as I-import qualified Data.ByteString.Unsafe as U--data FastSet = Sorted { fromSet :: !B.ByteString }-             | Table  { fromSet :: !B.ByteString }-    deriving (Eq, Ord)--instance Show FastSet where-    show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s)-    show (Table _) = "FastSet Table"---- | The lower bound on the size of a lookup table.  We choose this to--- balance table density against performance.-tableCutoff :: Int-tableCutoff = 8---- | Create a set.-set :: B.ByteString -> FastSet-set s | B.length s < tableCutoff = Sorted . B.sort $ s-      | otherwise                = Table . mkTable $ s--fromList :: [Word8] -> FastSet-fromList = set . B.pack--data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8--shiftR :: Int -> Int -> Int-shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)--shiftL :: Word8 -> Int -> Word8-shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))--index :: Int -> I-index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))-{-# INLINE index #-}---- | Check the set for membership.-memberWord8 :: Word8 -> FastSet -> Bool-memberWord8 w (Table t)  =-    let I byte bit = index (fromIntegral w)-    in  U.unsafeIndex t byte .&. bit /= 0-memberWord8 w (Sorted s) = search 0 (B.length s - 1)-    where search lo hi-              | hi < lo = False-              | otherwise =-                  let mid = (lo + hi) `div` 2-                  in case compare w (U.unsafeIndex s mid) of-                       GT -> search (mid + 1) hi-                       LT -> search lo (mid - 1)-                       _ -> True---- | Check the set for membership.  Only works with 8-bit characters:--- characters above code point 255 will give wrong answers.-memberChar :: Char -> FastSet -> Bool-memberChar c = memberWord8 (I.c2w c)-{-# INLINE memberChar #-}--mkTable :: B.ByteString -> B.ByteString-mkTable s = I.unsafeCreate 32 $ \t -> do-            _ <- I.memset t 0 32-            U.unsafeUseAsCStringLen s $ \(p, l) ->-              let loop n | n == l = return ()-                         | otherwise = do-                    c <- peekByteOff p n :: IO Word8-                    let I byte bit = index (fromIntegral c)-                    prev <- peekByteOff t byte :: IO Word8-                    pokeByteOff t byte (prev .|. bit)-                    loop (n + 1)-              in loop 0--charClass :: String -> FastSet-charClass = set . B8.pack . go-    where go (a:'-':b:xs) = [a..b] ++ go xs-          go (x:xs) = x : go xs-          go _ = ""
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Internal.hs 
@@ -1,516 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, Rank2Types, OverloadedStrings,-    RecordWildCards, MagicHash, UnboxedTuples #-}--- |--- Module      :  Data.Attoparsec.ByteString.Internal--- Copyright   :  Bryan O'Sullivan 2007-2011--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient parser combinators for 'B.ByteString' strings,--- loosely based on the Parsec library.--module Data.Attoparsec.ByteString.Internal-    (-    -- * Parser types-      Parser-    , Result--    -- * Running parsers-    , parse-    , parseOnly--    -- * Combinators-    , (<?>)-    , try-    , module Data.Attoparsec.Combinator--    -- * Parsing individual bytes-    , satisfy-    , satisfyWith-    , anyWord8-    , skip-    , word8-    , notWord8-    , peekWord8--    -- ** Byte classes-    , inClass-    , notInClass--    -- * Parsing more complicated structures-    , storable--    -- * Efficient string handling-    , skipWhile-    , string-    , stringTransform-    , take-    , scan-    , takeWhile-    , takeWhile1-    , takeTill--    -- ** Consume all remaining input-    , takeByteString-    , takeLazyByteString--    -- * State observation and manipulation functions-    , endOfInput-    , atEnd--    -- * Utilities-    , endOfLine-    ) where--import Control.Applicative ((<|>), (<$>))-import Control.Monad (when)-import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8)-import Data.Attoparsec.Combinator-import Data.Attoparsec.Internal.Types-    hiding (Parser, Input, Added, Failure, Success)-import Data.Monoid (Monoid(..))-import Data.Word (Word8)-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (castPtr, minusPtr, plusPtr)-import Foreign.Storable (Storable(peek, sizeOf))-import Prelude hiding (getChar, take, takeWhile)-import qualified Data.Attoparsec.Internal.Types as T-import qualified Data.ByteString as B8-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Internal as B-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Unsafe as B--#if defined(__GLASGOW_HASKELL__)-import GHC.Base (realWorld#)-import GHC.IO (IO(IO))-#else-import System.IO.Unsafe (unsafePerformIO)-#endif--type Parser = T.Parser B.ByteString-type Result = IResult B.ByteString-type Input = T.Input B.ByteString-type Added = T.Added B.ByteString-type Failure r = T.Failure B.ByteString r-type Success a r = T.Success B.ByteString a r--ensure' :: Int -> Input -> Added -> More -> Failure r -> Success B.ByteString r-        -> IResult B.ByteString r-ensure' !n0 i0 a0 m0 kf0 ks0 =-    T.runParser (demandInput >> go n0) i0 a0 m0 kf0 ks0-  where-    go !n = T.Parser $ \i a m kf ks ->-        if B.length (unI i) >= n-        then ks i a m (unI i)-        else T.runParser (demandInput >> go n) i a m kf ks---- | If at least @n@ bytes of input are available, return the current--- input, otherwise fail.-ensure :: Int -> Parser B.ByteString-ensure !n = T.Parser $ \i0 a0 m0 kf ks ->-    if B.length (unI i0) >= n-    then ks i0 a0 m0 (unI i0)-    -- The uncommon case is kept out-of-line to reduce code size:-    else ensure' n i0 a0 m0 kf ks--- Non-recursive so the bounds check can be inlined:-{-# INLINE ensure #-}---- | Ask for input.  If we receive any, pass it to a success--- continuation, otherwise to a failure continuation.-prompt :: Input -> Added -> More-       -> (Input -> Added -> More -> Result r)-       -> (Input -> Added -> More -> Result r)-       -> Result r-prompt i0 a0 _m0 kf ks = Partial $ \s ->-    if B.null s-    then kf i0 a0 Complete-    else ks (i0 <> I s) (a0 <> A s) Incomplete---- | Immediately demand more input via a 'Partial' continuation--- result.-demandInput :: Parser ()-demandInput = T.Parser $ \i0 a0 m0 kf ks ->-    if m0 == Complete-    then kf i0 a0 m0 ["demandInput"] "not enough bytes"-    else let kf' i a m = kf i a m ["demandInput"] "not enough bytes"-             ks' i a m = ks i a m ()-         in prompt i0 a0 m0 kf' ks'---- | This parser always succeeds.  It returns 'True' if any input is--- available either immediately or on demand, and 'False' if the end--- of all input has been reached.-wantInput :: Parser Bool-wantInput = T.Parser $ \i0 a0 m0 _kf ks ->-  case () of-    _ | not (B.null (unI i0)) -> ks i0 a0 m0 True-      | m0 == Complete  -> ks i0 a0 m0 False-      | otherwise       -> let kf' i a m = ks i a m False-                               ks' i a m = ks i a m True-                           in prompt i0 a0 m0 kf' ks'--get :: Parser B.ByteString-get  = T.Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)--put :: B.ByteString -> Parser ()-put s = T.Parser $ \_i0 a0 m0 _kf ks -> ks (I s) a0 m0 ()---- | Attempt a parse, and if it fails, rewind the input so that no--- input appears to have been consumed.------ This combinator is provided for compatibility with Parsec.--- Attoparsec parsers always backtrack on failure.-try :: Parser a -> Parser a-try p = p-{-# INLINE try #-}---- | The parser @satisfy p@ succeeds for any byte for which the--- predicate @p@ returns 'True'. Returns the byte that is actually--- parsed.------ >digit = satisfy isDigit--- >    where isDigit w = w >= 48 && w <= 57-satisfy :: (Word8 -> Bool) -> Parser Word8-satisfy p = do-  s <- ensure 1-  let !w = B.unsafeHead s-  if p w-    then put (B.unsafeTail s) >> return w-    else fail "satisfy"-{-# INLINE satisfy #-}---- | The parser @skip p@ succeeds for any byte for which the predicate--- @p@ returns 'True'.------ >skipDigit = skip isDigit--- >    where isDigit w = w >= 48 && w <= 57-skip :: (Word8 -> Bool) -> Parser ()-skip p = do-  s <- ensure 1-  if p (B.unsafeHead s)-    then put (B.unsafeTail s)-    else fail "skip"---- | The parser @satisfyWith f p@ transforms a byte, and succeeds if--- the predicate @p@ returns 'True' on the transformed value. The--- parser returns the transformed byte that was parsed.-satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a-satisfyWith f p = do-  s <- ensure 1-  let c = f $! B.unsafeHead s-  if p c-    then let !t = B.unsafeTail s-         in put t >> return c-    else fail "satisfyWith"-{-# INLINE satisfyWith #-}--storable :: Storable a => Parser a-storable = hack undefined- where-  hack :: Storable b => b -> Parser b-  hack dummy = do-    (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy)-    return . B.inlinePerformIO . withForeignPtr fp $ \p ->-        peek (castPtr $ p `plusPtr` o)---- | Consume @n@ bytes of input, but succeed only if the predicate--- returns 'True'.-takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString-takeWith n0 p = do-  let n = max n0 0-  s <- ensure n-  let h = B.unsafeTake n s-      t = B.unsafeDrop n s-  if p h-    then put t >> return h-    else fail "takeWith"---- | Consume exactly @n@ bytes of input.-take :: Int -> Parser B.ByteString-take n = takeWith n (const True)-{-# INLINE take #-}---- | @string s@ parses a sequence of bytes that identically match--- @s@. Returns the parsed string (i.e. @s@).  This parser consumes no--- input if it fails (even if a partial match).------ /Note/: The behaviour of this parser is different to that of the--- similarly-named parser in Parsec, as this one is all-or-nothing.--- To illustrate the difference, the following parser will fail under--- Parsec given an input of @\"for\"@:------ >string "foo" <|> string "for"------ The reason for its failure is that the first branch is a--- partial match, and will consume the letters @\'f\'@ and @\'o\'@--- before failing.  In Attoparsec, the above parser will /succeed/ on--- that input, because the failed first branch will consume nothing.-string :: B.ByteString -> Parser B.ByteString-string s = takeWith (B.length s) (==s)-{-# INLINE string #-}--stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString-                -> Parser B.ByteString-stringTransform f s = takeWith (B.length s) ((==f s) . f)-{-# INLINE stringTransform #-}---- | Skip past input for as long as the predicate returns 'True'.-skipWhile :: (Word8 -> Bool) -> Parser ()-skipWhile p = go- where-  go = do-    t <- B8.dropWhile p <$> get-    put t-    when (B.null t) $ do-      input <- wantInput-      when input go-{-# INLINE skipWhile #-}---- | Consume input as long as the predicate returns 'False'--- (i.e. until it returns 'True'), and return the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'True' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-takeTill :: (Word8 -> Bool) -> Parser B.ByteString-takeTill p = takeWhile (not . p)-{-# INLINE takeTill #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'False' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-takeWhile :: (Word8 -> Bool) -> Parser B.ByteString-takeWhile p = (B.concat . reverse) `fmap` go []- where-  go acc = do-    (h,t) <- B8.span p <$> get-    put t-    if B.null t-      then do-        input <- wantInput-        if input-          then go (h:acc)-          else return (h:acc)-      else return (h:acc)-{-# INLINE takeWhile #-}--takeRest :: Parser [B.ByteString]-takeRest = go []- where-  go acc = do-    input <- wantInput-    if input-      then do-        s <- get-        put B.empty-        go (s:acc)-      else return (reverse acc)---- | Consume all remaining input and return it as a single string.-takeByteString :: Parser B.ByteString-takeByteString = B.concat `fmap` takeRest---- | Consume all remaining input and return it as a single string.-takeLazyByteString :: Parser L.ByteString-takeLazyByteString = L.fromChunks `fmap` takeRest--data T s = T {-# UNPACK #-} !Int s---- | A stateful scanner.  The predicate consumes and transforms a--- state argument, and each transformed state is passed to successive--- invocations of the predicate on each byte of the input until one--- returns 'Nothing' or the input ends.------ This parser does not fail.  It will return an empty string if the--- predicate returns 'Nothing' on the first byte of input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-scan :: s -> (s -> Word8 -> Maybe s) -> Parser B.ByteString-scan s0 p = do-  chunks <- go [] s0-  case chunks of-    [x] -> return x-    xs  -> return $! B.concat $ reverse xs- where-  go acc s1 = do-    let scanner (B.PS fp off len) =-          withForeignPtr fp $ \ptr0 -> do-            let start = ptr0 `plusPtr` off-                end   = start `plusPtr` len-                inner ptr !s-                  | ptr < end = do-                    w <- peek ptr-                    case p s w of-                      Just s' -> inner (ptr `plusPtr` 1) s'-                      _       -> done (ptr `minusPtr` start) s-                  | otherwise = done (ptr `minusPtr` start) s-                done !i !s = return (T i s)-            inner start s1-    bs <- get-    let T i s' = inlinePerformIO $ scanner bs-        !h = B.unsafeTake i bs-        !t = B.unsafeDrop i bs-    put t-    if B.null t-      then do-        input <- wantInput-        if input-          then go (h:acc) s'-          else return (h:acc)-      else return (h:acc)-{-# INLINE scan #-}---- | Consume input as long as the predicate returns 'True', and return--- the consumed input.------ This parser requires the predicate to succeed on at least one byte--- of input: it will fail if the predicate never returns 'True' or if--- there is no input left.-takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString-takeWhile1 p = do-  (`when` demandInput) =<< B.null <$> get-  (h,t) <- B8.span p <$> get-  when (B.null h) $ fail "takeWhile1"-  put t-  if B.null t-    then (h<>) `fmap` takeWhile p-    else return h---- | Match any byte in a set.------ >vowel = inClass "aeiou"------ Range notation is supported.------ >halfAlphabet = inClass "a-nA-N"------ To add a literal @\'-\'@ to a set, place it at the beginning or end--- of the string.-inClass :: String -> Word8 -> Bool-inClass s = (`memberWord8` mySet)-    where mySet = charClass s-          {-# NOINLINE mySet #-}-{-# INLINE inClass #-}---- | Match any byte not in a set.-notInClass :: String -> Word8 -> Bool-notInClass s = not . inClass s-{-# INLINE notInClass #-}---- | Match any byte.-anyWord8 :: Parser Word8-anyWord8 = satisfy $ const True-{-# INLINE anyWord8 #-}---- | Match a specific byte.-word8 :: Word8 -> Parser Word8-word8 c = satisfy (== c) <?> show c-{-# INLINE word8 #-}---- | Match any byte except the given one.-notWord8 :: Word8 -> Parser Word8-notWord8 c = satisfy (/= c) <?> "not " ++ show c-{-# INLINE notWord8 #-}---- | Match any byte. Returns 'Nothing' if end of input has been--- reached. Does not consume any input.------ /Note/: Because this parser does not fail, do not use it with--- combinators such as 'many', because such parsers loop until a--- failure occurs.  Careless use will thus result in an infinite loop.-peekWord8 :: Parser (Maybe Word8)-peekWord8 = T.Parser $ \i0 a0 m0 _kf ks ->-            if B.null (unI i0)-            then if m0 == Complete-                 then ks i0 a0 m0 Nothing-                 else let ks' i a m = let !w = B.unsafeHead (unI i)-                                      in ks i a m (Just w)-                          kf' i a m = ks i a m Nothing-                      in prompt i0 a0 m0 kf' ks'-            else let !w = B.unsafeHead (unI i0)-                 in ks i0 a0 m0 (Just w)-{-# INLINE peekWord8 #-}---- | Match only if all input has been consumed.-endOfInput :: Parser ()-endOfInput = T.Parser $ \i0 a0 m0 kf ks ->-             if B.null (unI i0)-             then if m0 == Complete-                  then ks i0 a0 m0 ()-                  else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $-                                              \ i2 a2 m2 -> ks i2 a2 m2 ()-                           ks' i1 a1 m1 _   = addS i0 a0 m0 i1 a1 m1 $-                                              \ i2 a2 m2 -> kf i2 a2 m2 []-                                                            "endOfInput"-                       in  T.runParser demandInput i0 a0 m0 kf' ks'-             else kf i0 a0 m0 [] "endOfInput"---- | Return an indication of whether the end of input has been--- reached.-atEnd :: Parser Bool-atEnd = not <$> wantInput-{-# INLINE atEnd #-}---- | Match either a single newline character @\'\\n\'@, or a carriage--- return followed by a newline character @\"\\r\\n\"@.-endOfLine :: Parser ()-endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ())---- | Name the parser, in case failure occurs.-(<?>) :: Parser a-      -> String                 -- ^ the name to use if parsing fails-      -> Parser a-p <?> msg0 = T.Parser $ \i0 a0 m0 kf ks ->-             let kf' i a m strs msg = kf i a m (msg0:strs) msg-             in T.runParser p i0 a0 m0 kf' ks-{-# INLINE (<?>) #-}-infix 0 <?>---- | Terminal failure continuation.-failK :: Failure a-failK i0 _a0 _m0 stack msg = Fail (unI i0) stack msg-{-# INLINE failK #-}---- | Terminal success continuation.-successK :: Success a a-successK i0 _a0 _m0 a = Done (unI i0) a-{-# INLINE successK #-}---- | Run a parser.-parse :: Parser a -> B.ByteString -> Result a-parse m s = T.runParser m (I s) mempty Incomplete failK successK-{-# INLINE parse #-}---- | Run a parser that cannot be resupplied via a 'Partial' result.-parseOnly :: Parser a -> B.ByteString -> Either String a-parseOnly m s = case T.runParser m (I s) mempty Complete failK successK of-                  Fail _ _ err -> Left err-                  Done _ a     -> Right a-                  _            -> error "parseOnly: impossible error!"-{-# INLINE parseOnly #-}---- | Just like unsafePerformIO, but we inline it. Big performance gains as--- it exposes lots of things to further inlining. /Very unsafe/. In--- particular, you should do no memory allocation inside an--- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.-inlinePerformIO :: IO a -> a-#if defined(__GLASGOW_HASKELL__)-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-#else-inlinePerformIO = unsafePerformIO-#endif-{-# INLINE inlinePerformIO #-}
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/Combinator.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}--- |--- Module      :  Data.Attoparsec.Combinator--- Copyright   :  Daan Leijen 1999-2001, Bryan O'Sullivan 2009-2010--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  portable------ Useful parser combinators, similar to those provided by Parsec.-module Data.Attoparsec.Combinator-    (-      choice-    , count-    , option-    , many'-    , many1-    , many1'-    , manyTill-    , manyTill'-    , sepBy-    , sepBy'-    , sepBy1-    , sepBy1'-    , skipMany-    , skipMany1-    , eitherP-    ) where--import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2,-                            (<|>), (*>), (<$>))-import Control.Monad (MonadPlus(..))-#if !MIN_VERSION_base(4,2,0)-import Control.Applicative (many)-#endif--#if __GLASGOW_HASKELL__ >= 700-import Data.Attoparsec.Internal.Types (Parser)-import Data.ByteString (ByteString)-#endif---- | @choice ps@ tries to apply the actions in the list @ps@ in order,--- until one of them succeeds. Returns the value of the succeeding--- action.-choice :: Alternative f => [f a] -> f a-choice = foldr (<|>) empty-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE choice :: [Parser ByteString a] -> Parser ByteString a #-}-#endif---- | @option x p@ tries to apply action @p@. If @p@ fails without--- consuming input, it returns the value @x@, otherwise the value--- returned by @p@.------ > priority  = option 0 (digitToInt <$> digit)-option :: Alternative f => a -> f a -> f a-option x p = p <|> pure x-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-}-#endif---- | A version of 'liftM2' that is strict in the result of its first--- action.-liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c-liftM2' f a b = do-  !x <- a-  y <- b-  return (f x y)-{-# INLINE liftM2' #-}---- | @many' p@ applies the action @p@ /zero/ or more times. Returns a--- list of the returned values of @p@. The value returned by @p@ is--- forced to WHNF.------ >  word  = many' letter-many' :: (MonadPlus m) => m a -> m [a]-many' p = many_p-  where many_p = some_p `mplus` return []-        some_p = liftM2' (:) p many_p-{-# INLINE many' #-}---- | @many1 p@ applies the action @p@ /one/ or more times. Returns a--- list of the returned values of @p@.------ >  word  = many1 letter-many1 :: Alternative f => f a -> f [a]-many1 p = liftA2 (:) p (many p)-{-# INLINE many1 #-}---- | @many1' p@ applies the action @p@ /one/ or more times. Returns a--- list of the returned values of @p@. The value returned by @p@ is--- forced to WHNF.------ >  word  = many1' letter-many1' :: (MonadPlus m) => m a -> m [a]-many1' p = liftM2' (:) p (many' p)-{-# INLINE many1' #-}---- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@.------ > commaSep p  = p `sepBy` (symbol ",")-sepBy :: Alternative f => f a -> f s -> f [a]-sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s-                     -> Parser ByteString [a] #-}-#endif---- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@. The value--- returned by @p@ is forced to WHNF.------ > commaSep p  = p `sepBy'` (symbol ",")-sepBy' :: (MonadPlus m) => m a -> m s -> m [a]-sepBy' p s = scan `mplus` return []-  where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s-                      -> Parser ByteString [a] #-}-#endif---- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@.------ > commaSep p  = p `sepBy1` (symbol ",")-sepBy1 :: Alternative f => f a -> f s -> f [a]-sepBy1 p s = scan-    where scan = liftA2 (:) p ((s *> scan) <|> pure [])-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s-                      -> Parser ByteString [a] #-}-#endif---- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated--- by @sep@. Returns a list of the values returned by @p@. The value--- returned by @p@ is forced to WHNF.------ > commaSep p  = p `sepBy1'` (symbol ",")-sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]-sepBy1' p s = scan-    where scan = liftM2' (:) p ((s >> scan) `mplus` return [])-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s-                       -> Parser ByteString [a] #-}-#endif---- | @manyTill p end@ applies action @p@ /zero/ or more times until--- action @end@ succeeds, and returns the list of values returned by--- @p@.  This can be used to scan comments:------ >  simpleComment   = string "<!--" *> manyTill anyChar (try (string "-->"))------ Note the overlapping parsers @anyChar@ and @string \"<!--\"@, and--- therefore the use of the 'try' combinator.-manyTill :: Alternative f => f a -> f b -> f [a]-manyTill p end = scan-    where scan = (end *> pure []) <|> liftA2 (:) p scan-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b-                        -> Parser ByteString [a] #-}-#endif---- | @manyTill' p end@ applies action @p@ /zero/ or more times until--- action @end@ succeeds, and returns the list of values returned by--- @p@.  This can be used to scan comments:------ >  simpleComment   = string "<!--" *> manyTill' anyChar (try (string "-->"))------ Note the overlapping parsers @anyChar@ and @string \"<!--\"@, and--- therefore the use of the 'try' combinator. The value returned by @p@--- is forced to WHNF.-manyTill' :: (MonadPlus m) => m a -> m b -> m [a]-manyTill' p end = scan-    where scan = (end >> return []) `mplus` liftM2' (:) p scan-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b-                         -> Parser ByteString [a] #-}-#endif---- | Skip zero or more instances of an action.-skipMany :: Alternative f => f a -> f ()-skipMany p = scan-    where scan = (p *> scan) <|> pure ()-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-}-#endif---- | Skip one or more instances of an action.-skipMany1 :: Alternative f => f a -> f ()-skipMany1 p = p *> skipMany p-#if __GLASGOW_HASKELL__ >= 700-{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-}-#endif---- | Apply the given action repeatedly, returning every result.-count :: Monad m => Int -> m a -> m [a]-count n p = sequence (replicate n p)-{-# INLINE count #-}---- | Combine two alternatives.-eitherP :: (Alternative f) => f a -> f b -> f (Either a b)-eitherP a b = (Left <$> a) <|> (Right <$> b)-{-# INLINE eitherP #-}
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/Internal.hs 
@@ -1,31 +0,0 @@--- |--- Module      :  Data.Attoparsec.Internal--- Copyright   :  Bryan O'Sullivan 2012--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient parser combinators, loosely based on the Parsec--- library.--module Data.Attoparsec.Internal-    (-      compareResults-    ) where--import Data.Attoparsec.Internal.Types (IResult(..))---- | Compare two 'IResult' values for equality.------ If both 'IResult's are 'Partial', the result will be 'Nothing', as--- they are incomplete and hence their equality cannot be known.--- (This is why there is no 'Eq' instance for 'IResult'.)-compareResults :: (Eq t, Eq r) => IResult t r -> IResult t r -> Maybe Bool-compareResults (Fail i0 ctxs0 msg0) (Fail i1 ctxs1 msg1) =-    Just (i0 == i1 && ctxs0 == ctxs1 && msg0 == msg1)-compareResults (Done i0 r0) (Done i1 r1) =-    Just (i0 == i1 && r0 == r1)-compareResults (Partial _) (Partial _) = Nothing-compareResults _ _ = Just False
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/Internal/Types.hs 
@@ -1,227 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, OverloadedStrings,-    Rank2Types, RecordWildCards #-}--- |--- Module      :  Data.Attoparsec.Internal.Types--- Copyright   :  Bryan O'Sullivan 2007-2011--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ Simple, efficient parser combinators, loosely based on the Parsec--- library.--module Data.Attoparsec.Internal.Types-    (-      Parser(..)-    , Failure-    , Success-    , IResult(..)-    , Input(..)-    , Added(..)-    , More(..)-    , addS-    , (<>)-    ) where--import Control.Applicative (Alternative(..), Applicative(..), (<$>))-import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(..))-import Data.Monoid (Monoid(..))-import Prelude hiding (getChar, take, takeWhile)---- | The result of a parse.  This is parameterised over the type @t@--- of string that was processed.------ This type is an instance of 'Functor', where 'fmap' transforms the--- value in a 'Done' result.-data IResult t r = Fail t [String] String-                 -- ^ The parse failed.  The 't' parameter is the-                 -- input that had not yet been consumed when the-                 -- failure occurred.  The @[@'String'@]@ is a list of-                 -- contexts in which the error occurred.  The-                 -- 'String' is the message describing the error, if-                 -- any.-                 | Partial (t -> IResult t r)-                 -- ^ Supply this continuation with more input so that-                 -- the parser can resume.  To indicate that no more-                 -- input is available, use an empty string.-                 | Done t r-                 -- ^ The parse succeeded.  The 't' parameter is the-                 -- input that had not yet been consumed (if any) when-                 -- the parse succeeded.--instance (Show t, Show r) => Show (IResult t r) where-    show (Fail t stk msg) =-        "Fail " ++ show t ++ " " ++ show stk ++ " " ++ show msg-    show (Partial _)      = "Partial _"-    show (Done t r)       = "Done " ++ show t ++ " " ++ show r--instance (NFData t, NFData r) => NFData (IResult t r) where-    rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg-    rnf (Partial _)  = ()-    rnf (Done t r)   = rnf t `seq` rnf r-    {-# INLINE rnf #-}--fmapR :: (a -> b) -> IResult t a -> IResult t b-fmapR _ (Fail t stk msg) = Fail t stk msg-fmapR f (Partial k)       = Partial (fmapR f . k)-fmapR f (Done t r)       = Done t (f r)--instance Functor (IResult t) where-    fmap = fmapR-    {-# INLINE fmap #-}--newtype Input t = I {unI :: t} deriving (Monoid)-newtype Added t = A {unA :: t} deriving (Monoid)---- | The core parser type.  This is parameterised over the type @t@ of--- string being processed.------ This type is an instance of the following classes:------ * 'Monad', where 'fail' throws an exception (i.e. fails) with an---   error message.------ * 'Functor' and 'Applicative', which follow the usual definitions.------ * 'MonadPlus', where 'mzero' fails (with no error message) and---   'mplus' executes the right-hand parser if the left-hand one---   fails.  When the parser on the right executes, the input is reset---   to the same state as the parser on the left started with. (In---   other words, Attoparsec is a backtracking parser that supports---   arbitrary lookahead.)------ * 'Alternative', which follows 'MonadPlus'.-newtype Parser t a = Parser {-      runParser :: forall r. Input t -> Added t -> More-                -> Failure t   r-                -> Success t a r-                -> IResult t r-    }--type Failure t   r = Input t -> Added t -> More -> [String] -> String-                   -> IResult t r-type Success t a r = Input t -> Added t -> More -> a -> IResult t r---- | Have we read all available input?-data More = Complete | Incomplete-            deriving (Eq, Show)--instance Monoid More where-    mappend c@Complete _ = c-    mappend _ m          = m-    mempty               = Incomplete--addS :: (Monoid t) =>-        Input t -> Added t -> More-     -> Input t -> Added t -> More-     -> (Input t -> Added t -> More -> r) -> r-addS i0 a0 m0 _i1 a1 m1 f =-    let !i = i0 <> I (unA a1)-        a  = a0 <> a1-        !m = m0 <> m1-    in f i a m-{-# INLINE addS #-}--bindP :: Parser t a -> (a -> Parser t b) -> Parser t b-bindP m g =-    Parser $ \i0 a0 m0 kf ks -> runParser m i0 a0 m0 kf $-                                \i1 a1 m1 a -> runParser (g a) i1 a1 m1 kf ks-{-# INLINE bindP #-}--returnP :: a -> Parser t a-returnP a = Parser (\i0 a0 m0 _kf ks -> ks i0 a0 m0 a)-{-# INLINE returnP #-}--instance Monad (Parser t) where-    return = returnP-    (>>=)  = bindP-    fail   = failDesc--noAdds :: (Monoid t) =>-          Input t -> Added t -> More-       -> (Input t -> Added t -> More -> r) -> r-noAdds i0 _a0 m0 f = f i0 mempty m0-{-# INLINE noAdds #-}--plus :: (Monoid t) => Parser t a -> Parser t a -> Parser t a-plus a b = Parser $ \i0 a0 m0 kf ks ->-           let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $-                                  \ i2 a2 m2 -> runParser b i2 a2 m2 kf ks-               ks' i1 a1 m1 = ks i1 (a0 <> a1) m1-           in  noAdds i0 a0 m0 $ \i2 a2 m2 -> runParser a i2 a2 m2 kf' ks'-{-# INLINE plus #-}--instance (Monoid t) => MonadPlus (Parser t) where-    mzero = failDesc "mzero"-    {-# INLINE mzero #-}-    mplus = plus--fmapP :: (a -> b) -> Parser t a -> Parser t b-fmapP p m = Parser $ \i0 a0 m0 f k ->-            runParser m i0 a0 m0 f $ \i1 a1 s1 a -> k i1 a1 s1 (p a)-{-# INLINE fmapP #-}--instance Functor (Parser t) where-    fmap = fmapP-    {-# INLINE fmap #-}--apP :: Parser t (a -> b) -> Parser t a -> Parser t b-apP d e = do-  b <- d-  a <- e-  return (b a)-{-# INLINE apP #-}--instance Applicative (Parser t) where-    pure   = returnP-    {-# INLINE pure #-}-    (<*>)  = apP-    {-# INLINE (<*>) #-}--#if MIN_VERSION_base(4,2,0)-    -- These definitions are equal to the defaults, but this-    -- way the optimizer doesn't have to work so hard to figure-    -- that out.-    (*>)   = (>>)-    {-# INLINE (*>) #-}-    x <* y = x >>= \a -> y >> return a-    {-# INLINE (<*) #-}-#endif--instance (Monoid t) => Monoid (Parser t a) where-    mempty  = failDesc "mempty"-    {-# INLINE mempty #-}-    mappend = plus-    {-# INLINE mappend #-}--instance (Monoid t) => Alternative (Parser t) where-    empty = failDesc "empty"-    {-# INLINE empty #-}--    (<|>) = plus-    {-# INLINE (<|>) #-}--#if MIN_VERSION_base(4,2,0)-    many v = many_v-        where many_v = some_v <|> pure []-              some_v = (:) <$> v <*> many_v-    {-# INLINE many #-}--    some v = some_v-      where-        many_v = some_v <|> pure []-        some_v = (:) <$> v <*> many_v-    {-# INLINE some #-}-#endif--failDesc :: String -> Parser t a-failDesc err = Parser (\i0 a0 m0 kf _ks -> kf i0 a0 m0 [] msg)-    where msg = "Failed reading: " ++ err-{-# INLINE failDesc #-}--(<>) :: (Monoid m) => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}
− vendor/attoparsec-0.10.4.0/Data/Attoparsec/Number.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--- |--- Module      :  Data.Attoparsec.Number--- Copyright   :  Bryan O'Sullivan 2011--- License     :  BSD3------ Maintainer  :  bos@serpentine.com--- Stability   :  experimental--- Portability :  unknown------ A simple number type, useful for parsing both exact and inexact--- quantities without losing much precision.-module Data.Attoparsec.Number-    (-      Number(..)-    ) where--import Control.DeepSeq (NFData(rnf))-import Data.Data (Data)-import Data.Function (on)-import Data.Typeable (Typeable)---- | A numeric type that can represent integers accurately, and--- floating point numbers to the precision of a 'Double'.-data Number = I !Integer-            | D {-# UNPACK #-} !Double-              deriving (Typeable, Data)--instance Show Number where-    show (I a) = show a-    show (D a) = show a--instance NFData Number where-    rnf (I _) = ()-    rnf (D _) = ()-    {-# INLINE rnf #-}--binop :: (Integer -> Integer -> a) -> (Double -> Double -> a)-      -> Number -> Number -> a-binop _ d (D a) (D b) = d a b-binop i _ (I a) (I b) = i a b-binop _ d (D a) (I b) = d a (fromIntegral b)-binop _ d (I a) (D b) = d (fromIntegral a) b-{-# INLINE binop #-}--instance Eq Number where-    (==) = binop (==) (==)-    {-# INLINE (==) #-}--    (/=) = binop (/=) (/=)-    {-# INLINE (/=) #-}--instance Ord Number where-    (<) = binop (<) (<)-    {-# INLINE (<) #-}--    (<=) = binop (<=) (<=)-    {-# INLINE (<=) #-}--    (>) = binop (>) (>)-    {-# INLINE (>) #-}--    (>=) = binop (>=) (>=)-    {-# INLINE (>=) #-}--    compare = binop compare compare-    {-# INLINE compare #-}--instance Num Number where-    (+) = binop (((I$!).) . (+)) (((D$!).) . (+))-    {-# INLINE (+) #-}--    (-) = binop (((I$!).) . (-)) (((D$!).) . (-))-    {-# INLINE (-) #-}--    (*) = binop (((I$!).) . (*)) (((D$!).) . (*))-    {-# INLINE (*) #-}--    abs (I a) = I $! abs a-    abs (D a) = D $! abs a-    {-# INLINE abs #-}--    negate (I a) = I $! negate a-    negate (D a) = D $! negate a-    {-# INLINE negate #-}--    signum (I a) = I $! signum a-    signum (D a) = D $! signum a-    {-# INLINE signum #-}--    fromInteger = (I$!) . fromInteger-    {-# INLINE fromInteger #-}--instance Real Number where-    toRational (I a) = fromIntegral a-    toRational (D a) = toRational a-    {-# INLINE toRational #-}--instance Fractional Number where-    fromRational = (D$!) . fromRational-    {-# INLINE fromRational #-}--    (/) = binop (((D$!).) . (/) `on` fromIntegral)-                (((D$!).) . (/))-    {-# INLINE (/) #-}--    recip (I a) = D $! recip (fromIntegral a)-    recip (D a) = D $! recip a-    {-# INLINE recip #-}--instance RealFrac Number where-    properFraction (I a) = (fromIntegral a,0)-    properFraction (D a) = case properFraction a of-                             (i,d) -> (i,D d)-    {-# INLINE properFraction #-}-    truncate (I a) = fromIntegral a-    truncate (D a) = truncate a-    {-# INLINE truncate #-}-    round (I a) = fromIntegral a-    round (D a) = round a-    {-# INLINE round #-}-    ceiling (I a) = fromIntegral a-    ceiling (D a) = ceiling a-    {-# INLINE ceiling #-}-    floor (I a) = fromIntegral a-    floor (D a) = floor a-    {-# INLINE floor #-}