packages feed

haddock-leksah (empty) → 2.5.0

raw patch · 65 files changed

+11821/−0 lines, 65 filesdep +Cabaldep +arraydep +basesetup-changedbinary-added

Dependencies added: Cabal, array, base, containers, directory, filepath, ghc, ghc-paths, haskell98, pretty

Files

+ CHANGES view
@@ -0,0 +1,346 @@+Changed in version 2.5.0:++  * Drop support for GHC 6.8.*++  * Add support for GHC 6.10.3 and 6.10.4++  * Revert to the old multi-page index for large packages (#106)++  * Show GADT records in the generated documentation++  * Create output directory if it doesn't exist (#104)++  * Use the native codegen instead of compiling via C for TH modules++  * Add --use-unicode flag for displaying prettier versions of common symbols++  * Mutiple verbosity levels: remove --verbose and add --verbosity=n++-----------------------------------------------------------------------------++Changed in version 2.4.2:++  * Support GHC 6.10.2++  * Haddock no longer crashes on Template Haskell modules (#68)+    (only with GHC 6.10.2 or above)++  * Fix problem with Template Haskell-generated declarations disappearing (#59)++  * Generate two anchors for each link for compatibility between IE and Opera+    (#45)++  * Improved error messages++  * Show re-exports from external packages again (GHC ticket #2746)++  * Store hidden modules in .haddock files again (needed by the haddock+    library)++  * Avoid processing boot modules++  * Pragmas may exist between document comments and declarations++  * Do not indicate that a constructor argument is unboxed++  * Fix problem with with non-working links to ghc-prim++  * Allow referring to a specific section within a module in a module link+    (#65)++  * Fixes to the Hoogle backend+  +  * Improvements to the haddock library++  * Many other fixes (including #67, #69, #58, #57)++-----------------------------------------------------------------------------++Changed in version 2.4.1:++  * Depend on base 4.* when GHC >= 6.9, otherwise 3.*++-----------------------------------------------------------------------------++Changed in version 2.4.0:++  * Add framed view of the HTML documentation++  * Build with GHC 6.8.2 and 6.8.3 again++  * Support images in documentation comments again++  * Small improvements to the Hoogle output++  * A few bugs has been fixed++-----------------------------------------------------------------------------++Changed in version 2.3.0:++  * Support for GHC 6.10.1++  * Slightly improved space usage++  * Fix a bug that made hidden modules show up in the contents & index pages++  * Fix a bug that made Haddock load modules twice++  * Improvements to the Hoogle output++-----------------------------------------------------------------------------++Changed in version 2.2.2:++  * Relax version dependency on ghc-paths++-----------------------------------------------------------------------------++Changes in version 2.2.1:++  * Support for GHC 6.8.3++  * The Hoogle backend is back, thanks to Neil Mitchell. The plan is to be+    compatible with the upcoming Hoogle 4 pre-release++  * Show associated types in the documentation for class declarations++  * Show type family declarations++  * Show type equality predicates++  * Major bug fixes (#1 and #44)++  * It is no longer required to specify the path to GHC's lib dir++  * Remove unnecessary parenthesis in type signatures++-----------------------------------------------------------------------------++Changes in version 2.1.0:++  * Fix a bug that made links point to the defining module instead+    of the "best" one (e.g Int pointing to GHC.Base instead of Data.Int)++  * Fix a couple of smaller bugs++  * The representation of DocName was changed in the library++  * Add a flag --no-warnings for turning off warnings++-----------------------------------------------------------------------------++Changes in version 2.0.0.0:++  * The GHC API is used as the front-end++  * Haddock now understands all syntax understood by GHC 6.8.2++  * Haddock can generate documentation for some of the language extensions+    in GHC 6.8.2++  * Format of module attributes has changed. The only way of specifiying+    module attributes is via a new OPTIONS_HADDOCK pragma. Example: +    {-# OPTIONS_HADDOCK hide, prune #-}++  * Haddock understands literate source files++  * Add a small library to read Haddock's interface files++  * Add a flag -B for passing the path to the GHC lib dir++  * Add a flag --optghc for passing options to GHC++  * Add a flag --ghc-version for printing the GHC version++  * Remove --use-package, --allow-missing-html, --ghc-pkg, in favour of only+    supporting --read-interface++  * Remove --package flag, the GHC flag -package-name can be used instead++  * Remove --no-implicit-prelude flag, the GHC flag -XNoImplicitPrelude can+    be used instead++-----------------------------------------------------------------------------++Changes in version 0.9:++  * Infix type operators, e.g., first :: a~>a' -> (a,b)~>(a',b)++  * Add a search box to the index page which automatically narrows+    the index to the search as you type (thanks to Neil Mitchell).++  * Add a --ghc-pkg flag++  * Add a flag --allow-missing-html++  * URL expansion for %%, %L, %{LINE}++  * added substitution %{FILE///c}++  * Lexing of /.../ is now more like '...', in that a / character must+    be matched by another / character on the same line, otherwise it+    is treated as a literal '/'.  This removes a common source of+    accidental parse errors in documentation.++  * Various bugs were fixed.++  * Cabal 1.2 is now required, and Haddock builds with GHC 6.8.x.++-----------------------------------------------------------------------------++Changes in version 0.8:++  * Haddock has a Cabal build system, and will build on Windows without+    Cygwin or MSYS.  GHC 6.4 or later is required.++  * New options: --comments-base, --comments-module, --comments-entity+    for generating links to pages (eg. wiki) for collecting user comments.++  * New options: --source-base, --source-module, --source-entity+    for generating links to source code.  Haddock now understands+    {-# LINE #-} pragmas, which means it can figure out the correct+    name for the source file even if the file is preprocessed.++  * Haddock generates output for populating the Hoogle search engine.++  * New markup <<url>> for including images.++-----------------------------------------------------------------------------++Changes in version 0.7:++  * Changes in the way Haddock decides where to direct hyperlinks.  Each entity+    is now assigned a single "home" module, and all hyperlinks are directed+    to that module.  See the docs ("Hyperlinking and re-exported entities")+    for details.++  * New options --ignore-all-exports, --hide++  * New option --use-package for creating documentation that hyperlinks to+    the HTML documentation for existing packages on your system.  It works+    by querying ghc-pkg for the location of the Haddock interface and+    HTML for the given package.++  * Parts of the HTML documentation, notably lists of instances, are+    now "collapsible" with a +/- button.  Also, the contents page is now+    in the form of tree in which subtrees can be collapsed.++  * Support for Microsoft DevHelp and HtmlHelp 2.0 formats.++  * Support for a short description for each module for the contents page.++  * Compiles with GHC 6.4+++  * Various bugfixes++-----------------------------------------------------------------------------++Changes in version 0.6:++  * Implicit parameters, zip comprehensions and 'mdo' are now+    supported by the parser.++  * Some lexical bugs were fixed, mainly concerning literal paragraphs+    next to non-literal paragraphs.++  * New options:  --gen-index, --use-index, --gen-contents and --use-contents,+    for generting a combined index and contents for several libraries+    from the appropriate .haddock files.++  * There is now one index rather than separate Function/Constructor and+    Type/Class indices.  Where a name refers to several entities, these+    are listed separately in the index.++  * New option: -v, elicits more verbose warnings.  Some warnings are+    now turned off by default; Haddock should be a little less noisy+    in general.++  * Markup for definition lists has been added.  See the documentation +    for details.++  * New option: --package for setting the package name.  The package+    is listed alongside each module name in the combined contents.++  * Entities which are re-exported from another package now at least+    leave a hyperlink in the generated HTML, rather than nothing at all.++  * Some fixes for bugs which caused incorrect hyperlinks in the+    generated HTML.  In particular, instances should now be linked+    correctly.++  * Some aesthetic improvements to the generated HTML.++-----------------------------------------------------------------------------++Changes in version 0.5:++  * Compiles with recent versions of GHC.++  * A few bugs have been fixed.++  * New labelling/linking feature (see "Anchors" in the manual).++-----------------------------------------------------------------------------++Changes in version 0.4:++  * Import declarations which list entities in parentheses, or with+    hiding clauses, are now properly supported.  Modulo one or two+    small infelicities, the full Haskell modules system is now supported.++  * Haddock is now more flexible about the placing of separators+    (commas, semicolons) in relation to doc comments.++  * There is support for generating and reading "interface files"+    which describe the exports of a set of modules.  This is useful+    for generating documentation which hyperlinks to+    previously-generated documentation.+    +  * Support for generating the extra files required by the Microsoft+    Help compiler.++  * New option: --prologue specifies a file of documentation which is+    placed on the contents page.++  * Many bugs fixed++-----------------------------------------------------------------------------+Changes in version 0.3:+  +  * Documentation on individual function arguments is now implemented +  +  * Links can be made to identifiers that aren't in scope, by using+    the fully qualified name.++  * Instances are collected and listed with the appropriate classes+    and datatypes (not for derived instances yet).++  * Single quotes are only interpreted specially when they surround a+    legal Haskell identifier, otherwise they are treated literally.++  * Bird-tracked text is now literal.  If you want marked-up text in+    a code block, use the @...@ notation instead.++  * Various changes to the layout, it generally looks nicer now.++  * Various bugs fixed.++-----------------------------------------------------------------------------+Changes in version 0.2:++  * The [...] markup for typewriter font has been changed to @...@.++  * Module attributes introduced (see the documentation for details).++  * {- ... -} style comments may now be used for documentation annotations++  * Recursive modules are detected and reported as an error.++  * Existential constructors and rank-N types are now groked by the parser++  * Some type rendering cleaned up++  * `abc' is accepted as well as 'abc' to markup an identifier++  * Several bugs fixed, and error messages improved.
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright 2002, Simon Marlow.  All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,48 @@+Haddock, a Haskell Documentation Tool+=====================================++This is Haddock, a tool for automatically generating documentation+from annotated Haskell source code.  It is primary intended for+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 understands Haskell's module system, so you can structure your+code however you like without worrying that internal structure will be+exposed in the generated documentation.  For example, it is common to+implement a library in several modules, but define the external API by+having a single module which re-exports parts of these implementation+modules.  Using Haddock, you can still write documentation annotations+next to the actual definitions of the functions and types in the+library, but the documentation annotations from the implementation+will be propagated to the external API when the documentation is+generated.  Abstract types and classes are handled correctly.  In+fact, even without any documentation annotations, Haddock can generate+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).++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/
+ Setup.lhs view
@@ -0,0 +1,5 @@+#! /usr/bin/runhaskell+\begin{code}+import Distribution.Simple+main = defaultMain+\end{code}
+ doc/Makefile view
@@ -0,0 +1,6 @@+include config.mk++XML_DOC = haddock+INSTALL_XML_DOC = haddock++include docbook-xml.mk
+ doc/README view
@@ -0,0 +1,25 @@+Haddock documentation+---------------------++The documentation is in DocBook XML format.  You need some tools to+process it: at least xsltproc, and the DocBook XML DTD and XSL+stylesheets.  There's a configure script to detect the right way to+process the documentation on your system, and a Makefile to actually+do the processing (so, on Windows, you'll need Cygwin or MSys in+addition to the DocBook XML tools).  To build the HTML documentation:++   $ ./configure+   $ make html++which leaves the HTML documentation in a haddock/ subdirectory.++Printable documentation can also be produced, eg.:++   $ make pdf++or++   $ make ps++Generating the printed formats requires more tools (fop or xmltex) and+tends to be a bit harder.
+ doc/aclocal.m4 view
@@ -0,0 +1,174 @@+# FP_GEN_DOCBOOK_XML+# ------------------+# Generates a DocBook XML V4.2 document in conftest.xml.+AC_DEFUN([FP_GEN_DOCBOOK_XML],+[rm -f conftest.xml+cat > conftest.xml << EOF+<?xml version="1.0" encoding="iso-8859-1"?>+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"+   "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd">+<book id="test">+  <title>A DocBook Test Document</title>+  <chapter id="id-one">+    <title>A Chapter Title</title>+    <para>This is a paragraph, referencing <xref linkend="id-two"/>.</para>+  </chapter>+  <chapter id="id-two">+    <title>Another Chapter Title</title>+    <para>This is another paragraph, referencing <xref linkend="id-one"/>.</para>+  </chapter>+</book>+EOF+]) # FP_GEN_DOCBOOK_XML+++# FP_PROG_XSLTPROC+# ----------------+# Sets the output variable XsltprocCmd to the full path of the XSLT processor+# xsltproc. XsltprocCmd is empty if xsltproc could not be found.+AC_DEFUN([FP_PROG_XSLTPROC],+[AC_PATH_PROG([XsltprocCmd], [xsltproc])+if test -z "$XsltprocCmd"; then+  AC_MSG_WARN([cannot find xsltproc in your PATH, you will not be able to build the documentation])+fi+])# FP_PROG_XSLTPROC+++# FP_DIR_DOCBOOK_XSL(XSL-DIRS)+# ----------------------------+# Check which of the directories XSL-DIRS contains DocBook XSL stylesheets. The+# output variable DIR_DOCBOOK_XSL will contain the first usable directory or+# will be empty if none could be found.+AC_DEFUN([FP_DIR_DOCBOOK_XSL],+[AC_REQUIRE([FP_PROG_XSLTPROC])dnl+if test -n "$XsltprocCmd"; then+  AC_CACHE_CHECK([for DocBook XSL stylesheet directory], fp_cv_dir_docbook_xsl,+  [FP_GEN_DOCBOOK_XML+  fp_cv_dir_docbook_xsl=no+  for fp_var in $1; do+     if $XsltprocCmd ${fp_var}/html/docbook.xsl conftest.xml > /dev/null 2>&1; then+        fp_cv_dir_docbook_xsl=$fp_var+        break+     fi+  done+  rm -rf conftest*])+fi+if test x"$fp_cv_dir_docbook_xsl" = xno; then+  AC_MSG_WARN([cannot find DocBook XSL stylesheets, you will not be able to build the documentation])+  DIR_DOCBOOK_XSL=+else+  DIR_DOCBOOK_XSL=$fp_cv_dir_docbook_xsl+fi+AC_SUBST([DIR_DOCBOOK_XSL])+])# FP_DIR_DOCBOOK_XSL+++# FP_PROG_XMLLINT+# ----------------+# Sets the output variable XmllintCmd to the full path of the XSLT processor+# xmllint. XmllintCmd is empty if xmllint could not be found.+AC_DEFUN([FP_PROG_XMLLINT],+[AC_PATH_PROG([XmllintCmd], [xmllint])+if test -z "$XmllintCmd"; then+  AC_MSG_WARN([cannot find xmllint in your PATH, you will not be able to validate your documentation])+fi+])# FP_PROG_XMLLINT+++# FP_CHECK_DOCBOOK_DTD+# --------------------+AC_DEFUN([FP_CHECK_DOCBOOK_DTD],+[AC_REQUIRE([FP_PROG_XMLLINT])dnl+if test -n "$XmllintCmd"; then+  AC_MSG_CHECKING([for DocBook DTD])+  FP_GEN_DOCBOOK_XML+  if $XmllintCmd --valid --noout conftest.xml > /dev/null 2>&1; then+    AC_MSG_RESULT([ok])+  else+    AC_MSG_RESULT([failed])+    AC_MSG_WARN([cannot find a DTD for DocBook XML V4.2, you will not be able to validate your documentation])+    AC_MSG_WARN([check your XML_CATALOG_FILES environment variable and/or /etc/xml/catalog])+  fi+  rm -rf conftest*+fi+])# FP_CHECK_DOCBOOK_DTD+++# FP_GEN_FO+# ------------------+# Generates a formatting objects document in conftest.fo.+AC_DEFUN([FP_GEN_FO],+[rm -f conftest.fo+cat > conftest.fo << EOF+<?xml version="1.0"?>+<fo:root xmlns:fo="http://www.w3.org/1999/XSL/Format">+  <fo:layout-master-set>+    <fo:simple-page-master master-name="blank">+      <fo:region-body/>+    </fo:simple-page-master>+  </fo:layout-master-set>+  <fo:page-sequence master-reference="blank">+    <fo:flow flow-name="xsl-region-body">+      <fo:block>+        Test!+      </fo:block>+    </fo:flow>+  </fo:page-sequence>+</fo:root>+EOF+]) # FP_GEN_FO+++# FP_PROG_FOP+# -----------+# Set the output variable 'FopCmd' to the first working 'fop' in the current+# 'PATH'. Note that /usr/bin/fop is broken in SuSE 9.1 (unpatched), so try+# /usr/share/fop/fop.sh in that case (or no 'fop'), too.+AC_DEFUN([FP_PROG_FOP],+[AC_PATH_PROGS([FopCmd1], [fop])+if test -n "$FopCmd1"; then+  AC_CACHE_CHECK([for $FopCmd1 usability], [fp_cv_fop_usability],+    [FP_GEN_FO+    if "$FopCmd1" -fo conftest.fo -ps conftest.ps > /dev/null 2>&1; then+      fp_cv_fop_usability=yes+    else+      fp_cv_fop_usability=no+    fi+    rm -rf conftest*])+  if test x"$fp_cv_fop_usability" = xyes; then+     FopCmd=$FopCmd1+  fi+fi+if test -z "$FopCmd"; then+  AC_PATH_PROGS([FopCmd2], [fop.sh], , [/usr/share/fop])+  FopCmd=$FopCmd2+fi+AC_SUBST([FopCmd])+])# FP_PROG_FOP+++# FP_PROG_FO_PROCESSOR+# --------------------+# Try to find an FO processor. PassiveTeX output is sometimes a bit strange, so+# try FOP first. Sets the output variables FopCmd, XmltexCmd, DvipsCmd, and+# PdfxmltexCmd.+AC_DEFUN([FP_PROG_FO_PROCESSOR],+[AC_REQUIRE([FP_PROG_FOP])+AC_PATH_PROG([XmltexCmd], [xmltex])+AC_PATH_PROG([DvipsCmd], [dvips])+if test -z "$FopCmd"; then+  if test -z "$XmltexCmd"; then+    AC_MSG_WARN([cannot find an FO => DVI converter, you will not be able to build DVI or PostScript documentation])+  else+    if test -z "$DvipsCmd"; then+      AC_MSG_WARN([cannot find a DVI  => PS converter, you will not be able to build PostScript documentation])+    fi+  fi+  AC_PATH_PROG([PdfxmltexCmd], [pdfxmltex])+  if test -z "$PdfxmltexCmd"; then+    AC_MSG_WARN([cannot find an FO => PDF converter, you will not be able to build PDF documentation])+  fi+elif test -z "$XmltexCmd"; then+  AC_MSG_WARN([cannot find an FO => DVI converter, you will not be able to build DVI documentation])+fi+])# FP_PROG_FO_PROCESSOR
+ doc/config.mk.in view
@@ -0,0 +1,15 @@+#-----------------------------------------------------------------------------+# DocBook XML stuff++XSLTPROC		= @XsltprocCmd@+XMLLINT			= @XmllintCmd@+FOP			= @FopCmd@+XMLTEX			= @XmltexCmd@+PDFXMLTEX		= @PdfxmltexCmd@+DVIPS			= @DvipsCmd@++DIR_DOCBOOK_XSL		= @DIR_DOCBOOK_XSL@++XSLTPROC_LABEL_OPTS	= --stringparam toc.section.depth 3 \+			  --stringparam section.autolabel 1 \+			  --stringparam section.label.includes.component.label 1
+ doc/configure.ac view
@@ -0,0 +1,12 @@++AC_INIT([Haddock docs], [1.0], [simonmar@microsoft.com], [])++AC_CONFIG_SRCDIR([Makefile])++dnl ** check for DocBook toolchain+FP_CHECK_DOCBOOK_DTD+FP_DIR_DOCBOOK_XSL([/usr/share/xml/docbook/stylesheet/nwalsh/current /usr/share/xml/docbook/stylesheet/nwalsh /usr/share/sgml/docbook/docbook-xsl-stylesheets* /usr/share/sgml/docbook/xsl-stylesheets* /opt/kde?/share/apps/ksgmltools2/docbook/xsl /usr/share/docbook-xsl /usr/share/sgml/docbkxsl /usr/local/share/xsl/docbook /sw/share/xml/xsl/docbook-xsl])+FP_PROG_FO_PROCESSOR++AC_CONFIG_FILES([config.mk])+AC_OUTPUT
+ doc/docbook-xml.mk view
@@ -0,0 +1,130 @@+#-----------------------------------------------------------------------------+# DocBook XML++.PHONY: html html-no-chunks chm HxS fo dvi ps pdf++ifneq "$(XML_DOC)" ""++all :: html++# multi-file XML document: main document name is specified in $(XML_DOC),+# sub-documents (.xml files) listed in $(XML_SRCS).++ifeq "$(XML_SRCS)" ""+XML_SRCS = $(wildcard *.xml)+endif++XML_HTML           = $(addsuffix /index.html,$(basename $(XML_DOC)))+XML_HTML_NO_CHUNKS = $(addsuffix .html,$(XML_DOC))+XML_CHM            = $(addsuffix .chm,$(XML_DOC))+XML_HxS            = $(addsuffix .HxS,$(XML_DOC))+XML_FO             = $(addsuffix .fo,$(XML_DOC))+XML_DVI            = $(addsuffix .dvi,$(XML_DOC))+XML_PS             = $(addsuffix .ps,$(XML_DOC))+XML_PDF            = $(addsuffix .pdf,$(XML_DOC))++$(XML_HTML) $(XML_NO_CHUNKS_HTML) $(XML_FO) $(XML_DVI) $(XML_PS) $(XML_PDF) :: $(XML_SRCS)++html           :: $(XML_HTML)+html-no-chunks :: $(XML_HTML_NO_CHUNKS)+chm            :: $(XML_CHM)+HxS            :: $(XML_HxS)+fo             :: $(XML_FO)+dvi            :: $(XML_DVI)+ps             :: $(XML_PS)+pdf            :: $(XML_PDF)++CLEAN_FILES += $(XML_HTML_NO_CHUNKS) $(XML_FO) $(XML_DVI) $(XML_PS) $(XML_PDF)++FPTOOLS_CSS     = fptools.css++clean ::+	$(RM) -rf $(XML_DOC).out $(basename $(XML_DOC)) $(basename $(XML_DOC))-htmlhelp++validate ::+	$(XMLLINT) --valid --noout $(XMLLINT_OPTS) $(XML_DOC).xml+endif++#-----------------------------------------------------------------------------+# DocBook XML suffix rules+#++%.html : %.xml+	$(XSLTPROC) --output $@ \+		    --stringparam html.stylesheet $(FPTOOLS_CSS) \+		    $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \+		    $(DIR_DOCBOOK_XSL)/html/docbook.xsl $<++%/index.html : %.xml+	$(RM) -rf $(dir $@)+	$(XSLTPROC) --stringparam base.dir $(dir $@) \+		    --stringparam use.id.as.filename 1 \+		    --stringparam html.stylesheet $(FPTOOLS_CSS) \+		    $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \+		    $(DIR_DOCBOOK_XSL)/html/chunk.xsl $<+	cp $(FPTOOLS_CSS) $(dir $@)++# Note: Numeric labeling seems to be uncommon for HTML Help+%-htmlhelp/index.html : %.xml+	$(RM) -rf $(dir $@)+	$(XSLTPROC) --stringparam base.dir $(dir $@) \+		    --stringparam manifest.in.base.dir 1 \+		    --stringparam htmlhelp.chm "..\\"$(basename $<).chm \+		    $(XSLTPROC_OPTS) \+		    $(DIR_DOCBOOK_XSL)/htmlhelp/htmlhelp.xsl $<++%-htmlhelp2/collection.HxC : %.xml+	$(RM) -rf $(dir $@)+	$(XSLTPROC) --stringparam base.dir $(dir $@) \+		    --stringparam use.id.as.filename 1 \+		    --stringparam manifest.in.base.dir 1 \+		    $(XSLTPROC_OPTS) \+		    $(DIR_DOCBOOK_XSL)/htmlhelp2/htmlhelp2.xsl $<++# TODO: Detect hhc & Hxcomp via autoconf+#+# Two obstacles here:+#+# * The reason for the strange "if" below is that hhc returns 0 on error and 1+#   on success, the opposite of what shells and make expect.+#+# * There seems to be some trouble with DocBook indices, but the *.chm looks OK,+#   anyway, therefore we pacify make by "|| true". Ugly...+#+%.chm : %-htmlhelp/index.html+	( cd $(dir $<) && if hhc htmlhelp.hhp ; then false ; else true ; fi ) || true++%.HxS : %-htmlhelp2/collection.HxC+	( cd $(dir $<) && if Hxcomp -p collection.HxC -o ../$@ ; then false ; else true ; fi )++%.fo : %.xml+	$(XSLTPROC) --output $@ \+		    --stringparam draft.mode no \+		    $(XSLTPROC_LABEL_OPTS) $(XSLTPROC_OPTS) \+		    $(DIR_DOCBOOK_XSL)/fo/docbook.xsl $<++ifeq "$(FOP)" ""+ifneq "$(PDFXMLTEX)" ""+%.pdf : %.fo+	$(PDFXMLTEX) $<+	if grep "LaTeX Warning: Label(s) may have changed.Rerun to get cross-references right." $(basename $@).log > /dev/null ; then \+	  $(PDFXMLTEX) $< ; \+	  $(PDFXMLTEX) $< ; \+	fi+endif+else+%.ps : %.fo+	$(FOP) $(FOP_OPTS) -fo $< -ps $@++%.pdf : %.fo+	$(FOP) $(FOP_OPTS) -fo $< -pdf $@+endif++ifneq "$(XMLTEX)" ""+%.dvi : %.fo+	$(XMLTEX) $<+	if grep "LaTeX Warning: Label(s) may have changed.Rerun to get cross-references right." $(basename $@).log > /dev/null ; then \+	  $(XMLTEX) $< ; \+	  $(XMLTEX) $< ; \+	fi+endif
+ doc/fptools.css view
@@ -0,0 +1,36 @@+div {+  font-family: sans-serif;+  color: black;+  background: white+}++h1, h2, h3, h4, h5, h6, p.title { color: #005A9C }++h1 { font:            170% sans-serif }+h2 { font:            140% sans-serif }+h3 { font:            120% sans-serif }+h4 { font: bold       100% sans-serif }+h5 { font: italic     100% sans-serif }+h6 { font: small-caps 100% sans-serif }++pre {+  font-family: monospace;+  border-width: 1px;+  border-style: solid;+  padding: 0.3em+}++pre.screen         { color: #006400 }+pre.programlisting { color: maroon }++div.example {+  background-color: #fffcf5;+  margin: 1ex 0em;+  border: solid #412e25 1px;+  padding: 0ex 0.4em+}++a:link    { color:      #0000C8 }+a:hover   { background: #FFFFA8 }+a:active  { color:      #D00000 }+a:visited { color:      #680098 }
+ doc/haddock.xml view
@@ -0,0 +1,1648 @@+<?xml version="1.0" encoding="iso-8859-1"?>+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"+   "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd">++<book id="haddock">+  <bookinfo>+    <date>2004-08-02</date>+    <title>Haddock User Guide</title>+    <author>+      <firstname>Simon</firstname>+      <surname>Marlow</surname>+    </author>+    <address><email>simonmar@microsoft.com</email></address>+    <copyright>+      <year>2004</year>+      <holder>Simon Marlow</holder>+    </copyright>+    <abstract>+      <para>This document describes Haddock version 2.5.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 obsure 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, DocBook+  and Hoogle backends, and it is structured in such a way that adding new+	back-ends 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, 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>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 following people for useful feedback,+      discussion, patches, packaging, and moral support: Simon Peyton+      Jones, Mark Shields, Manuel Chakravarty, Ross Patterson, Brett+      Letner, Sven Panne, Hal Daume, George Russell, Oliver Braun,+      Ashley Yakeley, Malcolm Wallace, Krasimir Angelov, the members+      of <email>haskelldoc@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+    indentifiers 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>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>--optghc</option></primary></indexterm>+          <option>--optghc</option>=<replaceable>option</replaceable>+        </term>+	<listitem>+	  <para>Pass <replaceable>option</replaceable> to GHC.</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>-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>-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 auxiliary files in <replaceable>dir</replaceable>.</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>-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>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>haddock.css</filename></term>+	      <listitem>+		<para>The stylesheet used by the generated HTML.  Feel+		free to modify this to change the colors or+		layout, or even specify your own stylesheet using the+		<option>--css</option> option.</para>+	      </listitem>+	    </varlistentry>+	    <varlistentry>+	      <term><filename>haddock-util.js</filename></term>+	      <listitem>+		<para>A small piece of JavaScript for collapsing sections+		of the generated HTML.</para>+	      </listitem>+	    </varlistentry>+	    <varlistentry>+	      <term><filename><replaceable>module</replaceable>.html</filename></term>+	      <listitem>+		<para>An HTML page for each+		<replaceable>module</replaceable>.</para>+	      </listitem>+	    </varlistentry>+	    <varlistentry>+	      <term><filename>doc-index.html</filename></term>+	      <term><filename>doc-index-XX.html</filename></term>+	      <listitem>+		<para>The index, split into two+		(functions/constructors and types/classes, as per+		Haskell namespaces) and further split+		alphabetically.</para>+	      </listitem>+	    </varlistentry>+	  </variablelist>+	</listitem>+      </varlistentry>++      <varlistentry>+	<term>+          <indexterm><primary><option>-m</option></primary></indexterm>+          <option>-m</option>+        </term>+	<term>+          <indexterm><primary><option>--html-help</option></primary></indexterm>+          <option>--html-help</option>+        </term>+	<listitem>+	  <para>(In HTML mode only) Produce extra contents and index+	  files for given HTML Help system. Currently supported Help+	  systems are Microsoft HTML Help 1.3 and 2.0 and GNOME DevHelp.</para>++	  <para>Using the Microsoft HTML Help system provides two+	  advantages over plain HTML: the help viewer gives you a nice+	  hierarchical folding contents pane on the left, and the+	  documentation files are compressed and therefore much+	  smaller (roughly a factor of 10). The disadvantage is that+	  the help can't be viewed over the web.</para>++	  <para>In order to create a compiled Microsoft help file, you+	  also need the Microsoft HTML Help compiler, which is+	  available free from+	  <ulink url="http://www.microsoft.com/">http://www.microsoft.com/</ulink>+	  (search for <quote>HTML Help compiler</quote>).</para>++	  <para>Viewers</para>+	  <variablelist>+            <varlistentry>+              <term>Microsoft HTML Help Viewer</term>+              <listitem><para>Distributed with Microsoft Windows</para></listitem>+            </varlistentry>+            <varlistentry>+              <term><ulink url="http://xchm.sourceforge.net">xCHM</ulink></term>+              <listitem><para>a CHM viewer for UNIX (Linux, *BSD, Solaris), written by Razvan Cojocaru</para></listitem>+            </varlistentry>+            <varlistentry>+              <term><ulink url="http://www.jouledata.com/MacProducts.html">JouleData Solutions' CHM Viewer</ulink></term>+              <listitem><para>a comercial 100% native Cocoa .chm file viewer for the Mac OS X platform</para></listitem>+            </varlistentry>+            <varlistentry>+              <term><ulink url="http://gnochm.sourceforge.net">GnoCHM</ulink></term>+              <listitem><para>a CHM file viewer. It is designed to integrate nicely with Gnome.</para></listitem>+            </varlistentry>+	  </variablelist>++	  <para>The GNOME DevHelp also provides help viewer which looks like+	  MSHelp viewer but the documentation files aren't compressed.+	  The documentation can be viewed with any HTML browser but+	  DevHelp gives you a nice hierarchical folding contents and+	  keyword index panes on the left. The DevHelp expects to see+	  *.devhelp file in the folder where the documentation is placed.+	  The file contains all required information+	  to build the contents and index panes.+	  </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>+	<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.+	  </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>-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>Specify a stylesheet to use instead of the default one+	  that comes with Haddock.  It should specify certain classes:+	  see the default stylesheet for details.</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>-d</option></primary></indexterm>+          <option>-d</option>+        </term>+        <term>+          <indexterm><primary><option>--debug</option></primary></indexterm>+          <option>--debug</option>+        </term>+	<listitem>+	  <para>Produce extra debugging output.</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>--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>-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>--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 Index link on each page to+	  <replaceable>URL</replaceable>.  This option is intended for+	  use in conjuction with <option>--gen-index</option> for+	  generating a separate index covering multiple+	  libraries.</para>+	</listitem>+      </varlistentry>++      <varlistentry>+        <term>+          <indexterm><primary><option>--gen-index</option></primary></indexterm>+          <option>--gen-index</option>+        </term>+	<listitem>+	  <para>Generate an HTML 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 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 behaves 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+	    documetnation, 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 behaves as if module+	    <replaceable>module</replaceable> has the <literal>hide</literal>+	    atribute. (<xref linkend="module-attributes" />).</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>+    </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, or</para>+	</listitem>+	<listitem>+	  <para>A <literal>class</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>+      </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 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.  For example:</para>++<programlisting>+-- | This is the description for module "Foo"+module Foo where+...+</programlisting>+    </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>+      </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> atribute 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>+      </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>&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>+      </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>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 and Monospaced text</title>++	<para>Emphasis may be added by surrounding text with+	<literal>/.../</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>++      </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>+      </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.</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>+      </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.</para>+      </section>+    </section>+  </chapter>+  <index/>+</book>
+ examples/A.hs view
@@ -0,0 +1,2 @@+module A where+data A = A
+ examples/B.hs view
@@ -0,0 +1,2 @@+module B ( module A ) where+import A
+ examples/Bug1.hs view
@@ -0,0 +1,6 @@+module Bug1 where++-- | We should have different anchors for constructors and types\/classes.  This+-- hyperlink should point to the type constructor by default: 'T'.+data T = T+
+ examples/Bug2.hs view
@@ -0,0 +1,4 @@+module Bug2 ( x ) where+import B+x :: A+x = A
+ examples/Bug3.hs view
@@ -0,0 +1,6 @@+module Bug3 where++-- | /multi-line+-- emphasis/+foo :: Int+
+ examples/Bug4.hs view
@@ -0,0 +1,4 @@+module Bug4 where+-- | don't use apostrophe's in the wrong place's+foo :: Int+
+ examples/Bug6.hs view
@@ -0,0 +1,23 @@+-- | Exporting records.+module Bug6( A(A), B(B), b, C(C,c1,c2), D(D,d1), E(E) ) where++-- |+-- This record is exported without its field+data A = A { a :: Int }++-- |+-- .. with its field, but the field is named separately in the export list+-- (should still be visible as a field name)+data B = B { b :: Int }++-- |+-- .. with fields names as subordinate names in the export+data C = C { c1 :: Int, c2 :: Int }++-- |+-- .. with only some of the fields exported (we can't handle this one -+-- how do we render the declaration?)+data D = D { d1 :: Int, d2 :: Int }++-- | a newtype with a field+newtype E = E { e :: Int }
+ examples/Bug7.hs view
@@ -0,0 +1,12 @@+-- | This module caused a duplicate instance in the documentation for the Foo+-- type.+module Bug7  where++-- | The Foo datatype+data Foo = Foo++-- | The Bar class+class Bar x y++-- | Just one instance+instance Bar Foo Foo
+ examples/Bug8.hs view
@@ -0,0 +1,8 @@+infix -->+infix --->++data Typ = Type (String,[Typ])+         | TFree (String, [String])++x --> y = Type("fun",[s,t])+(--->) = flip $ foldr (-->)
+ examples/Bug9.hs view
@@ -0,0 +1,6 @@+-- Haddock 0.6 didn't parse this module, because the qualified+-- identifier C.safe was incorrectly lexed as 3 tokens.++module Check where+import qualified Foo as C+check = undefined { C.safe = 3 }
+ examples/Hash.hs view
@@ -0,0 +1,45 @@+{- |+  Implementation of fixed-size hash tables, with a type +  class for constructing hash values for structured types.+-}+module Hash (+  -- * The @HashTable@ type+  HashTable,++  -- ** Operations on @HashTable@s+  new, insert, lookup,++  -- * The @Hash@ class+  Hash(..),+ ) where++import Array++-- | A hash table with keys of type @key@ and values of type @val@.+-- The type @key@ should be an instance of 'Eq'.+data HashTable key val = HashTable Int (Array Int [(key,val)])++-- | Builds a new hash table with a given size+new :: (Eq key, Hash key) => Int -> IO (HashTable key val)++-- | Inserts a new element into the hash table+insert :: (Eq key, Hash key) => key -> val -> IO ()++-- | 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)++-- | A class of types which can be hashed.+class Hash a where+   -- | hashes the value of type @a@ into an 'Int'+   hash :: a -> Int++instance Hash Int where+   hash = id++instance Hash Float where+   hash = trunc++instance (Hash a, Hash b) => Hash (a,b) where+   hash (a,b) = hash a `xor` hash b+
+ examples/Hidden.hs view
@@ -0,0 +1,4 @@+-- #hide+module Hidden where+hidden :: Int -> Int+hidden a = a
+ examples/Makefile view
@@ -0,0 +1,11 @@+TOP = ..+include $(TOP)/mk/boilerplate.mk++all :: index.html++index.html : $(HS_SRCS) $(HADDOCK_INPLACE)+	$(HADDOCK_INPLACE) -h $(HS_SRCS)++CLEAN_FILES += index.html++include $(TOP)/mk/target.mk
+ examples/NoLayout.hs view
@@ -0,0 +1,4 @@+module NoLayout where {+  -- | the class 'C'+  g :: Int;+ }
+ examples/Test.hs view
@@ -0,0 +1,410 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Test+-- Copyright   :  (c) Simon Marlow 2002+-- License     :  BSD-style+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- This module illustrates & tests most of the features of Haddock.+-- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'.+--+-----------------------------------------------------------------------------++-- This is plain comment, ignored by Haddock.++module Test ( ++	-- Section headings are introduced with '-- *':+	-- * Type declarations++	-- Subsection headings are introduced with '-- **' and so on.+	-- ** Data types+	T(..), T2, T3(..), T4(..), T5(..), T6(..),+	N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..),++	-- ** Records+	R(..), R1(..),++	-- | test that we can export record selectors on their own:+	p, q, u,++	-- * Class declarations+	C(a,b), D(..), E, F(..),+	+	-- | Test that we can export a class method on its own:+	a,++	-- * Function types+	f, g,++	-- * Auxiliary stuff++	-- $aux1++	-- $aux2++	-- $aux3++	-- $aux4++	-- $aux5++	-- $aux6++	-- $aux7++	-- $aux8++	-- $aux9++	-- $aux10++	-- $aux11++	-- $aux12++	-- | This is some inline documentation in the export list+	--+	-- > a code block using bird-tracks+	-- > each line must begin with > (which isn't significant unless it+	-- > is at the beginning of the line).++	-- * A hidden module+	module Hidden,++	-- * A visible module+	module Visible,++	{-| nested-style doc comments -}++	-- * Existential \/ Universal types+	Ex(..),++	-- * Type signatures with argument docs+	k, l, m, o,++	-- * A section+	-- and without an intervening comma:+	-- ** A subsection ++{-|+ > a literal line++ $ a non /literal/ line $+-}++	f'+   ) where++import Hidden+import Visible+import Data.Maybe++bla = Nothing++-- | This comment applies to the /following/ declaration+-- and it continues until the next non-comment line+data T a b+ = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor+ | -- | This comment describes the 'B' constructor+   B (T a b, T Int Float) -- ^ ++-- | An abstract data declaration+data T2 a b = T2 a b++-- | A data declaration with no documentation annotations on the constructors+data T3 a b = A1 a | B1 b++-- A data declaration with no documentation annotations at all+data T4 a b = A2 a | B2 b++-- A data declaration documentation on the constructors only+data T5 a b+  = A3 a -- ^ documents 'A3'+  | B3 b -- ^ documents 'B3'++-- | Testing alternative comment styles+data T6+  -- | This is the doc for 'A4'+  = A4+  | B4+  | -- ^ This is the doc for 'B4'++    -- | This is the doc for 'C4'+    C4++-- | A newtype+newtype N1 a = N1 a++-- | A newtype with a fieldname+newtype N2 a b = N2 {n :: a b}++-- | A newtype with a fieldname, documentation on the field+newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field +		    }++-- | An abstract newtype - we show this one as data rather than newtype because+-- the difference isn\'t visible to the programmer for an abstract type.+newtype N4 a b = N4 a++newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor+		    }++newtype N6 a b = N6 {n6 :: a b+		    }+		 -- ^ docs on the constructor only++-- | docs on the newtype and the constructor+newtype N7 a b = N7 {n7 :: a b+		    }+		-- ^ The 'N7' constructor+		 ++class (D a) => C a  where+   -- |this is a description of the 'a' method+   a :: IO a+   b :: [a]+   -- ^ this is a description of the 'b' method+   c :: a -- c is hidden in the export list++-- ^ This comment applies to the /previous/ declaration (the 'C' class)++class D a where+   d :: T a b+   e :: (a,a)+-- ^ This is a class declaration with no separate docs for the methods++instance D Int where+  d = undefined+  e = undefined++-- instance with a qualified class name+instance Test.D Float where+  d = undefined+  e = undefined++class E a where+  ee :: a+-- ^ This is a class declaration with no methods (or no methods exported)++-- This is a class declaration with no documentation at all+class F a where+  ff :: a++-- | This is the documentation for the 'R' record, which has four fields,+-- 'p', 'q', 'r', and 's'.+data R = +  -- | This is the 'C1' record constructor, with the following fields:+  C1 { p :: Int -- ^ This comment applies to the 'p' field+     , q :: forall a . a->a  -- ^ This comment applies to the 'q' field+     , -- | This comment applies to both 'r' and 's'+       r,s :: Int+     }+  | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),+       u,v :: Int+     }+  -- ^ This is the 'C2' record constructor, also with some fields:++-- | Testing different record commenting styles+data R1 +  -- | This is the 'C3' record constructor+  = C3 { +	-- | The 's1' record selector+	  s1 :: Int+	-- | The 's2' record selector+	, s2 :: Int+	, s3 :: Int  -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here.+                     -- Since GHC doesn't allow that, I have removed it in this file. +	-- ^ The 's3' record selector+     }++-- These section headers are only used when there is no export list to+-- give the structure of the documentation:++-- * This is a section header (level 1)+-- ** This is a section header (level 2)+-- *** This is a section header (level 3)++{-|+In a comment string we can refer to identifiers in scope with+single quotes like this: 'T', and we can refer to modules by+using double quotes: "Foo".  We can add emphasis /like this/.++   * This is a bulleted list++   - This is the next item (different kind of bullet)++   (1) This is an ordered list+ +   2. This is the next item (different kind of bullet)++@+     This is a block of code, which can include other markup: 'R'+     formatting+               is+                 significant+@++> this is another block of code++We can also include URLs in documentation: <http://www.haskell.org/>.+-}++f :: C a => a -> Int++-- | we can export foreign declarations too+foreign import ccall g :: Int -> IO CInt++-- | this doc string has a parse error in it: \'+h :: Int+h = 42+++-- $aux1 This is some documentation that is attached to a name ($aux1)+-- rather than a source declaration.  The documentation may be+-- referred to in the export list using its name.+--+-- @ code block in named doc @++-- $aux2 This is some documentation that is attached to a name ($aux2)++-- $aux3+-- @ code block on its own in named doc @++-- $aux4+--+-- @ code block on its own in named doc (after newline) @++{- $aux5 a nested, named doc comment++   with a paragraph,++   @ and a code block @+-}++-- some tests for various arrangements of code blocks:++{- $aux6+>test+>test1++@ test2+  test3+@+-}++{- $aux7+@+test1+test2+@+-}++{- $aux8+>test3+>test4+-}++{- $aux9+@+test1+test2+@++>test3+>test4+-}++{- $aux10+>test3+>test4++@+test1+test2+@+-}++-- This one is currently wrong (Haddock 0.4).  The @...@ part is+-- interpreted as part of the bird-tracked code block.+{- $aux11+aux11:++>test3+>test4++@+test1+test2+@+-}++-- $aux12+-- > foo+-- +-- > bar+-- ++-- | A data-type using existential\/universal types+data Ex a +  = forall b . C b => Ex1 b+  | forall b . Ex2 b+  | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file +  | Ex4 (forall a . a -> a)++-- | This is a function with documentation for each argument+k :: T () () 	  -- ^ This argument has type 'T'+  -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int'+  -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@+  -> T5 () ()	  -- ^ This argument has a very long description that should+		  -- hopefully cause some wrapping to happen when it is finally+		  -- rendered by Haddock in the generated HTML page.+  -> IO ()	  -- ^ This is the result type++-- This function has arg docs but no docs for the function itself+l :: (Int, Int, Float) -- ^ takes a triple+  -> Int -- ^ returns an 'Int'++-- | This function has some arg docs +m :: R+  -> N1 ()	-- ^ one of the arguments+  -> IO Int	-- ^ and the return value++-- | This function has some arg docs but not a return value doc++-- can't use the original name ('n') with GHC+newn :: R		-- ^ one of the arguments, an 'R'+     -> N1 ()		-- ^ one of the arguments+     -> IO Int+newn = undefined +++-- | A foreign import with argument docs+foreign import ccall unsafe + o :: Float  -- ^ The input float+   -> IO Float  -- ^ The output float++-- | We should be able to escape this: \#\#\#++-- p :: Int +-- can't use the above original definition with GHC+newp :: Int  +newp = undefined++-- | a function with a prime can be referred to as 'f'' +-- but f' doesn't get link'd 'f\''+f' :: Int+++-- Add some definitions here so that this file can be compiled with GHC++data T1+f = undefined+f' = undefined+type CInt = Int  +k = undefined+l = undefined+m = undefined
+ examples/Visible.hs view
@@ -0,0 +1,3 @@+module Visible where+visible :: Int -> Int+visible a = a
+ examples/hide-bug/A.hs view
@@ -0,0 +1,2 @@+-- #hide+module A where { data T = MkT; f :: T; f = MkT }
+ examples/hide-bug/B.hs view
@@ -0,0 +1,5 @@+module B(Test, vis) where ++vis = id++data Test = Test
+ examples/hide-bug/C.hs view
@@ -0,0 +1,6 @@+module C(C.bla) where ++import D++bla :: Test+bla = undefined
+ examples/hide-bug/D.hs view
@@ -0,0 +1,7 @@+-- The link to the type T in the doc for this module should point to +-- B.T, not A.T.  Bug fixed in rev 1.59 of Main.hs.+module D(Test, hej) where ++import B++hej = vis
+ haddock-leksah.cabal view
@@ -0,0 +1,161 @@+name:                 haddock-leksah+version:              2.5.0+cabal-version:        >= 1.6+license:              BSD3+build-type:           Simple+license-file:         LICENSE+copyright:            (c) Simon Marlow, David Waern+author:               Simon Marlow, David Waern+maintainer:           David Waern <david.waern@gmail.com>+stability:            experimental+homepage:             http://www.haskell.org/haddock/+synopsis:             A documentation-generation tool for Haskell libraries+description:          Haddock is a documentation-generation tool for Haskell+                      libraries. This is a temporary package, which is an exact replic of+                      Haddock, with a more liberal exposure of modules, needed by Leksah.+category:             Development++extra-source-files:+  CHANGES+  README+  doc/Makefile+  doc/README+  doc/aclocal.m4+  doc/config.mk.in+  doc/configure.ac+  doc/docbook-xml.mk+  doc/fptools.css+  doc/haddock.xml+  examples/A.hs+  examples/B.hs+  examples/Bug1.hs+  examples/Bug2.hs+  examples/Bug3.hs+  examples/Bug4.hs+  examples/Bug6.hs+  examples/Bug7.hs+  examples/Bug8.hs+  examples/Bug9.hs+  examples/Hash.hs+  examples/Hidden.hs+  examples/Makefile+  examples/NoLayout.hs+  examples/Test.hs+  examples/Visible.hs+  examples/hide-bug/A.hs+  examples/hide-bug/B.hs+  examples/hide-bug/C.hs+  examples/hide-bug/D.hs+  haddock.spec+  haskell.vim+  src/haddock.sh++data-files:+  html/haddock-DEBUG.css+  html/haddock.css+  html/haddock-util.js+  html/haskell_icon.gif+  html/minus.gif+  html/plus.gif+  html/frames.html++flag in-ghc-tree+  description: Are we in a GHC tree?+  default: False+  manual: True++executable haddock+  build-depends:+    base >= 4.0.0.0 && < 4.3.0.0,+    haskell98,+    filepath,+    directory,+    pretty,+    containers,+    array,+    Cabal >= 1.5,+    ghc >= 6.10 && < 6.13 ++  if flag(in-ghc-tree)+    cpp-options: -DIN_GHC_TREE+    extensions: ForeignFunctionInterface+  else+    build-depends: ghc-paths++  main-is:              Main.hs+  hs-source-dirs:       src+  extensions:           CPP, PatternGuards, DeriveDataTypeable,+                        ScopedTypeVariables, MagicHash+  ghc-options:          -funbox-strict-fields -O2 -Wall++  other-modules:+    Haddock.Interface+    Haddock.Interface.Rename+    Haddock.Interface.Create+    Haddock.Interface.AttachInstances+    Haddock.Utils.FastMutInt2+    Haddock.Utils.BlockTable+    Haddock.Utils.Html+    Haddock.Utils+    Haddock.Backends.Html+    Haddock.Backends.HaddockDB+    Haddock.Backends.DevHelp+    Haddock.Backends.HH+    Haddock.Backends.HH2+    Haddock.Backends.Hoogle+    Haddock.ModuleTree+    Haddock.Types+    Haddock.Version+    Haddock.InterfaceFile+    Haddock.Options+    Haddock.GhcUtils++  -- Cabal doesn't define __GHC_PATCHLEVEL__+  if impl(ghc == 6.10.1)+    cpp-options: -D__GHC_PATCHLEVEL__=1+  if impl(ghc == 6.10.2)+    cpp-options: -D__GHC_PATCHLEVEL__=2+  if impl(ghc == 6.10.3)+    cpp-options: -D__GHC_PATCHLEVEL__=3+  if impl(ghc == 6.10.4)+    cpp-options: -D__GHC_PATCHLEVEL__=4++library+  hs-source-dirs:       src+  ghc-options:          -funbox-strict-fields -O2 -Wall+  extensions:           CPP, PatternGuards, DeriveDataTypeable,+                        ScopedTypeVariables, MagicHash+  exposed-modules:      Distribution.Haddock Haddock.Types Haddock.Interface+                        Haddock.Options+  other-modules:+    Haddock.Interface.Rename+    Haddock.Interface.Create+    Haddock.Interface.AttachInstances+    Haddock.Utils.FastMutInt2+    Haddock.Utils.BlockTable+    Haddock.Utils.Html+    Haddock.Utils+    Haddock.Backends.Html+    Haddock.Backends.HaddockDB+    Haddock.Backends.DevHelp+    Haddock.Backends.HH+    Haddock.Backends.HH2+    Haddock.Backends.Hoogle+    Haddock.ModuleTree+    Haddock.Version+    Haddock.InterfaceFile+    Haddock.GhcUtils++  -- Cabal doesn't define __GHC_PATCHLEVEL__+  if impl(ghc == 6.10.1)+    cpp-options: -D__GHC_PATCHLEVEL__=1+  if impl(ghc == 6.10.2)+    cpp-options: -D__GHC_PATCHLEVEL__=2+  if impl(ghc == 6.10.3)+    cpp-options: -D__GHC_PATCHLEVEL__=3+  if impl(ghc == 6.10.4)+    cpp-options: -D__GHC_PATCHLEVEL__=4++  if flag(in-ghc-tree)+    buildable: False+
+ haddock.spec view
@@ -0,0 +1,81 @@+# 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.5.0+%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 view
@@ -0,0 +1,68 @@+" 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/frames.html view
@@ -0,0 +1,27 @@+<html>
+<head>
+<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%";
+}
+--></script>
+<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>
+ html/haddock-DEBUG.css view
@@ -0,0 +1,173 @@+/* -------- Global things --------- */++BODY { +  background-color: #ffffff;+  color: #000000;+  font-family: sans-serif;+  } ++A:link    { color: #0000e0; text-decoration: none }+A:visited { color: #0000a0; text-decoration: none }+A:hover   { background-color: #e0e0ff; text-decoration: none }++TABLE.vanilla {+  width: 100%;+  border-width: 0px;+  background-color: #ffe0e0;+  /* I can't seem to specify cellspacing or cellpadding properly using CSS... */+}++TD {+  border-width: 0px;+}++TABLE.narrow {+  border-width: 0px;+}++/* --------- Documentation elements ---------- */++TD.children {+  padding-left: 25px;+  }++TD.synopsis {+  padding: 2px;+  background-color: #f0f0f0;+  font-family: monospace+ }++TD.decl { +  padding: 2px;+  background-color: #f0f0f0; +  font-family: monospace;+  white-space: nowrap;+  vertical-align: top;+  }++TD.recfield { padding-left: 20px }++TD.doc  { +  padding-top: 2px;+  padding-left: 10px;+  background-color: #e0ffe0;+  }++TD.ndoc  { +  padding: 2px;+  background-color: #e0ffe0;+  }++TD.rdoc  { +  padding: 2px;+  padding-left: 10px;+  background-color: #e0ffe0;+  width: 100%;+  }++TD.body  { +  padding-left: 10px+  }++/* ------- Section Headings ------- */++TD.section1 {+  padding-top: 15px;+  font-weight: bold;+  font-size: 150%+  }++TD.section2 {+  padding-top: 10px;+  font-weight: bold;+  font-size: 130%+  }++TD.section3 {+  padding-top: 5px;+  font-weight: bold;+  font-size: 110%+  }++TD.section4 {+  font-weight: bold;+  font-size: 100%+  }++/* -------------- The title bar at the top of the page */++TD.infohead {+  color: #ffffff;+  font-weight: bold;+  padding-right: 10px;+  text-align: left;+}++TD.infoval {+  color: #ffffff;+  padding-right: 10px;+  text-align: left;+}++TD.topbar {+  background-color: #000099;+  padding: 5px;+}++TD.title {+  color: #ffffff;+  padding-left: 10px;+  width: 100%+  }++TD.topbut {+  padding-left: 5px;+  padding-right: 5px;+  border-left-width: 1px;+  border-left-color: #ffffff;+  border-left-style: solid;+  white-space: nowrap;+  }++TD.topbut A:link {+  color: #ffffff+  }++TD.topbut A:visited {+  color: #ffff00+  }++TD.topbut A:hover {+  background-color: #6060ff;+  }++TD.topbut:hover {+  background-color: #6060ff+  }++TD.modulebar { +  background-color: #0077dd;+  padding: 5px;+  border-top-width: 1px;+  border-top-color: #ffffff;+  border-top-style: solid;+  }++/* --------- The page footer --------- */++TD.botbar {+  background-color: #000099;+  color: #ffffff;+  padding: 5px+  }+TD.botbar A:link {+  color: #ffffff;+  text-decoration: underline+  }+TD.botbar A:visited {+  color: #ffff00+  }+TD.botbar A:hover {+  background-color: #6060ff+  }+
+ html/haddock-util.js view
@@ -0,0 +1,139 @@+// Haddock JavaScript utilities+function toggle(button,id)+{+   var n = document.getElementById(id).style;+   if (n.display == "none")+   {+    button.src = "minus.gif";+    n.display = "block";+   }+   else+   {+    button.src = "plus.gif";+    n.display = "none";+   }+}+++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) {+      parent.window.synopsis.location = filename;+    }+}
+ html/haddock.css view
@@ -0,0 +1,297 @@+/* -------- Global things --------- */++BODY { +  background-color: #ffffff;+  color: #000000;+  font-family: sans-serif;+  padding: 0 0;+  } ++A:link    { color: #0000e0; text-decoration: none }+A:visited { color: #0000a0; text-decoration: none }+A:hover   { background-color: #e0e0ff; text-decoration: none }++TABLE.vanilla {+  width: 100%;+  border-width: 0px;+  /* I can't seem to specify cellspacing or cellpadding properly using CSS... */+}++TABLE.vanilla2 {+  border-width: 0px;+}++/* <TT> font is a little too small in MSIE */+TT  { font-size: 100%; }+PRE { font-size: 100%; }++LI P { margin: 0pt } ++TD {+  border-width: 0px;+}++TABLE.narrow {+  border-width: 0px;+}++TD.s8  {  height: 8px;  }+TD.s15 {  height: 15px; }++SPAN.keyword { text-decoration: underline; }++/* Resize the buttom image to match the text size */+IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em }++/* --------- Contents page ---------- */++DIV.node {+  padding-left: 3em;+}++DIV.cnode {+  padding-left: 1.75em;+}++SPAN.pkg {+  position: absolute;+  left: 50em;+}++/* --------- Documentation elements ---------- */++TD.children {+  padding-left: 25px;+  }++TD.synopsis {+  padding: 2px;+  background-color: #f0f0f0;+  font-family: monospace+ }++TD.decl { +  padding: 2px;+  background-color: #f0f0f0; +  font-family: monospace;+  vertical-align: top;+  }++TD.topdecl {+  padding: 2px;+  background-color: #f0f0f0;+  font-family: monospace;+  vertical-align: top;+}++TABLE.declbar {+  border-spacing: 0px;+ }++TD.declname {+  width: 100%;+ }++TD.declbut {+  padding-left: 5px;+  padding-right: 5px;+  border-left-width: 1px;+  border-left-color: #000099;+  border-left-style: solid;+  white-space: nowrap;+  font-size: small;+ }++/* +  arg is just like decl, except that wrapping is not allowed.  It is+  used for function and constructor arguments which have a text box+  to the right, where if wrapping is allowed the text box squashes up+  the declaration by wrapping it.+*/+TD.arg { +  padding: 2px;+  background-color: #f0f0f0; +  font-family: monospace;+  vertical-align: top;+  white-space: nowrap;+  }++TD.recfield { padding-left: 20px }++TD.doc  { +  padding-top: 2px;+  padding-left: 10px;+  }++TD.ndoc  { +  padding: 2px;+  }++TD.rdoc  { +  padding: 2px;+  padding-left: 10px;+  width: 100%;+  }++TD.body  { +  padding-left: 10px+  }++TD.pkg {+  width: 100%;+  padding-left: 10px+}++TABLE.indexsearch TR.indexrow {+  display: none;+}+TABLE.indexsearch TR.indexshow {+  display: table-row;+}++TD.indexentry {+  vertical-align: top;+  padding-right: 10px+  }++TD.indexannot {+  vertical-align: top;+  padding-left: 20px;+  white-space: nowrap+  }++TD.indexlinks {+  width: 100%+  }++/* ------- Section Headings ------- */++TD.section1 {+  padding-top: 15px;+  font-weight: bold;+  font-size: 150%+  }++TD.section2 {+  padding-top: 10px;+  font-weight: bold;+  font-size: 130%+  }++TD.section3 {+  padding-top: 5px;+  font-weight: bold;+  font-size: 110%+  }++TD.section4 {+  font-weight: bold;+  font-size: 100%+  }++/* -------------- The title bar at the top of the page */++TD.infohead {+  color: #ffffff;+  font-weight: bold;+  padding-right: 10px;+  text-align: left;+}++TD.infoval {+  color: #ffffff;+  padding-right: 10px;+  text-align: left;+}++TD.topbar {+  background-color: #000099;+  padding: 5px;+}++TD.title {+  color: #ffffff;+  padding-left: 10px;+  width: 100%+  }++TD.topbut {+  padding-left: 5px;+  padding-right: 5px;+  border-left-width: 1px;+  border-left-color: #ffffff;+  border-left-style: solid;+  white-space: nowrap;+  }++TD.topbut A:link {+  color: #ffffff+  }++TD.topbut A:visited {+  color: #ffff00+  }++TD.topbut A:hover {+  background-color: #6060ff;+  }++TD.topbut:hover {+  background-color: #6060ff+  }++TD.modulebar { +  background-color: #0077dd;+  padding: 5px;+  border-top-width: 1px;+  border-top-color: #ffffff;+  border-top-style: solid;+  }++/* --------- The page footer --------- */++TD.botbar {+  background-color: #000099;+  color: #ffffff;+  padding: 5px+  }+TD.botbar A:link {+  color: #ffffff;+  text-decoration: underline+  }+TD.botbar A:visited {+  color: #ffff00+  }+TD.botbar A:hover {+  background-color: #6060ff+  }++/* --------- Mini Synopsis for Frame View --------- */++.outer {+  margin: 0 0;+  padding: 0 0;+}++.mini-synopsis {+  padding: 0.25em 0.25em;+}++.mini-synopsis H1 { font-size: 130%; }+.mini-synopsis H2 { font-size: 110%; }+.mini-synopsis H3 { font-size: 100%; }+.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 {+  margin-top: 0.5em;+  margin-bottom: 0.25em;+  padding: 0 0;+}++.mini-synopsis H1 { border-bottom: 1px solid #ccc; }++.mini-topbar {+  font-size: 130%;+  background: #0077dd;+  padding: 0.25em;+}++
+ html/haskell_icon.gif view

binary file changed (absent → 911 bytes)

+ html/minus.gif view

binary file changed (absent → 56 bytes)

+ html/plus.gif view

binary file changed (absent → 59 bytes)

+ src/Distribution/Haddock.hs view
@@ -0,0 +1,23 @@+--+-- Haddock - A Haskell Documentation Tool+--+-- (c) Simon Marlow 2003+--+++module Distribution.Haddock (+  readInterfaceFile,+  nameCacheFromGhc,+  freshNameCache,+  NameCacheAccessor,+  InterfaceFile(..),+  LinkEnv,+  InstalledInterface(..),+  DocName(..),+  docNameOcc,+) where+++import Haddock.InterfaceFile+import Haddock.Types+
+ src/Haddock/Backends/DevHelp.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Backends.DevHelp+-- Copyright   :  (c) Simon Marlow 2003-2006,+--                    David Waern  2006+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Haddock.Backends.DevHelp (ppDevHelpFile) where++import Haddock.ModuleTree+import Haddock.Types hiding (Doc)+import Haddock.Utils++import Module+import Name          ( Name, nameModule, getOccString, nameOccName )+#if __GLASGOW_HASKELL__ < 609+import PackageConfig (stringToPackageId)+#endif++import Data.Maybe    ( fromMaybe )+import qualified Data.Map as Map+import Text.PrettyPrint++ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO ()+ppDevHelpFile odir doctitle maybe_package ifaces = do+  let devHelpFile = package++".devhelp"+      tree = mkModuleTree True [ (ifaceMod iface, toDescription iface) | iface <- ifaces ]+      doc =+        text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$+        (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>+            text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$+        text "<chapters>" $$+        nest 4 (ppModuleTree [] tree) $+$+        text "</chapters>" $$+        text "<functions>" $$+        nest 4 (ppList index) $+$+        text "</functions>" $$+        text "</book>"+  writeFile (pathJoin [odir, devHelpFile]) (render doc)+  where    +    package = fromMaybe "pkg" maybe_package++    ppModuleTree :: [String] -> [ModuleTree] -> Doc+    ppModuleTree ss [x]    = ppNode ss x+    ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs+    ppModuleTree _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"++    ppNode :: [String] -> ModuleTree -> Doc+    ppNode ss (Node s leaf _ _short ts) =+        case ts of+          [] -> text "<sub"<+>ppAttribs<>text "/>"+          _  -> +            text "<sub"<+>ppAttribs<>text ">" $$+            nest 4 (ppModuleTree (s:ss) ts) $+$+            text "</sub>"+        where+          ppLink | leaf      = text (moduleHtmlFile (mkModule (stringToPackageId "") +                                                              (mkModuleName mdl)))+                 | otherwise = empty++          ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink++          mdl = foldr (++) "" (s' : map ('.':) ss')+          (s':ss') = reverse (s:ss)+		-- reconstruct the module name++    index :: [(Name, [Module])]+    index = Map.toAscList (foldr getModuleIndex Map.empty ifaces)++    getModuleIndex iface fm =+	Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | name <- ifaceExports iface, nameModule name == mdl]) fm+	where mdl = ifaceMod iface++    ppList :: [(Name, [Module])] -> Doc+    ppList [] = empty+    ppList ((name,refs):mdls)  =+      ppReference name refs $$+      ppList mdls++    ppReference :: Name -> [Module] -> Doc+    ppReference _ [] = empty+    ppReference name (mdl:refs) =  +      text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$+      ppReference name refs
+ src/Haddock/Backends/HH.hs view
@@ -0,0 +1,186 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Backends.HH+-- Copyright   :  (c) Simon Marlow 2003+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Haddock.Backends.HH (ppHHContents, ppHHIndex, ppHHProject) where++ppHHContents, ppHHIndex, ppHHProject :: a+ppHHContents = error "not yet"+ppHHIndex = error "not yet"+ppHHProject = error "not yet"++{-+import HaddockModuleTree+import HaddockTypes+import HaddockUtil+import HsSyn2 hiding(Doc)+import qualified Map++import Data.Char ( toUpper )+import Data.Maybe ( fromMaybe )+import Text.PrettyPrint++ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()+ppHHContents odir doctitle maybe_package tree = do+  let contentsHHFile = package++".hhc"++      html =+      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$+	text "<HTML>" $$+	text "<HEAD>" $$+	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$+	text "<!-- Sitemap 1.0 -->" $$+	text "</HEAD><BODY>" $$+	ppModuleTree tree $$+	text "</BODY><HTML>"+  writeFile (pathJoin [odir, contentsHHFile]) (render html)+  where+	package = fromMaybe "pkg" maybe_package+	+	ppModuleTree :: [ModuleTree] -> Doc+	ppModuleTree ts =+		text "<OBJECT type=\"text/site properties\">" $$+		text "<PARAM name=\"FrameName\" value=\"main\">" $$+		text "</OBJECT>" $$+		text "<UL>" $+$+		nest 4 (text "<LI>" <> nest 4+		                (text "<OBJECT type=\"text/sitemap\">" $$+		                 nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$+		                         text "<PARAM name=\"Local\" value=\"index.html\">") $$+		                 text "</OBJECT>") $+$+		        text "</LI>" $$+		        text "<UL>" $+$+		        nest 4 (fn [] ts) $+$+		        text "</UL>") $+$+		text "</UL>"++	fn :: [String] -> [ModuleTree] -> Doc+	fn ss [x]    = ppNode ss x+	fn ss (x:xs) = ppNode ss x $$ fn ss xs+        fn _  []     = error "HaddockHH.ppHHContents.fn: no module trees given"++	ppNode :: [String] -> ModuleTree -> Doc+	ppNode ss (Node s leaf _pkg _ []) =+	  ppLeaf s ss leaf+	ppNode ss (Node s leaf _pkg _ ts) =+	  ppLeaf s ss leaf $$+	  text "<UL>" $+$+	  nest 4 (fn (s:ss) ts) $+$+	  text "</UL>"++	ppLeaf s ss isleaf  =+		text "<LI>" <> nest 4+			(text "<OBJECT type=\"text/sitemap\">" $$+			 text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$+			 (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile mdl) <> text "\">" else empty) $$+			 text "</OBJECT>") $+$+		text "</LI>"+		where +			mdl = foldr (++) "" (s' : map ('.':) ss')+			(s':ss') = reverse (s:ss)+			-- reconstruct the module name+		+-------------------------------+ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO ()+ppHHIndex odir maybe_package ifaces = do+  let indexHHFile = package++".hhk"+  +      html = +      	text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$+	text "<HTML>" $$+	text "<HEAD>" $$+	text "<META name=\"GENERATOR\" content=\"Haddock\">" $$+	text "<!-- Sitemap 1.0 -->" $$+	text "</HEAD><BODY>" $$+	text "<UL>" $+$+	nest 4 (ppList index) $+$+	text "</UL>" $$+	text "</BODY><HTML>"+  writeFile (pathJoin [odir, indexHHFile]) (render html)+  where+	package = fromMaybe "pkg" maybe_package+  	+	index :: [(HsName, [Module])]+	index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)++	getIfaceIndex iface fm =+		foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']+		where mdl = iface_module iface+	+	ppList [] = empty+	ppList ((name,refs):mdls)  =+		text "<LI>" <> nest 4+				(text "<OBJECT type=\"text/sitemap\">" $$+				 text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$+				 ppReference name refs $$+				 text "</OBJECT>") $+$+		text "</LI>" $$+		ppList mdls++	ppReference name [] = empty+	ppReference name (Module mdl:refs) =+		text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$+		ppReference name refs+++ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO ()+ppHHProject odir doctitle maybe_package ifaces pkg_paths = do+  let projectHHFile = package++".hhp"+      doc =+        text "[OPTIONS]" $$+        text "Compatibility=1.1 or later" $$+        text "Compiled file=" <> text package <> text ".chm" $$+        text "Contents file=" <> text package <> text ".hhc" $$+        text "Default topic=" <> text contentsHtmlFile $$+        text "Display compile progress=No" $$+        text "Index file=" <> text package <> text ".hhk" $$+        text "Title=" <> text doctitle $$+	space $$+        text "[FILES]" $$+        ppMods ifaces $$+        text contentsHtmlFile $$+        text indexHtmlFile $$+        ppIndexFiles chars $$+        ppLibFiles ("":pkg_paths)+  writeFile (pathJoin [odir, projectHHFile]) (render doc)+  where+    package = fromMaybe "pkg" maybe_package+	+    ppMods [] = empty+    ppMods (iface:ifaces) =+	let Module mdl = iface_module iface in+        text (moduleHtmlFile mdl) $$+        ppMods ifaces+		+    ppIndexFiles []     = empty+    ppIndexFiles (c:cs) =+        text (subIndexHtmlFile c) $$+        ppIndexFiles cs+        +    ppLibFiles []           = empty+    ppLibFiles (path:paths) =+        ppLibFile cssFile   $$+    	ppLibFile iconFile  $$+    	ppLibFile jsFile    $$+    	ppLibFile plusFile  $$+        ppLibFile minusFile $$+        ppLibFiles paths+        where+            toPath fname | null path = fname+	                 | otherwise = pathJoin [path, fname]+            ppLibFile fname = text (toPath fname)++    chars :: [Char]+    chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))++    getIfaceIndex iface fm =+        Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm+	where mdl = iface_module iface+-}
+ src/Haddock/Backends/HH2.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Backends.HH2+-- Copyright   :  (c) Simon Marlow 2003+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Haddock.Backends.HH2 (ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where++import Haddock.Types++ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()+ppHH2Files = error "not yet"++ppHH2Contents, ppHH2Index, ppHH2Collection :: a+ppHH2Contents = error "not yet"+ppHH2Index = error "not yet"+ppHH2Collection = error "not yet"++{-+import HaddockModuleTree+import HaddockUtil+import HsSyn2 hiding(Doc)+import qualified Map++import Data.Char ( toUpper )+import Data.Maybe ( fromMaybe )+import Text.PrettyPrint++ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO ()+ppHH2Contents odir doctitle maybe_package tree = do+  let 	+	contentsHH2File = package++".HxT"++	doc  =+		text "<?xml version=\"1.0\"?>" $$+		text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$+		text "<HelpTOC DTDVersion=\"1.0\">" $$+		nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$+		        nest 4 (ppModuleTree [] tree) $+$+		        text "</HelpTOCNode>") $$+		text "</HelpTOC>"+  writeFile (pathJoin [odir, contentsHH2File]) (render doc)+  where+	package = fromMaybe "pkg" maybe_package+	+	ppModuleTree :: [String] -> [ModuleTree] -> Doc+	ppModuleTree ss [x]    = ppNode ss x+	ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs+	ppModuleTree _  []     = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given"++	ppNode :: [String] -> ModuleTree -> Doc+	ppNode ss (Node s leaf _pkg _short []) =+	  text "<HelpTOCNode"  <+> ppAttributes leaf (s:ss) <> text "/>"+	ppNode ss (Node s leaf _pkg _short ts) =+	  text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text ">" $$+	  nest 4 (ppModuleTree (s:ss) ts) $+$+	  text "</HelpTOCNode>"+			+	ppAttributes :: Bool -> [String] -> Doc+	ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl]+	  where+	    mdl = foldr (++) "" (s' : map ('.':) ss')+	    (s':ss') = reverse ss+	                -- reconstruct the module name+	    +	    ppId = text "Id=" <> doubleQuotes (text mdl)+	    +	    ppTitle = text "Title=" <> doubleQuotes (text (head ss))+	    +	    ppUrl | isleaf    = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl))+	          | otherwise = empty++-----------------------------------------------------------------------------------++ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO ()+ppHH2Index odir maybe_package ifaces = do+  let +	indexKHH2File     = package++"K.HxK"+	indexNHH2File     = package++"N.HxK"+	docK = +		text "<?xml version=\"1.0\"?>" $$+		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$+		text "<HelpIndex DTDVersion=\"1.0\" Name=\"K\">" $$+		nest 4 (ppList index) $+$+		text "</HelpIndex>"  +	docN = +		text "<?xml version=\"1.0\"?>" $$+		text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$+		text "<HelpIndex DTDVersion=\"1.0\" Name=\"NamedURLIndex\">" $$+		text "<Keyword Term=\"HomePage\">" $$+		nest 4 (text "<Jump Url=\""<>text contentsHtmlFile<>text "\"/>") $$+		text "</Keyword>" $$+		text "</HelpIndex>"+  writeFile (pathJoin [odir, indexKHH2File]) (render docK)+  writeFile (pathJoin [odir, indexNHH2File]) (render docN)+  where+	package = fromMaybe "pkg" maybe_package+    +	index :: [(HsName, [Module])]+	index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)++	getIfaceIndex iface fm =+	    Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm+	    where mdl = iface_module iface+	+	ppList [] = empty+	ppList ((name,mdls):vs)  =+		text "<Keyword Term=\"" <> text (escapeStr (show name)) <> text "\">" $$+		nest 4 (vcat (map (ppJump name) mdls)) $$+		text "</Keyword>" $$+		ppList vs++	ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"+++-----------------------------------------------------------------------------------++ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()+ppHH2Files odir maybe_package ifaces pkg_paths = do+  let filesHH2File = package++".HxF"+      doc =+        text "<?xml version=\"1.0\"?>" $$+        text "<!DOCTYPE HelpFileList SYSTEM \"ms-help://hx/resources/HelpFileList.DTD\">" $$+        text "<HelpFileList DTDVersion=\"1.0\">" $$+        nest 4 (ppMods ifaces $$+                text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$+                text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$+                ppIndexFiles chars $$+                ppLibFiles ("":pkg_paths)) $$+        text "</HelpFileList>"+  writeFile (pathJoin [odir, filesHH2File]) (render doc)+  where+    package = fromMaybe "pkg" maybe_package+	+    ppMods [] = empty+    ppMods (iface:ifaces) =+		text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$+		ppMods ifaces+		where Module mdl = iface_module iface+		+    ppIndexFiles []     = empty+    ppIndexFiles (c:cs) =+        text "<File Url=\""<>text (subIndexHtmlFile c)<>text "\"/>" $$+        ppIndexFiles cs+        +    ppLibFiles []           = empty+    ppLibFiles (path:paths) =        +        ppLibFile cssFile   $$+	ppLibFile iconFile  $$+	ppLibFile jsFile    $$+	ppLibFile plusFile  $$+        ppLibFile minusFile $$+        ppLibFiles paths+        where+            toPath fname | null path = fname+                         | otherwise = pathJoin [path, fname]+            ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>"++    chars :: [Char]+    chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))++    getIfaceIndex iface fm =+        Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm+	where mdl = iface_module iface++-----------------------------------------------------------------------------------++ppHH2Collection :: FilePath -> String -> Maybe String -> IO ()+ppHH2Collection odir doctitle maybe_package = do+  let +	package = fromMaybe "pkg" maybe_package+	collectionHH2File = package++".HxC"+	+	doc =+		text "<?xml version=\"1.0\"?>" $$+		text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$+		text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$+		nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$+		        nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$+		        text "</CompilerOptions>" $$+		        text "<TOCDef File=\"" <> text package <> text ".HxT\"/>" $$+		        text "<KeywordIndexDef File=\"" <> text package <> text "K.HxK\"/>" $$+		        text "<KeywordIndexDef File=\"" <> text package <> text "N.HxK\"/>" $$+		        text "<ItemMoniker Name=\"!DefaultToc\" ProgId=\"HxDs.HxHierarchy\" InitData=\"\"/>" $$+		        text "<ItemMoniker Name=\"!DefaultFullTextSearch\" ProgId=\"HxDs.HxFullTextSearch\" InitData=\"\"/>" $$+		        text "<ItemMoniker Name=\"!DefaultAssociativeIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"A\"/>" $$+		        text "<ItemMoniker Name=\"!DefaultKeywordIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"K\"/>" $$+		        text "<ItemMoniker Name=\"!DefaultNamedUrlIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"NamedURLIndex\"/>" $$+		        text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$+		text "</HelpCollection>"+  writeFile (pathJoin [odir, collectionHH2File]) (render doc)+-}
+ src/Haddock/Backends/HaddockDB.hs view
@@ -0,0 +1,171 @@+-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,311 @@+-----------------------------------------------------------------------------+-- |+-- 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 Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import System.FilePath+++prefix :: [String]+prefix = ["-- Hoogle documentation, generated by Haddock"+         ,"-- See Hoogle, http://www.haskell.org/hoogle/"+         ,""]+++ppHoogle :: String -> String -> String -> Maybe (HsDoc RdrName) -> [Interface] -> FilePath -> IO ()+ppHoogle package version synopsis prologue ifaces odir = do+    let filename = package ++ ".txt"+        contents = prefix +++                   docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue +++                   ["@package " ++ package] +++                   ["@version " ++ version | version /= ""] +++                   concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]+    writeFile (odir </> filename) (unlines contents)+++ppModule :: Interface -> [String]+ppModule iface = "" : doc (ifaceDoc iface) +++                 ["module " ++ moduleString (ifaceMod iface)] +++                 concatMap ppExport (ifaceExportItems iface) +++                 concatMap ppInstance (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 => HsType a -> String+outHsType = out . 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 => a -> String+out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . 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 :: ExportItem Name -> [String]+ppExport (ExportDecl decl dc _ _) = doc dc ++ f (unL decl)+    where+        f (TyClD d@TyData{}) = ppData d+        f (TyClD d@ClassDecl{}) = ppClass d+        f (TyClD d@TySynonym{}) = ppSynonym d+        f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ+        f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig name typ+        f (SigD sig) = ppSig sig+        f _ = []+ppExport _ = []+++ppSig :: Sig Name -> [String]+ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ outHsType typ]+    where+        typ = case unL sig of+                   HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c+                   x -> x+ppSig _ = []+++ppSynonym :: TyClDecl Name -> [String]+ppSynonym x = [out x]+++-- note: does not yet output documentation for class methods+ppClass :: TyClDecl Name -> [String]+ppClass x = out x{tcdSigs=[]} :+            concatMap (ppSig . addContext . unL) (tcdSigs x)+    where+        addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)+        addContext _ = error "expected TypeSig"++        f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d+        f t = HsForAllTy Implicit [] (reL [context]) (reL t)++        context = reL $ HsClassP (unL $ tcdLName x)+            (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x))++        tyVar (UserTyVar v) = v+        tyVar (KindedTyVar v _) = v+++ppInstance :: Instance -> [String]+ppInstance x = [dropComment $ out x]+++ppData :: TyClDecl Name -> [String]+ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :+           concatMap (ppCtor x . unL) (tcdCons x)+    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 d+                nam = out $ tcdLName d+                f w = if w == nam then operator nam else w+++ppCtor :: TyClDecl Name -> ConDecl Name -> [String]+ppCtor dat con = ldoc (con_doc 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+                          [ldoc (cd_fld_doc r) +++                           [out (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 (makeExplicit $ unL $ funs flds)+        name = out $ unL $ con_name con++        resType = case con_res con of+            ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [x | UserTyVar x <- map unL $ tcdTyVars dat]+            ResTyGADT x -> x+++---------------------------------------------------------------------+-- DOCUMENTATION++ldoc :: Outputable o => Maybe (LHsDoc o) -> [String]+ldoc = doc . liftM unL++doc :: Outputable o => Maybe (HsDoc o) -> [String]+doc = docWith ""+++docWith :: Outputable o => String -> Maybe (HsDoc o) -> [String]+docWith [] Nothing = []+docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "--   ") $+    [header | header /= ""] ++ ["" | header /= "" && isJust d] +++    maybe [] (showTags . markup markupTag) 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 => DocMarkup o [Tag]+markupTag = Markup {+  markupParagraph     = box TagP,+  markupEmpty         = str "",+  markupString        = str,+  markupAppend        = (++),+  markupIdentifier    = box (TagInline "a") . str . out . head,+  markupModule        = box (TagInline "a") . str,+  markupEmphasis      = box (TagInline "i"),+  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,+  markupURL           = box (TagInline "a") . str,+  markupAName         = const $ str ""+  }+++showTags :: [Tag] -> [String]+showTags = concat . intersperse [""] . map showBlock+    where+++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/Html.hs view
@@ -0,0 +1,1980 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Backends.Html+-- Copyright   :  (c) Simon Marlow 2003-2006,+--                    David Waern  2006-2009+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Haddock.Backends.Html ( +  ppHtml, copyHtmlBits, +  ppHtmlIndex, ppHtmlContents,+  ppHtmlHelpFiles+) where+++import Prelude hiding (div)++import Haddock.Backends.DevHelp+import Haddock.Backends.HH+import Haddock.Backends.HH2+import Haddock.ModuleTree+import Haddock.Types hiding ( Doc )+import Haddock.Version+import Haddock.Utils+import Haddock.Utils.Html hiding ( name, title, p )+import qualified Haddock.Utils.Html as Html+import Haddock.GhcUtils++import Control.Exception     ( bracket )+import Control.Monad         ( when, unless, join )+import Data.Char             ( toUpper )+import Data.List             ( sortBy, groupBy )+import Data.Maybe+import Foreign.Marshal.Alloc ( allocaBytes )+import System.IO             ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )+import System.Directory hiding ( copyFile )+import Data.Map              ( Map )+import qualified Data.Map as Map hiding ( Map )+import Data.Function+import Data.Ord              ( comparing )++#if __GLASGOW_HASKELL__ >= 609+import GHC hiding ( NoLink, moduleInfo )+#else+import GHC hiding ( NoLink )+#endif+import Name+import Module+import RdrName hiding ( Qual, is_explicit )+import FastString            ( unpackFS )+import BasicTypes            ( IPName(..), Boxity(..) )+import Outputable            ( ppr, showSDoc, Outputable )++-- the base, module and entity URLs for the source code and wiki links.+type SourceURLs = (Maybe String, Maybe String, Maybe String)+type WikiURLs = (Maybe String, Maybe String, Maybe String)+++-- convenient short-hands+type Doc = HsDoc DocName+++-- -----------------------------------------------------------------------------+-- Generating HTML documentation++ppHtml	:: String+	-> Maybe String				-- package+	-> [Interface]+	-> FilePath			-- destination directory+	-> Maybe (GHC.HsDoc GHC.RdrName)    -- prologue text, maybe+	-> Maybe String		        -- the Html Help format (--html-help)+	-> 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)+	-> IO ()++ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format+	maybe_source_url maybe_wiki_url+	maybe_contents_url maybe_index_url unicode =  do+  let+	visible_ifaces = filter visible ifaces+	visible i = OptHide `notElem` ifaceOptions i+  when (not (isJust maybe_contents_url)) $ +    ppHtmlContents odir doctitle maybe_package+        maybe_html_help_format 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++  when (not (isJust maybe_index_url)) $ +    ppHtmlIndex odir doctitle maybe_package maybe_html_help_format+      maybe_contents_url maybe_source_url maybe_wiki_url +      (map toInstalledIface visible_ifaces)+    +  when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ +	ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format []++  mapM_ (ppHtmlModule odir doctitle+	   maybe_source_url maybe_wiki_url+	   maybe_contents_url maybe_index_url unicode) visible_ifaces++ppHtmlHelpFiles	+    :: String                   -- doctitle+    -> Maybe String				-- package+	-> [Interface]+	-> FilePath                 -- destination directory+	-> Maybe String             -- the Html Help format (--html-help)+	-> [FilePath]               -- external packages paths+	-> IO ()+ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths =  do+  let+	visible_ifaces = filter visible ifaces+	visible i = OptHide `notElem` ifaceOptions i++  -- Generate index and contents page for Html Help if requested+  case maybe_html_help_format of+    Nothing        -> return ()+    Just "mshelp"  -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths+    Just "mshelp2" -> do+		ppHH2Files      odir maybe_package visible_ifaces pkg_paths+		ppHH2Collection odir doctitle maybe_package+    Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces+    Just format    -> fail ("The "++format++" format is not implemented")++copyFile :: FilePath -> FilePath -> IO ()+copyFile fromFPath toFPath =+	(bracket (openFile fromFPath ReadMode) hClose $ \hFrom ->+	 bracket (openFile toFPath WriteMode) hClose $ \hTo ->+	 allocaBytes bufferSize $ \buffer ->+		copyContents hFrom hTo buffer)+	where+		bufferSize = 1024+		+		copyContents hFrom hTo buffer = do+			count <- hGetBuf hFrom buffer bufferSize+			when (count > 0) $ do+				hPutBuf hTo buffer count+				copyContents hFrom hTo buffer+++copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO ()+copyHtmlBits odir libdir maybe_css = do+  let +	libhtmldir = pathJoin [libdir, "html"]+	css_file = case maybe_css of+			Nothing -> pathJoin [libhtmldir, cssFile]+			Just f  -> f+	css_destination = pathJoin [odir, cssFile]+	copyLibFile f = do+	   copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f])+  copyFile css_file css_destination+  mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ]++footer :: HtmlTable+footer = +  tda [theclass "botbar"] << +	( toHtml "Produced by" <+> +	  (anchor ! [href projectUrl] << toHtml projectName) <+>+	  toHtml ("version " ++ projectVersion)+	)+   +srcButton :: SourceURLs -> Maybe Interface -> HtmlTable+srcButton (Just src_base_url, _, _) Nothing =+  topButBox (anchor ! [href src_base_url] << toHtml "Source code")++srcButton (_, Just src_module_url, _) (Just iface) =+  let url = spliceURL (Just $ ifaceOrigFilename iface)+                      (Just $ ifaceMod iface) Nothing Nothing src_module_url+   in topButBox (anchor ! [href url] << toHtml "Source code")++srcButton _ _ =+  Html.emptyTable+ +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> +             Maybe SrcSpan -> String -> String+spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url+ 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_ -> show $ srcSpanStartLine span_++  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+  +wikiButton :: WikiURLs -> Maybe Module -> HtmlTable+wikiButton (Just wiki_base_url, _, _) Nothing =+  topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments")++wikiButton (_, Just wiki_module_url, _) (Just mdl) =+  let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url+   in topButBox (anchor ! [href url] << toHtml "User Comments")++wikiButton _ _ =+  Html.emptyTable++contentsButton :: Maybe String -> HtmlTable+contentsButton maybe_contents_url +  = topButBox (anchor ! [href url] << toHtml "Contents")+  where url = maybe contentsHtmlFile id maybe_contents_url++indexButton :: Maybe String -> HtmlTable+indexButton maybe_index_url +  = topButBox (anchor ! [href url] << toHtml "Index")+  where url = maybe indexHtmlFile id maybe_index_url++simpleHeader :: String -> Maybe String -> Maybe String+             -> SourceURLs -> WikiURLs -> HtmlTable+simpleHeader doctitle maybe_contents_url maybe_index_url+  maybe_source_url maybe_wiki_url = +  (tda [theclass "topbar"] << +     vanillaTable << (+       (td << +  	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]+       ) <->+       (tda [theclass "title"] << toHtml doctitle) <->+	srcButton maybe_source_url Nothing <->+        wikiButton maybe_wiki_url Nothing <->+	contentsButton maybe_contents_url <-> indexButton maybe_index_url+   ))++pageHeader :: String -> Interface -> String+    -> SourceURLs -> WikiURLs+    -> Maybe String -> Maybe String -> HtmlTable+pageHeader mdl iface doctitle+           maybe_source_url maybe_wiki_url+           maybe_contents_url maybe_index_url =+  (tda [theclass "topbar"] << +    vanillaTable << (+       (td << +  	image ! [src "haskell_icon.gif", width "16", height 16, alt " "]+       ) <->+       (tda [theclass "title"] << toHtml doctitle) <->+	srcButton maybe_source_url (Just iface) <->+	wikiButton maybe_wiki_url (Just $ ifaceMod iface) <->+	contentsButton maybe_contents_url <->+	indexButton maybe_index_url+    )+   ) </>+   tda [theclass "modulebar"] <<+	(vanillaTable << (+	  (td << font ! [size "6"] << toHtml mdl) <->+	  moduleInfo iface+	)+    )++moduleInfo :: Interface -> HtmlTable+moduleInfo iface = +   let+      info = ifaceInfo iface++      doOneEntry :: (String, (GHC.HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable+      doOneEntry (fieldName,field) = case field info of+         Nothing -> Nothing+         Just fieldValue -> +            Just ((tda [theclass "infohead"] << toHtml fieldName)+               <-> (tda [theclass "infoval"]) << toHtml fieldValue)+     +      entries :: [HtmlTable]+      entries = mapMaybe doOneEntry [+         ("Portability",GHC.hmi_portability),+         ("Stability",GHC.hmi_stability),+         ("Maintainer",GHC.hmi_maintainer)+         ]+   in+      case entries of+         [] -> Html.emptyTable+         _ -> tda [align "right"] << narrowTable << (foldl1 (</>) entries)++-- ---------------------------------------------------------------------------+-- Generate the module contents++ppHtmlContents+   :: FilePath+   -> String+   -> Maybe String+   -> Maybe String+   -> Maybe String+   -> SourceURLs+   -> WikiURLs+   -> [InstalledInterface] -> Bool -> Maybe (GHC.HsDoc GHC.RdrName)+   -> IO ()+ppHtmlContents odir doctitle+  maybe_package maybe_html_help_format maybe_index_url+  maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do+  let tree = mkModuleTree showPkgs+         [(instMod iface, toInstalledDescription iface) | iface <- ifaces]+      html = +	header +		(documentCharacterEncoding ++++		 thetitle (toHtml doctitle) ++++		 styleSheet ++++		 (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++        body << vanillaTable << (+   	    simpleHeader doctitle Nothing maybe_index_url+                         maybe_source_url maybe_wiki_url </>+	    ppPrologue doctitle prologue </>+	    ppModuleTree doctitle tree </>+	    s15 </>+	    footer+	  )+  createDirectoryIfMissing True odir+  writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html)++  -- XXX: think of a better place for this?+  ppHtmlContentsFrame odir doctitle ifaces+  +  -- Generate contents page for Html Help if requested+  case maybe_html_help_format of+    Nothing        -> return ()+    Just "mshelp"  -> ppHHContents  odir doctitle maybe_package tree+    Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree+    Just "devhelp" -> return ()+    Just format    -> fail ("The "++format++" format is not implemented")++ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable+ppPrologue _ Nothing = Html.emptyTable+ppPrologue title (Just doc) = +  (tda [theclass "section1"] << toHtml title) </>+  docBox (rdrDocToHtml doc)++ppModuleTree :: String -> [ModuleTree] -> HtmlTable+ppModuleTree _ ts = +  tda [theclass "section1"] << toHtml "Modules" </>+  td << vanillaTable2 << htmlTable+  where+    genTable tbl id_ []     = (tbl, id_)+    genTable tbl id_ (x:xs) = genTable (tbl </> u) id' xs      +      where+        (u,id') = mkNode [] x 0 id_++    (htmlTable,_) = genTable emptyTable 0 ts++mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int)+mkNode ss (Node s leaf pkg short ts) depth id_ = htmlNode+  where+    htmlNode = case ts of+      [] -> (td_pad_w 1.25 depth << htmlModule  <-> shortDescr <-> htmlPkg,id_)+      _  -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg </> +                (td_subtree << sub_tree), id')++    mod_width = 50::Int {-em-}++    td_pad_w :: Double -> Int -> Html -> HtmlTable+    td_pad_w pad depth_ = +	tda [thestyle ("padding-left: " ++ show pad ++ "em;" +++		       "width: " ++ show (mod_width - depth_*2) ++ "em")]++    td_w depth_ = +	tda [thestyle ("width: " ++ show (mod_width - depth_*2) ++ "em")]++    td_subtree =+	tda [thestyle ("padding: 0; padding-left: 2em")]++    shortDescr :: HtmlTable+    shortDescr = case short of+	Nothing -> td empty+	Just doc -> tda [theclass "rdoc"] (origDocToHtml doc)++    htmlModule +      | leaf      = ppModule (mkModule (stringToPackageId pkgName) +                                       (mkModuleName mdl)) ""+      | otherwise = toHtml s++    -- ehm.. TODO: change the ModuleTree type+    (htmlPkg, pkgName) = case pkg of+      Nothing -> (td << empty, "")+      Just p  -> (td << toHtml p, p)++    mdl = foldr (++) "" (s' : map ('.':) ss')+    (s':ss') = reverse (s:ss)+	 -- reconstruct the module name+    +    id_s = "n:" ++ show id_+    +    (sub_tree,id') = genSubTree emptyTable (id_+1) ts+    +    genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int)+    genSubTree htmlTable id__ [] = (sub_tree_, id__)+      where+        sub_tree_ = collapsed vanillaTable2 id_s htmlTable+    genSubTree htmlTable id__ (x:xs) = genSubTree (htmlTable </> u) id__' xs      +      where+        (u,id__') = mkNode (s:ss) x (depth+1) id__++-- The URL for source and wiki links, and the current module+type LinksInfo = (SourceURLs, WikiURLs)++-- | 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 -> [InstalledInterface] -> IO ()+ppHtmlContentsFrame odir doctitle ifaces = do+  let mods = flatModuleTree ifaces+      html =+        header+            (documentCharacterEncoding ++++	     thetitle (toHtml doctitle) ++++	     styleSheet ++++	     (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++        body << vanillaTable << Html.p << (+            foldr (+++) noHtml (map (+++br) mods))+  createDirectoryIfMissing True odir+  writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderHtml html)++-- ---------------------------------------------------------------------------+-- Generate the index++ppHtmlIndex :: FilePath+            -> String +            -> Maybe String+            -> Maybe String+            -> Maybe String+            -> SourceURLs+            -> WikiURLs+            -> [InstalledInterface] +            -> IO ()+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format+  maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do+  let html = +        header (documentCharacterEncoding ++++                thetitle (toHtml (doctitle ++ " (Index)")) ++++        styleSheet ++++        (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++        body << vanillaTable << (+            simpleHeader doctitle maybe_contents_url Nothing+                         maybe_source_url maybe_wiki_url </>+        index_html+           )++  createDirectoryIfMissing True odir++  when split_indices $+    mapM_ (do_sub_index index) initialChars++  writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html)+  +    -- Generate index and contents page for Html Help if requested+  case maybe_html_help_format of+    Nothing        -> return ()+    Just "mshelp"  -> ppHHIndex  odir maybe_package ifaces+    Just "mshelp2" -> ppHH2Index odir maybe_package ifaces+    Just "devhelp" -> return ()+    Just format    -> fail ("The "++format++" format is not implemented")+ where++  index_html+    | split_indices = +	tda [theclass "section1"] << +	      	toHtml ("Index") </>+	indexInitialLetterLinks+    | otherwise =+	td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<+	  aboves (map indexElt index))++  -- 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++  setTrClass :: Html -> Html+  setTrClass (Html xs) = Html $ map f xs+      where+          f (HtmlTag name attrs inner)+               | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner+               | otherwise = HtmlTag name attrs (setTrClass inner)+          f x = x+ 	+  indexInitialLetterLinks = +	td << setTrClass (table ! [cellpadding 0, cellspacing 5] <<+	    besides [ td << anchor ! [href (subIndexHtmlFile c)] <<+			 toHtml [c]+		    | c <- initialChars+                    , any ((==c) . toUpper . head . fst) index ])++  -- 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 (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html)+    where +      html = header (documentCharacterEncoding ++++		thetitle (toHtml (doctitle ++ " (Index)")) ++++		styleSheet) ++++             body << vanillaTable << (+	        simpleHeader doctitle maybe_contents_url Nothing+                             maybe_source_url maybe_wiki_url </>+		indexInitialLetterLinks </>+	        tda [theclass "section1"] << +	      	toHtml ("Index (" ++ c:")") </>+	        td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<+	      	  aboves (map indexElt 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,_) = map toUpper n1 `compare` map toUpper 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 (++)))+               (concat (map getIfaceIndex ifaces))++  getIfaceIndex iface = +    [ (getOccString name+       , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])])+       | name <- instExports iface ]+    where mdl = instMod iface++  indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable+  indexElt (str, entities) = +     case Map.toAscList entities of+	[(nm,entries)] ->  +	    tda [ theclass "indexentry" ] << toHtml str <-> +			indexLinks nm entries+	many_entities ->+	    tda [ theclass "indexentry" ] << toHtml str </> +		aboves (map doAnnotatedEntity (zip [1..] many_entities))++  doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable+  doAnnotatedEntity (j,(nm,entries))+	= tda [ theclass "indexannot" ] << +		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 = +     tda [ theclass "indexlinks" ] << +	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+	-> SourceURLs -> WikiURLs+	-> Maybe String -> Maybe String -> Bool+	-> Interface -> IO ()+ppHtmlModule odir doctitle+  maybe_source_url maybe_wiki_url+  maybe_contents_url maybe_index_url unicode iface = do+  let +      mdl = ifaceMod iface+      mdl_str = moduleString mdl+      html = +	header (documentCharacterEncoding ++++		thetitle (toHtml mdl_str) ++++		styleSheet ++++		(script ! [src jsFile, thetype "text/javascript"] $ noHtml) ++++                (script ! [thetype "text/javascript"]+                     -- XXX: quoting errors possible?+                     << Html [HtmlString ("window.onload = function () {setSynopsis(\"mini_" +                                ++ moduleHtmlFile mdl ++ "\")};")])+               ) ++++        body << vanillaTable << (+	    pageHeader mdl_str iface doctitle+		maybe_source_url maybe_wiki_url+		maybe_contents_url maybe_index_url </> s15 </>+	    ifaceToHtml maybe_source_url maybe_wiki_url iface unicode </> s15 </>+	    footer+         )+  createDirectoryIfMissing True odir+  writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html)+  ppHtmlModuleMiniSynopsis odir doctitle iface unicode++ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO ()+ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do+  let mdl = ifaceMod iface+      html =+        header+          (documentCharacterEncoding ++++	   thetitle (toHtml $ moduleString mdl) ++++	   styleSheet ++++	   (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) ++++        body << thediv ! [ theclass "outer" ] << (+           (thediv ! [theclass "mini-topbar"]+             << toHtml (moduleString mdl)) ++++           miniSynopsis mdl iface unicode)+  createDirectoryIfMissing True odir+  writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderHtml html)++ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> HtmlTable+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode+  = abovesSep s15 (contents ++ description: synopsis: maybe_doc_hdr: bdy)+  where+    docMap = ifaceRnDocMap iface+ +    exports = numberSectionHeadings (ifaceRnExportItems iface)++    has_doc (ExportDecl _ doc _ _) = isJust doc+    has_doc (ExportNoDecl _ _) = False+    has_doc (ExportModule _) = False+    has_doc _ = True++    no_doc_at_all = not (any has_doc exports)++    contents = case ppModuleContents exports of+                   Nothing -> []+                   Just x -> [td << vanillaTable << x]++    description+          = case ifaceRnDoc iface of+              Nothing -> Html.emptyTable+              Just doc -> (tda [theclass "section1"] << toHtml "Description") </>+                          docBox (docToHtml doc)++	-- omit the synopsis if there are no documentation annotations at all+    synopsis+      | no_doc_at_all = Html.emptyTable+      | otherwise+      = (tda [theclass "section1"] << toHtml "Synopsis") </>+        s15 </>+            (tda [theclass "body"] << vanillaTable <<+            abovesSep s8 (map (processExport True linksInfo docMap unicode)+            (filter forSummary exports))+        )++	-- if the documentation doesn't begin with a section header, then+	-- add one ("Documentation").+    maybe_doc_hdr+      = case exports of		   +          [] -> Html.emptyTable+          ExportGroup _ _ _ : _ -> Html.emptyTable+          _ -> tda [ theclass "section1" ] << toHtml "Documentation"++    bdy  = map (processExport False linksInfo docMap unicode) exports+    linksInfo = (maybe_source_url, maybe_wiki_url)++miniSynopsis :: Module -> Interface -> Bool -> Html+miniSynopsis mdl iface unicode =+    thediv ! [ theclass "mini-synopsis" ]+      << hsep (map (processForMiniSynopsis mdl unicode) $ exports)+  where+    exports = numberSectionHeadings (ifaceRnExportItems iface)++processForMiniSynopsis :: Module -> Bool -> ExportItem DocName ->  Html+processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =+  thediv ! [theclass "decl" ] <<+  case decl0 of+    TyClD d@(TyFamily{}) -> ppTyFamHeader True False d unicode+    TyClD d@(TyData{tcdTyPats = ps})+      | Nothing <- ps    -> keyword "data" <++> ppTyClBinderWithVarsMini mdl d+      | Just _ <- ps     -> keyword "data" <++> keyword "instance"+                                           <++> ppTyClBinderWithVarsMini mdl d+    TyClD d@(TySynonym{tcdTyPats = ps})+      | Nothing <- ps    -> keyword "type" <++> ppTyClBinderWithVarsMini mdl d+      | Just _ <- ps     -> keyword "type" <++> keyword "instance"+                                           <++> ppTyClBinderWithVarsMini mdl d+    TyClD d@(ClassDecl {}) ->+                            keyword "class" <++> ppTyClBinderWithVarsMini mdl d+    SigD (TypeSig (L _ n) (L _ _)) ->+        let nm = docNameOcc n+        in ppNameMini mdl nm+    _ -> noHtml+processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =+  let heading+        | lvl == 1 = h1+        | lvl == 2 = h2+        | lvl >= 3 = h3+        | otherwise = error "bad group level"+  in heading << docToHtml txt+processForMiniSynopsis _ _ _ = noHtml++ppNameMini :: Module -> OccName -> Html+ppNameMini mdl nm =+    anchor ! [ href ( moduleHtmlFile mdl ++ "#"+                      ++ (escapeStr (anchorNameStr nm)))+             , target mainFrameName ]+      << ppBinder' nm++ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html+ppTyClBinderWithVarsMini mdl decl =+  let n = unLoc $ tcdLName decl+      ns = tyvarNames $ tcdTyVars decl+  in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName++ppModuleContents :: [ExportItem DocName] -> Maybe HtmlTable+ppModuleContents exports+  | length sections == 0 = Nothing+  | otherwise            = Just (tda [theclass "section4"] << bold << toHtml "Contents"+  		                 </> td << dlist << concatHtml sections)+ where+  (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 = (dterm << linkedAnchor id0 << docToHtml 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 = ddef << dlist << concatHtml 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 exports = go 1 exports+  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 -> DocMap -> Bool -> (ExportItem DocName) -> HtmlTable+processExport _ _ _ _ (ExportGroup lev id0 doc)+  = ppDocGroup lev (namedAnchor id0 << docToHtml doc)+processExport summary links docMap unicode (ExportDecl decl doc subdocs insts)+  = ppDecl summary links decl doc insts docMap subdocs unicode+processExport _ _ _ _ (ExportNoDecl y [])+  = declBox (ppDocName y)+processExport _ _ _ _ (ExportNoDecl y subs)+  = declBox (ppDocName y <+> parenList (map ppDocName subs))+processExport _ _ _ _ (ExportDoc doc)+  = docBox (docToHtml doc)+processExport _ _ _ _ (ExportModule mdl)+  = declBox (toHtml "module" <+> ppModule mdl "")++forSummary :: (ExportItem DocName) -> Bool+forSummary (ExportGroup _ _ _) = False+forSummary (ExportDoc _)       = False+forSummary _                    = True++ppDocGroup :: Int -> Html -> HtmlTable+ppDocGroup lev doc+  | lev == 1  = tda [ theclass "section1" ] << doc+  | lev == 2  = tda [ theclass "section2" ] << doc+  | lev == 3  = tda [ theclass "section3" ] << doc+  | otherwise = tda [ theclass "section4" ] << doc++declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (HsDoc DocName) -> Html -> HtmlTable+declWithDoc True  _     _   _  _          html_decl = declBox html_decl+declWithDoc False links loc nm Nothing    html_decl = topDeclBox links loc nm html_decl+declWithDoc False links loc nm (Just doc) html_decl = +		topDeclBox links loc nm html_decl </> docBox (docToHtml doc)+++-- TODO: use DeclInfo DocName or something+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> +          Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable+ppDecl summ links (L loc decl) mbDoc instances docMap subdocs unicode = case decl of+  TyClD d@(TyFamily {})          -> ppTyFam summ False links loc mbDoc d unicode+  TyClD d@(TyData {})+    | Nothing <- tcdTyPats d     -> ppDataDecl summ links instances loc mbDoc d unicode+    | Just _  <- tcdTyPats d     -> ppDataInst summ links loc mbDoc d +  TyClD d@(TySynonym {})+    | Nothing <- tcdTyPats d     -> ppTySyn summ links loc mbDoc d unicode+    | Just _  <- tcdTyPats d     -> ppTyInst summ False links loc mbDoc d unicode+  TyClD d@(ClassDecl {})         -> ppClassDecl summ links instances loc mbDoc docMap subdocs d unicode+  SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc n t unicode+  ForD d                         -> ppFor summ links loc mbDoc d unicode+  InstD _                        -> Html.emptyTable+  _                              -> error "declaration not supported by ppDecl"++ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->+            DocName -> HsType DocName -> Bool -> HtmlTable+ppFunSig summary links loc mbDoc docname typ unicode =+  ppTypeOrFunSig summary links loc docname typ mbDoc+    (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode+  where+    occname = docNameOcc docname++ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->+                  Maybe (HsDoc DocName) -> (Html, Html, Html) -> Bool -> HtmlTable+ppTypeOrFunSig summary links loc docname typ doc (pref1, pref2, sep) unicode+  | summary || noArgDocs typ = declWithDoc summary links loc docname doc pref1+  | otherwise = topDeclBox links loc docname pref2 </>+    (tda [theclass "body"] << vanillaTable <<  (+      do_args sep typ </>+        (case doc of+          Just d -> ndocBox (docToHtml d)+          Nothing -> Html.emptyTable)+	))+  where +    noLArgDocs (L _ t) = noArgDocs t+    noArgDocs (HsForAllTy _ _ _ t) = noLArgDocs t+    noArgDocs (HsFunTy (L _ (HsDocTy _ _)) _) = False +    noArgDocs (HsFunTy _ r) = noLArgDocs r+    noArgDocs (HsDocTy _ _) = False+    noArgDocs _ = True++    do_largs leader (L _ t) = do_args leader t  +    do_args :: Html -> (HsType DocName) -> HtmlTable+    do_args leader (HsForAllTy Explicit tvs lctxt ltype)+      = (argBox (+          leader <+> +          hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>+          ppLContextNoArrow lctxt unicode)+            <-> rdocBox noHtml) </> +            do_largs (darrow unicode) ltype+    do_args leader (HsForAllTy Implicit _ lctxt ltype)+      = (argBox (leader <+> ppLContextNoArrow lctxt unicode)+          <-> rdocBox noHtml) </> +          do_largs (darrow unicode) ltype+    do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r)+      = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (docToHtml (unLoc ldoc)))+          </> do_largs (arrow unicode) r+    do_args leader (HsFunTy lt r)+      = (argBox (leader <+> ppLType unicode lt) <-> rdocBox noHtml) </> do_largs (arrow unicode) r+    do_args leader (HsDocTy lt ldoc)+      = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (docToHtml (unLoc ldoc)))+    do_args leader t+      = argBox (leader <+> ppType unicode t) <-> rdocBox (noHtml)+++ppTyVars :: [LHsTyVarBndr DocName] -> [Html]+ppTyVars tvs = map ppTyName (tyvarNames tvs)+++tyvarNames :: [LHsTyVarBndr DocName] -> [Name]+tyvarNames = map (getName . hsTyVarName . unLoc)+  ++ppFor :: Bool -> LinksInfo -> SrcSpan -> Maybe Doc -> ForeignDecl DocName -> Bool -> HtmlTable+ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _) unicode+  = ppFunSig summary links loc mbDoc name typ unicode+ppFor _ _ _ _ _ _ = error "ppFor"+++-- we skip type patterns for now+ppTySyn :: Bool -> LinksInfo -> SrcSpan -> Maybe Doc -> TyClDecl DocName -> Bool -> HtmlTable+ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) unicode+  = ppTypeOrFunSig summary links loc name (unLoc ltype) mbDoc +                   (full, hdr, spaceHtml +++ equals) unicode+  where+    hdr  = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)+    full = hdr <+> equals <+> ppLType unicode ltype+    occ  = docNameOcc name+ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn"+++ppTypeSig :: Bool -> OccName -> HsType DocName  -> Bool -> Html+ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty+++ppTyName :: Name -> Html+ppTyName name+  | isNameSym name = parens (ppName name)+  | otherwise = ppName name+++--------------------------------------------------------------------------------+-- Type families+--------------------------------------------------------------------------------+++ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html+ppTyFamHeader summary associated decl unicode =++  (case tcdFlavour decl of+     TypeFamily+       | associated -> keyword "type"+       | otherwise  -> keyword "type family"+     DataFamily+       | associated -> keyword "data"+       | otherwise  -> keyword "data family"+  ) <+>++  ppTyClBinderWithVars summary decl <+>++  case tcdKind decl of+    Just kind -> dcolon unicode  <+> ppKind kind +    Nothing -> empty+++ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->+              TyClDecl DocName -> Bool -> HtmlTable+ppTyFam summary associated links loc mbDoc decl unicode+  +  | summary = declWithDoc summary links loc docname mbDoc +              (ppTyFamHeader True associated decl unicode)+  +  | associated, isJust mbDoc         = header_ </> bodyBox << doc +  | associated                       = header_ +  | null instances, isJust mbDoc     = header_ </> bodyBox << doc+  | null instances                   = header_+  | isJust mbDoc                     = header_ </> bodyBox << (doc </> instancesBit)+  | otherwise                        = header_ </> bodyBox << instancesBit++  where+    docname = tcdName decl++    header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode)++    doc = ndocBox . docToHtml . fromJust $ mbDoc ++    instId = collapseId (getName docname)++    instancesBit = instHdr instId </>+  	  tda [theclass "body"] << +            collapsed thediv instId (+              spacedTable1 << (+                aboves (map (declBox . ppInstHead unicode) instances)+              )+            )++    -- TODO: get the instances+    instances = []+++--------------------------------------------------------------------------------+-- Indexed data types+--------------------------------------------------------------------------------+++ppDataInst :: a+ppDataInst = undefined+++--------------------------------------------------------------------------------+-- Indexed newtypes+--------------------------------------------------------------------------------++-- TODO+-- ppNewTyInst = undefined+++--------------------------------------------------------------------------------+-- Indexed types+--------------------------------------------------------------------------------++ +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->+            TyClDecl DocName -> Bool -> HtmlTable+ppTyInst summary associated links loc mbDoc decl unicode+  +  | summary = declWithDoc summary links loc docname mbDoc+              (ppTyInstHeader True associated decl unicode)+  +  | isJust mbDoc = header_ </> bodyBox << doc +  | otherwise    = header_++  where+    docname = tcdName decl++    header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode)++    doc = case mbDoc of+      Just d -> ndocBox (docToHtml d)+      Nothing -> Html.emptyTable+++ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html+ppTyInstHeader _ _ decl unicode =+  keyword "type instance" <+>+  ppAppNameTypes (tcdName decl) typeArgs unicode+  where+    typeArgs = map unLoc . fromJust . tcdTyPats $ decl+++--------------------------------------------------------------------------------+-- Associated Types+--------------------------------------------------------------------------------+    ++ppAssocType :: Bool -> LinksInfo -> Maybe (HsDoc DocName) -> LTyClDecl DocName -> Bool -> HtmlTable+ppAssocType summ links doc (L loc decl) unicode = +  case decl of+    TyFamily  {} -> ppTyFam summ True links loc doc decl unicode+    TySynonym {} -> ppTySyn summ links loc doc decl unicode+    _            -> error "declaration type not supported by ppAssocType" +++--------------------------------------------------------------------------------+-- TyClDecl helpers+--------------------------------------------------------------------------------+++-- | Print a type family / newtype / data / class binder and its variables +ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html+ppTyClBinderWithVars summ decl = +  ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)+++--------------------------------------------------------------------------------+-- Type applications+--------------------------------------------------------------------------------+++-- | Print an application of a DocName and a list of HsTypes+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)+++-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html+ppAppDocNameNames summ n ns = +  ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName+++-- | General printing of type applications+ppTypeApp :: DocName -> [a] -> (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 n <+> ppT t2++ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)+++-------------------------------------------------------------------------------+-- Contexts +-------------------------------------------------------------------------------+++ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html+ppLContext        = ppContext        . unLoc+ppLContextNoArrow = ppContextNoArrow . unLoc+++ppContextNoArrow :: HsContext DocName -> Bool -> Html+ppContextNoArrow []  _ = empty+ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode+++ppContextNoLocs :: [HsPred DocName] -> Bool -> Html+ppContextNoLocs []  _ = empty+ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode+++ppContext :: HsContext DocName -> Bool -> Html+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode+++pp_hs_context :: [HsPred DocName] -> Bool -> Html+pp_hs_context []  _       = empty+pp_hs_context [p] unicode = ppPred unicode p+pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt)+++ppPred :: Bool -> HsPred DocName -> Html+ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode+ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2+ppPred unicode (HsIParam (IPName n) t)+  = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t+++-------------------------------------------------------------------------------+-- Class declarations+-------------------------------------------------------------------------------+++ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName+           -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]+           -> Bool -> Html+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 -> Html+ppFds fds unicode =+  if null fds then noHtml else +	char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))+  where+	fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>+			       hsep (map ppDocName vars2)++ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = +  if null sigs && null ats+    then (if summary then declBox else topDeclBox links loc nm) hdr+    else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")+	    </> +      (+				bodyBox <<+					aboves+					(+						[ ppAssocType summary links doc at unicode | at <- ats+                                                , let doc = join $ lookup (tcdName $ unL at) subdocs ]  ++++						[ ppFunSig summary links loc doc n typ unicode+						| L _ (TypeSig (L _ n) (L _ typ)) <- sigs+						, let doc = join $ lookup n subdocs ] +					)+				)+  where+    hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode+    nm  = unLoc lname+ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+    +++ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan+            -> Maybe (HsDoc DocName) -> DocMap -> [(DocName, Maybe (HsDoc DocName))]+            -> TyClDecl DocName -> Bool -> HtmlTable+ppClassDecl summary links instances loc mbDoc _ subdocs+	decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode+  | summary = ppShortClassDecl summary links decl loc subdocs unicode+  | otherwise = classheader </> bodyBox << (classdoc </> body_ </> instancesBit)+  where +    classheader+      | null lsigs = topDeclBox links loc nm (hdr unicode)+      | otherwise  = topDeclBox links loc nm (hdr unicode <+> keyword "where")++    nm   = unLoc $ tcdLName decl++    hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds+    +    classdoc = case mbDoc of+      Nothing -> Html.emptyTable+      Just d -> ndocBox (docToHtml d)++    body_+      | null lsigs, null ats = Html.emptyTable+      | null ats  = s8 </> methHdr </> bodyBox << methodTable+      | otherwise = s8 </> atHdr </> bodyBox << atTable </> +                    s8 </> methHdr </> bodyBox << methodTable + +    methodTable =+      abovesSep s8 [ ppFunSig summary links loc doc n typ unicode+                   | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs+                   , let doc = join $ lookup n subdocs ]++    atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats+                             , let doc = join $ lookup (tcdName $ unL at) subdocs ]++    instId = collapseId (getName nm)+    instancesBit+      | null instances = Html.emptyTable+      | otherwise +        =  s8 </> instHdr instId </>+           tda [theclass "body"] << +             collapsed thediv instId (+             spacedTable1 << (+               aboves (map (declBox . ppInstHead unicode) instances)+             ))+ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"+++ppInstHead :: Bool -> InstHead DocName -> Html+ppInstHead unicode ([],   n, ts) = ppAppNameTypes n ts unicode+ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode+++-- -----------------------------------------------------------------------------+-- Data & newtype declarations+++-- TODO: print contexts+ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html+ppShortDataDecl summary links loc dataDecl unicode++  | [lcon] <- cons, ResTyH98 <- resTy = +    ppDataHeader summary dataDecl unicode+    <+> equals <+> ppShortConstr summary (unLoc lcon) unicode++  | [] <- cons = ppDataHeader summary dataDecl unicode++  | otherwise = vanillaTable << (+      case resTy of +        ResTyH98 -> dataHeader </> +          tda [theclass "body"] << vanillaTable << (+            aboves (zipWith doConstr ('=':repeat '|') cons)+          )+        ResTyGADT _ -> dataHeader </> +          tda [theclass "body"] << vanillaTable << (+            aboves (map doGADTConstr cons)+          )+    )+  +  where+    dataHeader = +      (if summary then declBox else topDeclBox links loc docname)+      ((ppDataHeader summary dataDecl unicode) <+> +      case resTy of ResTyGADT _ -> keyword "where"; _ -> empty)++    doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode)+    doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode)++    docname   = unLoc . tcdLName $ dataDecl+    cons      = tcdCons dataDecl+    resTy     = (con_res . unLoc . head) cons ++ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> +              SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable+ppDataDecl summary links instances loc mbDoc dataDecl unicode+  +  | summary = declWithDoc summary links loc docname mbDoc +              (ppShortDataDecl summary links loc dataDecl unicode)+  +  | otherwise+      = (if validTable then (</>) else const) header_ $+	      tda [theclass "body"] << vanillaTable << (+		      datadoc </> +		      constrBit </>+		      instancesBit+        )+++  where+    docname   = unLoc . tcdLName $ dataDecl+    cons      = tcdCons dataDecl+    resTy     = (con_res . unLoc . head) cons +      +    header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode+             <+> whereBit)++    whereBit +      | null cons = empty +      | otherwise = case resTy of +        ResTyGADT _ -> keyword "where"+        _ -> empty                         ++    constrTable+      | any isRecCon cons = spacedTable5+      | otherwise         = spacedTable1++    datadoc = case mbDoc of+      Just doc -> ndocBox (docToHtml doc)+      Nothing -> Html.emptyTable++    constrBit +      | null cons = Html.emptyTable+      | otherwise = constrHdr </> ( +          tda [theclass "body"] << constrTable << +	  aboves (map (ppSideBySideConstr unicode) cons)+        )++    instId = collapseId (getName docname)++    instancesBit+      | null instances = Html.emptyTable+      | otherwise +        = instHdr instId </>+	  tda [theclass "body"] << +          collapsed thediv instId (+            spacedTable1 << (+              aboves (map (declBox . ppInstHead unicode) instances)+            )+          )++    validTable = isJust mbDoc || not (null cons) || not (null instances)+++isRecCon :: Located (ConDecl a) -> Bool+isRecCon lcon = case con_details (unLoc lcon) of +  RecCon _ -> True+  _ -> False+++ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html+ppShortConstr summary con unicode = case con_res con of +  ResTyH98 -> case con_details con of +    PrefixCon args -> header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args)+    RecCon fields -> header_ unicode +++ ppBinder summary occ <+>+                                              doRecordFields fields+    InfixCon arg1 arg2 -> header_ unicode +++ +      hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2]    ++  ResTyGADT resTy -> case con_details con of +    -- prefix & infix could use hsConDeclArgTys if it seemed to+    -- simplify the code.+    PrefixCon args -> doGADTCon args resTy+    -- 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 <+> hsep [+                            ppForAll forall ltvs lcontext unicode,+                            doRecordFields fields,+                            arrow unicode <+> ppLType unicode resTy ]+    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy +    +  where+    doRecordFields fields = braces (vanillaTable <<+                        aboves (map (ppShortField summary unicode) fields))+    doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [+                             ppForAll forall ltvs lcontext unicode,+                             ppLType unicode (foldr mkFunTy resTy args) ]++    header_  = ppConstrHdr forall tyVars context+    occ      = docNameOcc . 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 :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html+ppConstrHdr forall tvs ctxt unicode+ = (if null tvs then noHtml else ppForall)+   ++++   (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ")+  where+    ppForall = case forall of +      Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". "+      Implicit -> empty++ppSideBySideConstr :: Bool -> LConDecl DocName -> HtmlTable+ppSideBySideConstr unicode (L _ con) = case con_res con of + +  ResTyH98 -> case con_details con of ++    PrefixCon args -> +      argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) +      <-> maybeRDocBox mbLDoc  ++    RecCon fields -> +      argBox (header_ unicode +++ ppBinder False occ) <->+      maybeRDocBox mbLDoc+      </>+      doRecordFields fields++    InfixCon arg1 arg2 -> +      argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2])+      <-> maybeRDocBox mbLDoc+ +  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+                                          </> doRecordFields fields+    InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy ++ where +    doRecordFields fields =+        (tda [theclass "body"] << spacedTable1 <<+        aboves (map (ppSideBySideField unicode) fields))+    doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [+                               ppForAll forall ltvs (con_cxt con) unicode,+                               ppLType unicode (foldr mkFunTy resTy args) ]+                            ) <-> maybeRDocBox mbLDoc+++    header_ = ppConstrHdr forall tyVars context+    occ     = docNameOcc . unLoc . con_name $ con+    ltvs    = con_qvars con+    tyVars  = tyvarNames (con_qvars con)+    context = unLoc (con_cxt con)+    forall  = con_explicit con+    mbLDoc  = con_doc con+    mkFunTy a b = noLoc (HsFunTy a b)++ppSideBySideField :: Bool -> ConDeclField DocName ->  HtmlTable+ppSideBySideField unicode (ConDeclField (L _ name) ltype mbLDoc) =+  argBox (ppBinder False (docNameOcc name)+    <+> dcolon unicode <+> ppLType unicode ltype) <->+  maybeRDocBox mbLDoc++{-+ppHsFullConstr :: HsConDecl -> Html+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 (docToHtml (fromJust doc))+	  | otherwise  = Html.emptyTable++	fields_html = +	   td << +	      table ! [width "100%", cellpadding 0, cellspacing 8] << (+		   aboves (map ppFullField (concat (map expandField fields)))+		)+-}++ppShortField :: Bool -> Bool -> ConDeclField DocName -> HtmlTable+ppShortField summary unicode (ConDeclField (L _ name) ltype _)+  = tda [theclass "recfield"] << (+      ppBinder summary (docNameOcc name)+      <+> dcolon unicode <+> ppLType unicode ltype+    )++{-+ppFullField :: HsFieldDecl -> Html+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 :: Bool -> TyClDecl DocName -> Bool -> Html+ppDataHeader summary decl unicode+  | not (isDataDecl decl) = error "ppDataHeader: illegal argument"+  | otherwise = +    -- newtype or data+    (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> +    -- context+    ppLContext (tcdCtxt decl) unicode <+>+    -- T a b c ..., or a :+: b+    ppTyClBinderWithVars summary decl+++-- ----------------------------------------------------------------------------+-- Types and contexts+++ppKind :: Outputable a => a -> Html+ppKind k = toHtml $ showSDoc (ppr k)+++{-+ppForAll Implicit _ lctxt = ppCtxtPart lctxt+ppForAll Explicit ltvs lctxt = +  hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt +-}+++ppBang :: HsBang -> Html+ppBang HsNoBang = empty +ppBang HsStrict = toHtml "!"+ppBang HsUnbox  = toHtml "!" -- unboxed args is an implementation detail,+                             -- so we just show the strictness annotation+++tupleParens :: Boxity -> [Html] -> Html+tupleParens Boxed   = parenList+tupleParens Unboxed = ubxParenList +{-+ppType :: HsType DocName -> Html+ppType t = case t of+  t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype+  HsTyVar n -> ppDocName n+  HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt+  HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt+  HsAppTy a b -> ppLType a <+> ppLType b +  HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b]+  HsListTy t -> brackets $ ppLType t+  HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]"+  HsTupleTy Boxed ts -> parenList $ map ppLType ts+  HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts+  HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b+  HsParTy t -> parens $ ppLType t+  HsNumTy n -> toHtml (show n)+  HsPredTy p -> ppPred p+  HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k]+  HsSpliceTy _ -> error "ppType"+  HsDocTy t _ -> ppLType t+-}+++--------------------------------------------------------------------------------+-- Rendering of HsType +--------------------------------------------------------------------------------+++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+           -> Html -> Html  -- Wrap in parens if (ctxt >= op)+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p+                               | otherwise            = p+++ppLType, ppLParendType :: Bool -> Located (HsType DocName) -> Html+ppLType       unicode y = ppType unicode (unLoc y)+ppLParendType unicode y = ppParendType unicode (unLoc y) +++ppType, ppParendType :: Bool -> HsType DocName -> Html+ppType       unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +++-- Drop top-level for-all type variables in user style+-- since they are implicit in Haskell++ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]+         -> Located (HsContext DocName) -> Bool -> Html+ppForAll expl tvs cxt unicode+  | show_forall = forall_part <+> ppLContext cxt unicode+  | otherwise   = ppLContext cxt unicode+  where+    show_forall = not (null 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 -> Html+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode +++ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html+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]++-- gaw 2004+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 <+> ppKind 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 _         (HsPredTy p)        u = parens (ppPred u p)+ppr_mono_ty _         (HsNumTy n)         _ = toHtml (show n) -- generics only+ppr_mono_ty _         (HsSpliceTy _)      _ = error "ppr_mono_ty-haddock"+#if __GLASGOW_HASKELL__ >= 611+ppr_mono_ty _         (HsRecTy _)         _ = error "ppr_mono_ty HsRecTy"+#endif++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 quote (ppLDocName op) else ppLDocName op+    occName = docNameOcc . 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_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html +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 $+    hsep [p1, arrow unicode <+> p2]+++-- ----------------------------------------------------------------------------+-- Names++ppOccName :: OccName -> Html+ppOccName = toHtml . occNameString++ppRdrName :: RdrName -> Html+ppRdrName = ppOccName . rdrNameOcc++ppLDocName :: Located DocName -> Html+ppLDocName (L _ d) = ppDocName d++ppDocName :: DocName -> Html+ppDocName (Documented name mdl) = +  linkIdOcc mdl (Just occName) << ppOccName occName+    where occName = nameOccName name+ppDocName (Undocumented name) = toHtml (getOccString name)++linkTarget :: OccName -> Html+linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" ++ppName :: Name -> Html+ppName 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 (anchorNameStr n) << ppBinder' n+ppBinder False n = linkTarget n +++ bold << ppBinder' n+++ppBinder' :: OccName -> Html+ppBinder' n+  | isVarSym n = parens $ ppOccName n+  | otherwise  = ppOccName n+++linkId :: Module -> Maybe Name -> Html -> Html+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName)+++linkIdOcc :: Module -> Maybe OccName -> Html -> Html+linkIdOcc mdl mbName = anchor ! [href uri]+  where +    uri = case mbName of+      Nothing   -> moduleHtmlFile mdl+      Just name -> nameHtmlRef mdl name++ppModule :: Module -> String -> Html+ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)] +                   << toHtml (moduleString mdl)++-- -----------------------------------------------------------------------------+-- * Doc Markup++parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html+parHtmlMarkup ppId isTyCon = Markup {+  markupParagraph     = paragraph,+  markupEmpty	      = toHtml "",+  markupString        = toHtml,+  markupAppend        = (+++),+  markupIdentifier    = tt . ppId . choose,+  markupModule        = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref,+  markupEmphasis      = emphasize . toHtml,+  markupMonospaced    = tt . toHtml,+  markupUnorderedList = ulist . concatHtml . map (li <<),+  markupPic           = \path -> image ! [src path],+  markupOrderedList   = olist . concatHtml . map (li <<),+  markupDefList       = dlist . concatHtml . map markupDef,+  markupCodeBlock     = pre,+  markupURL	      = \url -> anchor ! [href url] << toHtml url,+  markupAName	      = \aname -> namedAnchor aname << toHtml ""+  }+  where+    -- If an id can refer to multiple things, we give precedence to type+    -- constructors.  This should ideally be done during renaming from RdrName+    -- to Name, but since we will move this process from GHC into Haddock in+    -- the future, we fix it here in the meantime.+    -- TODO: mention this rule in the documentation.+    choose [] = error "empty identifier list in HsDoc"+    choose [x] = x+    choose (x:y:_)+      | isTyCon x = x+      | otherwise = y+++markupDef :: (HTML a, HTML b) => (a, b) -> Html+markupDef (a,b) = dterm << a +++ ddef << b+++htmlMarkup :: DocMarkup DocName Html+htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName)++htmlOrigMarkup :: DocMarkup Name Html+htmlOrigMarkup = parHtmlMarkup ppName isTyConName++htmlRdrMarkup :: DocMarkup RdrName Html+htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc++-- If the doc is a single paragraph, don't surround it with <P> (this causes+-- ugly extra whitespace with some browsers).+docToHtml :: HsDoc DocName -> Html+docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))++origDocToHtml :: HsDoc Name -> Html+origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc))++rdrDocToHtml :: HsDoc RdrName -> Html+rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc))++-- 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.+unParagraph :: HsDoc a -> HsDoc a+unParagraph (GHC.DocParagraph d) = d+--NO: This eliminates line breaks in the code block:  (SDM, 6/5/2003)+--unParagraph (DocCodeBlock d) = (DocMonospaced d)+unParagraph doc              = doc++htmlCleanup :: DocMarkup a (GHC.HsDoc a)+htmlCleanup = idMarkup { +  markupUnorderedList = GHC.DocUnorderedList . map unParagraph,+  markupOrderedList   = GHC.DocOrderedList   . map unParagraph+  } ++-- -----------------------------------------------------------------------------+-- * Misc++hsep :: [Html] -> Html+hsep [] = noHtml+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls++infixr 8 <+>, <++>+(<+>) :: Html -> Html -> Html+a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b))++(<++>) :: Html -> Html -> Html+a <++> b = a +++ spaceHtml +++ b++keyword :: String -> Html+keyword s = thespan ! [theclass "keyword"] << toHtml s++equals, comma :: Html+equals = char '='+comma  = char ','++char :: Char -> Html+char c = toHtml [c]++empty :: Html+empty  = noHtml+++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++abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable+abovesSep _ []      = Html.emptyTable+abovesSep 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 "#)"++{-+text :: Html+text   = strAttr "TEXT"+-}++-- a box for displaying code+declBox :: Html -> HtmlTable+declBox html = tda [theclass "decl"] << html++-- a box for top level documented names+-- it adds a source and wiki link at the right hand side of the box+topDeclBox :: LinksInfo -> SrcSpan -> DocName -> Html -> HtmlTable+topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html+topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url))+           loc name html =+  tda [theclass "topdecl"] <<+  (        table ! [theclass "declbar"] <<+	    ((tda [theclass "declname"] << html)+             <-> srcLink+             <-> wikiLink)+  )+  where srcLink =+          case maybe_source_url of+            Nothing  -> Html.emptyTable+            Just url -> tda [theclass "declbut"] <<+                          let url' = spliceURL (Just fname) (Just origMod)+                                               (Just n) (Just loc) url+                           in anchor ! [href url'] << toHtml "Source"++        wikiLink =+          case maybe_wiki_url of+            Nothing  -> Html.emptyTable+            Just url -> tda [theclass "declbut"] <<+                          let url' = spliceURL (Just fname) (Just mdl)+                                               (Just n) (Just loc) url+                           in anchor ! [href url'] << toHtml "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++        -- Name must be documented, otherwise we wouldn't get here+        Documented n mdl = name++        fname = unpackFS (srcSpanFile loc)+++-- a box for displaying an 'argument' (some code which has text to the+-- right of it).  Wrapping is not allowed in these boxes, whereas it is+-- in a declBox.+argBox :: Html -> HtmlTable+argBox html = tda [theclass "arg"] << html++-- a box for displaying documentation, +-- indented and with a little padding at the top+docBox :: Html -> HtmlTable+docBox html = tda [theclass "doc"] << html++-- a box for displaying documentation, not indented.+ndocBox :: Html -> HtmlTable+ndocBox html = tda [theclass "ndoc"] << html++-- a box for displaying documentation, padded on the left a little+rdocBox :: Html -> HtmlTable+rdocBox html = tda [theclass "rdoc"] << html++maybeRDocBox :: Maybe (GHC.LHsDoc DocName) -> HtmlTable+maybeRDocBox Nothing = rdocBox (noHtml)+maybeRDocBox (Just ldoc) = rdocBox (docToHtml (unLoc ldoc))++-- a box for the buttons at the top of the page+topButBox :: Html -> HtmlTable+topButBox html = tda [theclass "topbut"] << html++bodyBox :: Html -> HtmlTable+bodyBox html = tda [theclass "body"] << vanillaTable << html++-- a vanilla table has width 100%, no border, no padding, no spacing+-- a narrow table is the same but without width 100%.+vanillaTable, vanillaTable2, narrowTable :: Html -> Html+vanillaTable  = table ! [theclass "vanilla",  cellspacing 0, cellpadding 0]+vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0]+narrowTable   = table ! [theclass "narrow",   cellspacing 0, cellpadding 0]++spacedTable1, spacedTable5 :: Html -> Html+spacedTable1 = table ! [theclass "vanilla",  cellspacing 1, cellpadding 0]+spacedTable5 = table ! [theclass "vanilla",  cellspacing 5, cellpadding 0]++constrHdr, methHdr, atHdr :: HtmlTable+constrHdr  = tda [ theclass "section4" ] << toHtml "Constructors"+methHdr    = tda [ theclass "section4" ] << toHtml "Methods"+atHdr      = tda [ theclass "section4" ] << toHtml "Associated Types"++instHdr :: String -> HtmlTable+instHdr id_ = +  tda [ theclass "section4" ] << (collapsebutton id_ +++ toHtml " Instances")++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 "."+++s8, s15 :: HtmlTable+s8  = tda [ theclass "s8" ]  << noHtml+s15 = tda [ theclass "s15" ] << noHtml+++-- | Generate a named anchor+--+-- This actually generates two anchor tags, one with the name unescaped, and one+-- with the name URI-escaped. This is needed because Opera 9.52 (and later+-- versions) needs the name to be unescaped, while IE 7 needs it to be escaped.+--+namedAnchor :: String -> Html -> Html+namedAnchor n = (anchor ! [Html.name n]) . (anchor ! [Html.name (escapeStr n)])+++--+-- A section of HTML which is collapsible via a +/- button.+--++-- TODO: Currently the initial state is non-collapsed. Change the 'minusFile'+-- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we+-- use cookies from JavaScript to have a more persistent state.++collapsebutton :: String -> Html+collapsebutton id_ = +  image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ]++collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html+collapsed fn id_ html =+  fn ! [identifier id_, thestyle "display:block;"] << html++-- A quote is a valid part of a Haskell identifier, but it would interfere with+-- the ECMA script string delimiter used in collapsebutton above.+collapseId :: Name -> String+collapseId nm = "i:" ++ escapeStr (getOccString nm)++linkedAnchor :: String -> Html -> Html+linkedAnchor frag = anchor ! [href hr_]+   where hr_ | null frag = ""+             | otherwise = '#': escapeStr frag++documentCharacterEncoding :: Html+documentCharacterEncoding =+   meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"]++styleSheet :: Html+styleSheet =+   thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]
+ src/Haddock/GhcUtils.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE FlexibleInstances #-}+{-# 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 qualified Data.Map as Map+import Control.Arrow+import Data.Foldable hiding (concatMap)+import Data.Traversable++import HsSyn+import SrcLoc+import Outputable+import Name+import Packages+import Module+++moduleString :: Module -> String+moduleString = moduleNameString . moduleName +++-- return the name of the package, with version info+modulePackageString :: Module -> String+modulePackageString = packageIdString . modulePackageId+++-- return the (name,version) of the package+modulePackageInfo :: Module -> (String, [Char])+modulePackageInfo modu = case unpackPackageId pkg of+                          Nothing -> (packageIdString pkg, "")+#if __GLASGOW_HASKELL__ >= 609+                          Just x -> (display $ pkgName x, showVersion (pkgVersion x))+#else+                          Just x -> (pkgName x, showVersion (pkgVersion x))+#endif+  where pkg = modulePackageId modu+++mkModuleNoPackage :: String -> Module+mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)+++instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where+  ppr m = ppr (Map.toList m)+++isNameSym :: Name -> Bool+isNameSym = isSymOcc . nameOccName+++isVarSym :: OccName -> Bool+isVarSym = isLexVarSym . occNameFS+++getMainDeclBinder :: HsDecl name -> Maybe name+getMainDeclBinder (TyClD d) = Just (tcdName d)+getMainDeclBinder (ValD d)+   = case collectAcc d [] of+        []       -> Nothing +        (name:_) -> Just (unLoc name)+getMainDeclBinder (SigD d) = sigNameNoLoc d+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)+getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing+getMainDeclBinder _ = Nothing+++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 (TyClD d) = isFamInstDecl d+isInstD _ = False+++declATs :: HsDecl a -> [a]+declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d+declATs _ = []+++pretty :: Outputable a => a -> String+pretty x = showSDoc (ppr x)+++trace_ppr :: Outputable a => a -> b -> b+trace_ppr x y = trace (pretty x) y+++-------------------------------------------------------------------------------+-- Located+-------------------------------------------------------------------------------+++unL :: Located a -> a+unL (L _ x) = x+++reL :: a -> Located a+reL = L undefined+++instance Foldable Located where+  foldMap f (L _ x) = f x+++instance Traversable Located where+  mapM f (L l x) = (return . 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) . tcdCons $ d+    | isClassDecl d =+        map (tcdName . unL) (tcdATs d) +++        [ unL n | L _ (TypeSig n _) <- tcdSigs d ]+    | 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) (tcdCons d)+  | isClassDecl d = family d : concatMap (families . unL) (tcdATs 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 _ _ = []
+ src/Haddock/Interface.hs view
@@ -0,0 +1,266 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Interface+-- Copyright   :  (c) Simon Marlow 2003-2006,+--                    David Waern  2006-2009+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Here we build the actual module interfaces. By interface we mean the+-- information that is used to render a Haddock page for a module. Parts of+-- this information are also stored in the .haddock files.+-----------------------------------------------------------------------------++module Haddock.Interface (+  createInterfaces+) where+++import Haddock.Interface.Create+import Haddock.Interface.AttachInstances+import Haddock.Interface.Rename+import Haddock.Types+import Haddock.Options+import Haddock.GhcUtils+import Haddock.Utils+import Haddock.InterfaceFile++import qualified Data.Map as Map+import Data.List+import Data.Maybe+import Control.Monad+import Control.Exception ( evaluate )+import Distribution.Verbosity++import GHC hiding (verbosity, flags)+import Digraph+import HscTypes+++-- | Turn a topologically sorted list of module names/filenames into interfaces. Also+-- return the home link environment created in the process.+#if __GLASGOW_HASKELL__ >= 609+createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile]+                 -> Ghc ([Interface], LinkEnv)+createInterfaces verbosity modules flags extIfaces = do+  -- part 1, create interfaces+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces+                                   , iface <- ifInstalledIfaces ext ]+  out verbosity verbose "Creating interfaces..."+  interfaces <- createInterfaces' verbosity modules flags instIfaceMap+#else+createInterfaces :: Verbosity -> Session -> [String] -> [Flag]+                 -> [InterfaceFile] -> IO ([Interface], LinkEnv)+createInterfaces verbosity session modules flags extIfaces = do+  -- part 1, create interfaces+  let instIfaceMap =  Map.fromList [ (instMod iface, iface) | ext <- extIfaces+                                   , iface <- ifInstalledIfaces ext ]+  out verbosity verbose "Creating interfaces..."+  interfaces <- createInterfaces' verbosity session modules flags instIfaceMap+#endif+  -- part 2, build link environment+  out verbosity verbose "Building link 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+      allNames  = Map.keys links++  -- part 3, attach instances+  out verbosity verbose "Attaching instances..."+  let interfaces' = attachInstances interfaces allNames++  -- part 4, rename interfaces+  out verbosity verbose "Renaming interfaces..."+  let warnings = Flag_NoWarnings `notElem` flags+  let (interfaces'', msgs) = +         runWriter $ mapM (renameInterface links warnings) interfaces'+  liftIO $ mapM_ putStrLn msgs++  return (interfaces'', homeLinks)  +++#if __GLASGOW_HASKELL__ >= 609+createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]+createInterfaces' verbosity modules flags instIfaceMap = do+  targets <- mapM (\f -> guessTarget f Nothing) modules+  setTargets targets+  modgraph <- depanal [] False++#if (__GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ >= 2) || __GLASGOW_HASKELL__ >= 611+  -- If template haskell is used by the package, we can not use+  -- HscNothing as target since we might need to run code generated from+  -- one or more of the modules during typechecking.+#if __GLASGOW_HASKELL__ < 611+  let needsTemplateHaskell = any (dopt Opt_TemplateHaskell . ms_hspp_opts)+#endif+  modgraph' <- if needsTemplateHaskell modgraph+       then do+         dflags <- getSessionDynFlags+         _ <- setSessionDynFlags dflags { hscTarget = HscAsm } +         -- we need to set HscAsm on all the ModSummaries as well+         let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscAsm } }  +         return (map addHscAsm modgraph)+       else return modgraph+#else+  let modgraph' = modgraph+#endif++  let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing+  (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do+    x <- processModule verbosity modsum flags modMap instIfaceMap+#else+createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]+createInterfaces' verbosity session modules flags instIfaceMap = do+  targets <- mapM (\f -> guessTarget f Nothing) modules+  setTargets session targets+  mbGraph <- depanal session [] False+  modgraph <- case mbGraph of+    Just graph -> return graph+    Nothing -> throwE "Failed to create dependency graph"+  let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing+  (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do+    x <- processModule verbosity session modsum flags modMap instIfaceMap+#endif+    case x of+      Just interface ->+        return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap)+      Nothing -> return (ifaces, modMap)+    ) ([], Map.empty) orderedMods+  return (reverse ifaces)++{-    liftIO $ do+     putStrLn . ppModInfo $ ifaceInfo interface+     putStrLn . show $ fmap pretty (ifaceDoc interface)+     print (ifaceOptions interface)+     mapM (putStrLn . pretty . fst) (Map.elems . ifaceDeclMap $ interface)+     mapM (putStrLn . show . fmap pretty . snd) (Map.elems . ifaceDeclMap $ interface)+     mapM (putStrLn . ppExportItem) (ifaceExportItems interface)+     mapM (putStrLn . pretty) (ifaceLocals interface)+     mapM (putStrLn . pretty) (ifaceExports interface)+     mapM (putStrLn . pretty) (ifaceVisibleExports interface)+     mapM (putStrLn . pretty) (ifaceInstances interface)+     mapM (\(a,b) -> putStrLn $ pretty a ++ pretty b)  (Map.toList $ ifaceSubMap interface)+     mapM (putStrLn . pretty) (ifaceInstances interface)-}++{-++ppInsts = concatMap ppInst ++ppInst (a,b,c) = concatMap pretty a ++ pretty b ++ concatMap pretty c +++ppExportItem (ExportDecl decl (Just doc) insts) = pretty decl ++ pretty doc ++ ppInsts insts+ppExportItem (ExportDecl decl Nothing insts) = pretty decl ++ ppInsts insts+ppExportItem (ExportNoDecl name name2 names) = pretty name ++ pretty name2 ++ pretty names+ppExportItem (ExportGroup level id doc) = show level ++ show id ++ pretty doc+ppExportItem (ExportDoc doc) = pretty doc+ppExportItem (ExportModule mod) = pretty mod+++ppModInfo (HaddockModInfo a b c d) = show (fmap pretty a) ++ show b ++ show c ++ show d +-}++#if __GLASGOW_HASKELL__ >= 609+processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)+processModule verbosity modsum flags modMap instIfaceMap = do+  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."+  tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum+  if not $ isBootSummary modsum+    then do+      let filename = msHsFilePath modsum+      let dynflags = ms_hspp_opts modsum+      let Just renamed_src = renamedSource tc_mod+      let ghcMod = mkGhcModule (ms_mod modsum,+                            filename,+                            (parsedSource tc_mod,+                             renamed_src,+                             typecheckedSource tc_mod,+                             moduleInfo tc_mod))+                            dynflags+      out verbosity verbose "Creating interface..."+      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap+      liftIO $ mapM_ putStrLn msg+      interface' <- liftIO $ evaluate interface+      return (Just interface')+    else+      return Nothing+#else+processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)+processModule verbosity session modsum flags modMap instIfaceMap = do+  out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."+  let filename = msHsFilePath modsum+  mbMod <- checkAndLoadModule session modsum False+  if not $ isBootSummary modsum+    then do+      ghcMod <- case mbMod of+        Just (CheckedModule a (Just b) (Just c) (Just d) _)+          -> return $ mkGhcModule (ms_mod modsum, filename, (a,b,c,d)) (ms_hspp_opts modsum)+        _ -> throwE ("Failed to check module: " ++ (moduleString $ ms_mod modsum))+      let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap+      mapM_ putStrLn msg+      return (Just interface)+    else+      return Nothing+#endif+++type CheckedMod = (Module, FilePath, FullyCheckedMod)+++type FullyCheckedMod = (ParsedSource, +                        RenamedSource, +                        TypecheckedSource, +                        ModuleInfo)+++-- | Dig out what we want from the typechecker output+mkGhcModule :: CheckedMod -> DynFlags -> GhcModule +mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {+  ghcModule         = mdl,+  ghcFilename       = file,+  ghcMbDocOpts      = mbOpts,+  ghcHaddockModInfo = info,+  ghcMbDoc          = mbDoc,+  ghcGroup          = group_,+  ghcMbExports      = mbExports,+  ghcExportedNames  = modInfoExports modInfo,+  ghcDefinedNames   = map getName $ modInfoTyThings modInfo,+  ghcNamesInScope   = fromJust $ modInfoTopLevelScope modInfo, +  ghcInstances      = modInfoInstances modInfo+}+  where+#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2+    HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed+#else+    mbOpts = haddockOptions dynflags+#endif+    (group_, _, mbExports, mbDoc, info) = renamed+    (_, renamed, _, modInfo) = checkedMod+++-- | 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
+ src/Haddock/Interface/AttachInstances.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE MagicHash #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Interface.AttachInstances+-- Copyright   :  (c) David Waern  2006-2009+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+-----------------------------------------------------------------------------++module Haddock.Interface.AttachInstances (attachInstances) where+++import Haddock.Types++import qualified Data.Map as Map+import Data.Map (Map)+import Data.List++import GHC+import Name+import InstEnv+import Class++#if __GLASGOW_HASKELL__ >= 610 && __GHC_PATCHLEVEL__ >= 2+import TypeRep hiding (funTyConName)+#else+import TypeRep+#endif++import Var hiding (varName)+import TyCon+import PrelNames+import FastString+#define FSLIT(x) (mkFastString# (x#))+++attachInstances :: [Interface] -> [Name] -> [Interface]+attachInstances ifaces filterNames = map attach ifaces+  where+    instMap =+      fmap (map toHsInstHead . sortImage instHead) $+      collectInstances ifaces filterNames++    attach iface = iface { ifaceExportItems = newItems }+      where+        newItems = map attachExport (ifaceExportItems iface)++        attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _)+          | isClassDecl d || isDataDecl d || isFamilyDecl d =+             ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of+                                    Nothing -> []+                                    Just instheads -> instheads)+        attachExport export = export+++--------------------------------------------------------------------------------+-- Collecting and sorting instances+--------------------------------------------------------------------------------+++-- | Simplified type for sorting types, ignoring qualification (not visible+-- in Haddock output) and unifying special tycons with normal ones.+data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)+++collectInstances+   :: [Interface]+   -> [Name]+   -> Map Name [([TyVar], [PredType], Class, [Type])]  -- maps class/type names to instances++collectInstances ifaces _ -- filterNames+  = Map.fromListWith (flip (++)) tyInstPairs `Map.union`+    Map.fromListWith (flip (++)) classInstPairs+  where+    allInstances = concatMap ifaceInstances ifaces+    classInstPairs = [ (is_cls inst, [instanceHead inst]) | +                       inst <- allInstances ]+                    -- unfinished filtering of internal instances+                    -- Just n <- nub (is_tcs inst) ]+                    --   n `elem` filterNames ]+    tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, +                    Just tycon <- nub (is_tcs inst) ]    +++-- TODO: should we support PredTy here?+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])+instHead (_, _, cls, args)+  = (map argCount args, className cls, map simplify args)+  where+    argCount (AppTy t _) = argCount t + 1+    argCount (TyConApp _ ts) = length ts+    argCount (FunTy _ _ ) = 2+    argCount (ForAllTy _ t) = argCount t+    argCount _ = 0++    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 _ = error "simplify"+++-- sortImage f = sortBy (\x y -> compare (f x) (f y))+sortImage :: Ord b => (a -> b) -> [a] -> [a]+sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]+ where cmp_fst (x,_) (y,_) = compare x y+++funTyConName :: Name+funTyConName = mkWiredInName gHC_PRIM+                        (mkOccNameFS tcName FSLIT("(->)"))+                        funTyConKey+                        (ATyCon funTyCon)       -- Relevant TyCon+                        BuiltInSyntax+++toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name+toHsInstHead (_, preds, cls, ts) = (map toHsPred preds, className cls, map toHsType ts) +++--------------------------------------------------------------------------------+-- Type -> HsType conversion+--------------------------------------------------------------------------------+++toHsPred :: PredType -> HsPred Name+toHsPred (ClassP cls ts) = HsClassP (className cls) (map toLHsType ts)+toHsPred (IParam n t) = HsIParam n (toLHsType t)+toHsPred (EqPred t1 t2) = HsEqualP (toLHsType t1) (toLHsType t2)+++toLHsType :: Type -> Located (HsType Name)+toLHsType = noLoc . toHsType++ +toHsType :: Type -> HsType Name+toHsType t = case t of +  TyVarTy v -> HsTyVar (tyVarName v) +  AppTy a b -> HsAppTy (toLHsType a) (toLHsType b)++  TyConApp tc ts -> case ts of +    t1:t2:rest+      | isSymOcc . nameOccName . tyConName $ tc ->+          app (HsOpTy (toLHsType t1) (noLoc . tyConName $ tc) (toLHsType t2)) rest+    _ -> app (tycon tc) ts++  FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)+  ForAllTy v ty -> cvForAll [v] ty +  PredTy p -> HsPredTy (toHsPred p) +  where+    tycon = HsTyVar . tyConName+    app tc = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc . map toHsType+    cvForAll vs (ForAllTy v ty) = cvForAll (v:vs) ty+    cvForAll vs ty = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType ty)+    tyvarbinders = map (noLoc . UserTyVar . tyVarName)
+ src/Haddock/Interface/Create.hs view
@@ -0,0 +1,579 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Interface.Create+-- 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.Create (createInterface) where+++import Haddock.Types+import Haddock.Options+import Haddock.GhcUtils+import Haddock.Utils++import qualified Data.Map as Map+import Data.Map (Map)+import Data.List+import Data.Maybe+import Data.Ord+import Control.Monad++import GHC hiding (flags)+import Name+import Bag+++-- | Process the data in the GhcModule to produce an interface.+-- To do this, we need access to already processed modules in the topological+-- sort. That's what's in the module map.+createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap+                -> ErrMsgM Interface+createInterface ghcMod flags modMap instIfaceMap = do++  let mdl = ghcModule ghcMod++  opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mdl+  let opts+        | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0+        | otherwise = opts0++  let group_        = ghcGroup ghcMod+      exports       = fmap (reverse . map unLoc) (ghcMbExports ghcMod)+      localNames    = ghcDefinedNames ghcMod+      decls0        = declInfos . topDecls $ group_+      decls         = filterOutInstances decls0+      declMap       = mkDeclMap decls+      ignoreExps    = Flag_IgnoreAllExports `elem` flags+      exportedNames = ghcExportedNames ghcMod+      instances     = ghcInstances ghcMod++  warnAboutFilteredDecls mdl decls0++  exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap+                               opts exports ignoreExps instances instIfaceMap++  let visibleNames = mkVisibleNames exportItems opts+  +  -- prune the export list to just those declarations that have+  -- documentation, if the 'prune' option is on.+  let +    prunedExportItems+      | OptPrune `elem` opts = pruneExportItems exportItems+      | otherwise = exportItems+ +  return Interface {+    ifaceMod             = mdl,+    ifaceOrigFilename    = ghcFilename ghcMod,+    ifaceInfo            = ghcHaddockModInfo ghcMod,+    ifaceDoc             = ghcMbDoc ghcMod,+    ifaceRnDoc           = Nothing,+    ifaceOptions         = opts,+    ifaceLocals          = localNames,+    ifaceRnDocMap        = Map.empty,+    ifaceExportItems     = prunedExportItems,+    ifaceRnExportItems   = [],+    ifaceExports         = exportedNames,+    ifaceVisibleExports  = visibleNames, +    ifaceDeclMap         = declMap,+    ifaceSubMap          = mkSubMap declMap exportedNames,+    ifaceInstances       = ghcInstances ghcMod+  }+++-------------------------------------------------------------------------------+-- 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 []+  if Flag_HideModule (moduleString mdl) `elem` flags +    then return $ OptHide : opts+    else return opts+++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 other = tell ["Unrecognised option: " ++ other] >> return Nothing+++--------------------------------------------------------------------------------+-- Declarations+--------------------------------------------------------------------------------++-- | Make a sub map from a declaration map. Make sure we only include exported+-- names.+mkSubMap :: Map Name DeclInfo -> [Name] -> Map Name [Name]+mkSubMap declMap exports =+  Map.filterWithKey (\k _ -> k `elem` exports) (Map.map filterSubs declMap)+  where+    filterSubs (_, _, subs) = [ sub  | (sub, _) <- subs, sub `elem` exports ]+++-- Make a map from names to 'DeclInfo's. Exclude declarations that don't+-- have names (instances and stand-alone documentation comments). Include+-- subordinate names, but map them to their parent declarations. +mkDeclMap :: [DeclInfo] -> Map Name DeclInfo+mkDeclMap decls = Map.fromList . concat $+  [ (declName d, (parent, doc, subs)) : subDecls+  | (parent@(L _ d), doc, subs) <- decls +  , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]+  , not (isDocD d), not (isInstD d) ]+++declInfos :: [(Decl, Maybe Doc)] -> [DeclInfo]+declInfos decls = [ (parent, doc, subordinates d)+                  | (parent@(L _ d), doc) <- decls]+++subordinates :: HsDecl Name -> [(Name, Maybe Doc)]+subordinates (TyClD d) = classDataSubs d+subordinates _ = []+++classDataSubs :: TyClDecl Name -> [(Name, Maybe Doc)]+classDataSubs decl+  | isClassDecl decl = classSubs+  | isDataDecl  decl = dataSubs+  | otherwise        = []+  where+    classSubs = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ]+    dataSubs  = constrs ++ fields   +      where+        cons    = map unL $ tcdCons decl+        constrs = [ (unL $ con_name c, fmap unL $ con_doc c) | c <- cons ]+        fields  = [ (unL n, fmap unL doc)+                  | RecCon flds <- map con_details cons+                  , ConDeclField n _ doc <- flds ]+++-- All the sub declarations of a class (that we handle), ordered by+-- source location, with documentation attached if it exists. +classDecls :: TyClDecl Name -> [(Decl, Maybe Doc)]+classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass+++declsFromClass :: TyClDecl a -> [Located (HsDecl a)]+declsFromClass class_ = docs ++ defs ++ sigs ++ ats+  where +    docs = mkDecls tcdDocs DocD class_+    defs = mkDecls (bagToList . tcdMeths) ValD class_+    sigs = mkDecls tcdSigs SigD class_+    ats  = mkDecls tcdATs TyClD class_+++declName :: HsDecl a -> a+declName (TyClD d) = tcdName d+declName (ForD (ForeignImport n _ _)) = unLoc n+-- we have normal sigs only (since they are taken from ValBindsOut)+declName (SigD sig) = fromJust $ sigNameNoLoc sig+declName _ = error "unexpected argument to declName"+++-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists.+topDecls :: HsGroup Name -> [(Decl, Maybe Doc)] +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup+++filterOutInstances :: [(Located (HsDecl a), b, c)] -> [(Located (HsDecl a), b, c)]+filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d))+++-- | Take all declarations except pragmas, infix decls, rules and value+-- bindings from an 'HsGroup'.+declsFromGroup :: HsGroup Name -> [Decl]+declsFromGroup group_ = +  mkDecls 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_+  where+    typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs+    typesigs _ = 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)+++warnAboutFilteredDecls :: Module -> [(LHsDecl Name, b, c)] -> ErrMsgM ()+warnAboutFilteredDecls mdl decls = do+  let modStr = moduleString mdl+  let typeInstances =+        nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ]++  unless (null typeInstances) $+    tell $ nub [+      "Warning: " ++ modStr ++ ": Instances of type and data "+      ++ "families are not yet supported. Instances of the following families "+      ++ "will be filtered out:\n  " ++ (concat $ intersperse ", "+      $ map (occNameString . nameOccName) typeInstances) ]++  let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls+                                 , not (null ats) ]++  unless (null instances) $+    tell $ nub [+      "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. "+      ++ "These instances are affected:\n" ++ (concat $ intersperse ", " instances) ]+++--------------------------------------------------------------------------------+-- 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 :: [(Decl, Maybe Doc)] -> [(Decl, Maybe Doc)]+filterDecls decls = filter (isHandled . unL . fst) decls+  where+    isHandled (ForD (ForeignImport {})) = True+    isHandled (TyClD {}) = True+    isHandled (InstD {}) = True+    isHandled (SigD d) = isVanillaLSig (reL d)+    -- 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 :: [(Decl, Maybe Doc)] -> [(Decl, Maybe 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 isVanillaLSig $ 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 the docs and attach them to the right declaration.+collectDocs :: [Decl] -> [(Decl, (Maybe Doc))]+collectDocs = collect Nothing DocEmpty++collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))]+collect d doc_so_far [] =+   case d of+        Nothing -> []+        Just d0  -> finishedDoc d0 doc_so_far []++collect d doc_so_far (e:es) =+  case e of+    L _ (DocD (DocCommentNext str)) ->+      case d of+        Nothing -> collect d (docAppend doc_so_far str) es+        Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es)++    L _ (DocD (DocCommentPrev str)) -> collect d (docAppend doc_so_far str) es++    _ -> case d of+      Nothing -> collect (Just e) doc_so_far es+      Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es)+++finishedDoc :: Decl -> Doc -> [(Decl, (Maybe Doc))] -> [(Decl, (Maybe Doc))]+finishedDoc d DocEmpty rest = (d, Nothing) : rest+finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest+  where+    notDocDecl (L _ (DocD _)) = False+    notDocDecl _              = True+finishedDoc _ _ rest = rest+++{-+attachATs :: [IE Name] -> ([IE Name], [Name])+attachATs exports = +  where+    ats =   <- export ]+-}+++-- | 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+  :: ModuleMap+  -> Module			-- this module+  -> [Name]			-- exported names (orig)+  -> [DeclInfo]+  -> Map Name DeclInfo             -- maps local names to declarations+  -> [DocOption]+  -> Maybe [IE Name]+  -> Bool				-- --ignore-all-exports flag+  -> [Instance]+  -> InstIfaceMap+  -> ErrMsgM [ExportItem Name]++mkExportItems modMap this_mod exported_names decls declMap+              opts maybe_exps ignore_all_exports _ instIfaceMap+  | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts+    = everything_local_exported+  | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps)+  where++-- creating export items for intsances (unfinished experiment)+--    instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ]++    everything_local_exported =  -- everything exported+      return (fullContentsOfThisModule decls)+   ++    lookupExport (IEVar x) = declWith x+    lookupExport (IEThingAbs t) = declWith t+  --    | Just fam <- Map.lookup t famMap = absFam fam+  --    | otherwise = declWith t+ --     where+   --     absFam (Just (famDecl, doc), instances) = return $ [ ExportDecl famDecl doc [] ] ++ matchingInsts t+     --   absFam (Nothing, instances) =++    lookupExport (IEThingAll t)        = declWith t+    lookupExport (IEThingWith t _)     = declWith t+    lookupExport (IEModuleContents m)  = fullContentsOf m+    lookupExport (IEGroup lev doc)     = return [ ExportGroup lev "" doc ]+    lookupExport (IEDoc doc)           = return [ ExportDoc doc ] +    lookupExport (IEDocNamed str) = do+      r <- findNamedDoc str [ unL d | (d,_,_) <- decls ]+      case r of+        Nothing -> return []+        Just found -> return [ ExportDoc found ]++    declWith :: Name -> ErrMsgM [ ExportItem Name ]+    declWith t =+      case findDecl t of+        Just x@(decl,_,_) ->+          let declName_ =+                case getMainDeclBinder (unL decl) of+                  Just n -> n+                  Nothing -> error "declWith: should not happen"+          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 /= declName_,+                Just p <- find isExported (parents t $ unL decl) ->+                do tell [ +                     "Warning: " ++ moduleString this_mod ++ ": " +++                     pretty (nameOccName t) ++ " is exported separately but " +++                     "will be documented under " ++ pretty (nameOccName p) +++                     ". Consider exporting it together with its parent(s)" +++                     " for code clarity." ]+                   return []++              -- normal case+              | otherwise                          -> return [ mkExportDecl t x ]+        Nothing ->+          -- If we can't find the declaration, it must belong to another package.+          -- We return just the name of the declaration and try to get the subs+          -- from the installed interface of that package.+          case Map.lookup (nameModule t) instIfaceMap of+            Nothing -> return [ ExportNoDecl t [] ]+            Just iface ->+              let subs = case Map.lookup t (instSubMap iface) of+                           Nothing -> []+                           Just x -> x+              in return [ ExportNoDecl t subs ]++    mkExportDecl :: Name -> DeclInfo -> ExportItem Name+    mkExportDecl n (decl, doc, subs) = decl'+      where+        decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' []+        mdl = nameModule n+        subs' = filter ((`elem` exported_names) . fst) subs+        sub_names = map fst subs'++    isExported n = n `elem` exported_names++    fullContentsOf modname+	| m == this_mod = return (fullContentsOfThisModule decls)+	| otherwise = +	   case Map.lookup m modMap 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 Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of+                 Just iface -> return [ ExportModule (instMod iface) ]+                 Nothing -> do+                   tell ["Warning: " ++ pretty this_mod ++ ": Could not find " +++                         "documentation for exported module: " ++ pretty modname]+                   return []+      where+        m = mkModule packageId modname+        packageId = modulePackageId this_mod++    +    findDecl :: Name -> Maybe DeclInfo+    findDecl n +      | m == this_mod = Map.lookup n declMap+      | otherwise = case Map.lookup m modMap of+                      Just iface -> Map.lookup n (ifaceDeclMap iface) +                      Nothing -> Nothing+      where+        m = nameModule n+++-- 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)+++fullContentsOfThisModule :: [DeclInfo] -> [ExportItem Name]+fullContentsOfThisModule decls = catMaybes (map mkExportItem decls)+  where+    mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc+    mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _)   = Just $ ExportDoc doc+    mkExportItem (decl, doc, subs) = Just $ ExportDecl decl doc subs []++--    mkExportItem _ = Nothing -- TODO: see if this is really needed+++-- | 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 -> Decl -> Decl+extractDecl name mdl decl+  | Just n <- getMainDeclBinder (unLoc decl), n == name = decl+  | otherwise  =  +    case unLoc decl of+      TyClD d | isClassDecl d -> +        let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name,+                        isVanillaLSig sig ] -- TODO: document fixity+--        let assocMathes = [ tyDecl | at <- tcdATs d,  ] +        in case matches of +          [s0] -> let (n, tyvar_names) = name_and_tyvars d+                      L pos sig = extractClassDecl n tyvar_names s0+                  in L pos (SigD sig)+          _ -> error "internal: extractDecl" +      TyClD d | isDataDecl d -> +        let (n, tyvar_names) = name_and_tyvars d+            L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)+        in L pos (SigD sig)+      _ -> error "internal: extractDecl"+  where+    name_and_tyvars d = (unLoc (tcdLName d), hsLTyVarLocNames (tcdTyVars d))+++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 (mkImplicitHsForAllTy (lctxt []) ltype)))+  where+    lctxt = noLoc . ctxt+    ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds  +extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"+++extractRecSel :: Name -> Module -> Name -> [Located 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 = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs)+++-- Pruning+pruneExportItems :: [ExportItem Name] -> [ExportItem Name]+pruneExportItems items = filter hasDoc items+  where hasDoc (ExportDecl _ d _ _) = isJust d+	hasDoc _ = True+++mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name]+mkVisibleNames exports opts+  | OptHide `elem` opts = []+  | otherwise = concatMap exportName exports+  where+    exportName e@ExportDecl {} =+      case getMainDeclBinder $ unL $ expItemDecl e of+        Just n -> n : subs+        Nothing -> subs+      where subs = map fst (expItemSubDocs e) +    exportName ExportNoDecl {} = [] -- we don't count these as visible, since+                                    -- we don't want links to go to them.+    exportName _ = []+++-- | Find a stand-alone documentation comment by its name+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe Doc)+findNamedDoc name decls = search decls+  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/Rename.hs view
@@ -0,0 +1,447 @@+----------------------------------------------------------------------------+-- |+-- 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 Haddock.Types+import Haddock.GhcUtils++import GHC hiding (NoLink)+import Name+import BasicTypes+import Bag (emptyBag)++import Data.List+import qualified Data.Map as Map hiding ( Map )+import Prelude hiding (mapM)+import Data.Traversable (mapM)+import Control.Monad hiding (mapM)+++renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface+renameInterface 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++      docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface)+      docs   = [ (n, doc) | (n, Just doc) <- Map.toList docMap ]+      renameMapElem (k,d) = do d' <- renameDoc d; return (k, d')++      -- 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 (liftM Map.fromList (mapM renameMapElem docs))++      (finalModuleDoc, missingNames3)+        = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface))++      -- combine the missing names and filter out the built-ins, which would+      -- otherwise allways be missing.+      missingNames = nub $ filter isExternalName+                    (missingNames1 ++ missingNames2 ++ missingNames3)++      -- 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 . 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,+                     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 GenRnM n a =+  RnM { unRn :: (n -> (Bool, DocName))  -- name lookup function+             -> (a,[n])+      }++type RnM a = GenRnM Name a++instance Monad (GenRnM n) where+  (>>=) = thenRn+  return = returnRn++returnRn :: a -> GenRnM n a+returnRn a   = RnM (const (a,[]))+thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n 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 :: (DocName -> a) -> Name -> RnM a+lookupRn and_then name = do+  lkp <- getLookupRn+  case lkp name of+    (False,maps_to) -> do outRn name; return (and_then maps_to)+    (True, maps_to) -> return (and_then 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 id+++renameL :: Located Name -> RnM (Located DocName)+renameL = mapM rename+++renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]+renameExportItems = mapM renameExportItem+++renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))+renameMaybeDoc = mapM renameDoc+++renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName)+renameLDoc = mapM renameDoc+++renameDoc :: HsDoc Name -> RnM (HsDoc DocName)+renameDoc d = case d of+  DocEmpty -> return DocEmpty+  DocAppend a b -> do+    a' <- renameDoc a+    b' <- renameDoc b+    return (DocAppend a' b')+  DocString str -> return (DocString str)+  DocParagraph doc -> do+    doc' <- renameDoc doc+    return (DocParagraph doc')+  DocIdentifier ids -> do+    lkp <- getLookupRn+    case [ n | (True, n) <- map lkp ids ] of+      ids'@(_:_) -> return (DocIdentifier ids')+      [] -> return (DocIdentifier (map Undocumented ids))+  DocModule str -> return (DocModule str)+  DocEmphasis doc -> do+    doc' <- renameDoc doc+    return (DocEmphasis doc')+  DocMonospaced doc -> do+    doc' <- renameDoc doc+    return (DocMonospaced doc')+  DocUnorderedList docs -> do+    docs' <- mapM renameDoc docs+    return (DocUnorderedList docs')+  DocOrderedList docs -> do+    docs' <- mapM renameDoc docs+    return (DocOrderedList docs')+  DocDefList docs -> do+    docs' <- mapM (\(a,b) -> do+      a' <- renameDoc a+      b' <- renameDoc b+      return (a',b')) docs+    return (DocDefList docs')+  DocCodeBlock doc -> do+    doc' <- renameDoc doc+    return (DocCodeBlock doc')+  DocURL str -> return (DocURL str)+  DocPic str -> return (DocPic str)+  DocAName str -> return (DocAName str)+++renameLPred :: LHsPred Name -> RnM (LHsPred DocName)+renameLPred = mapM renamePred+++renamePred :: HsPred Name -> RnM (HsPred DocName)+renamePred (HsClassP name types) = do+  name'  <- rename name+  types' <- mapM renameLType types+  return (HsClassP name' types')+renamePred (HsEqualP type1 type2) = do+  type1' <- renameLType type1+  type2' <- renameLType type2+  return (HsEqualP type1' type2')+renamePred (HsIParam (IPName name) t) = do+  name' <- rename name+  t'    <- renameLType t+  return (HsIParam (IPName name') t')+++renameLType :: LHsType Name -> RnM (LHsType DocName)+renameLType = mapM renameType+++renameType :: HsType Name -> RnM (HsType DocName)+renameType t = case t of+  HsForAllTy expl tyvars lcontext ltype -> do+    tyvars'   <- mapM renameLTyVarBndr 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++  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts++  HsOpTy a (L loc op) b -> do+    op' <- rename op+    a'  <- renameLType a+    b'  <- renameLType b+    return (HsOpTy a' (L loc op') b')++  HsParTy ty -> return . HsParTy =<< renameLType ty++  HsNumTy n -> return (HsNumTy n)++  HsPredTy p -> return . HsPredTy =<< renamePred p++  HsKindSig ty k -> do+    ty' <- renameLType ty+    return (HsKindSig ty' k)++  HsDocTy ty doc -> do+    ty' <- renameLType ty+    doc' <- renameLDoc doc+    return (HsDocTy ty' doc')++  _ -> error "renameType"+++renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)+renameLTyVarBndr (L loc tv) = do+  name' <- rename (hsTyVarName tv)+  return $ L loc (replaceTyVarName tv name')+++renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName])+renameLContext (L loc context) = do+  context' <- mapM renameLPred context+  return (L loc context')+++renameInstHead :: InstHead Name -> RnM (InstHead DocName)+renameInstHead (preds, className, types) = do+  preds' <- mapM renamePred preds+  className' <- rename className+  types' <- mapM renameType types+  return (preds', className', types')+++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"+++renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName)+renameLTyClD (L loc d) = return . L loc =<< renameTyClD d+++renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)+renameTyClD d = case d of+#if __GLASGOW_HASKELL__ >= 611+  ForeignType lname b -> do+    lname' <- renameL lname+    return (ForeignType lname' b)+#else+  ForeignType lname a b -> do+    lname' <- renameL lname+    return (ForeignType lname' a b)+#endif++  TyFamily flav lname ltyvars kind -> do+    lname'   <- renameL lname+    ltyvars' <- mapM renameLTyVarBndr ltyvars+    return (TyFamily flav lname' ltyvars' kind)++  TyData x lcontext lname ltyvars typats k cons _ -> do+    lcontext' <- renameLContext lcontext+    lname'    <- renameL lname+    ltyvars'  <- mapM renameLTyVarBndr ltyvars+    typats'   <- mapM (mapM renameLType) typats+    cons'     <- mapM renameLCon cons+    -- I don't think we need the derivings, so we return Nothing+    return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing)++  TySynonym lname ltyvars typats ltype -> do+    lname'   <- renameL lname+    ltyvars' <- mapM renameLTyVarBndr ltyvars+    ltype'   <- renameLType ltype+    typats'  <- mapM (mapM renameLType) typats+    return (TySynonym lname' ltyvars' typats' ltype')++  ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do+    lcontext' <- renameLContext lcontext+    lname'    <- renameL lname+    ltyvars'  <- mapM renameLTyVarBndr ltyvars+    lfundeps' <- mapM renameLFunDep lfundeps+    lsigs'    <- mapM renameLSig lsigs+    ats'      <- mapM renameLTyClD ats+    -- we don't need the default methods or the already collected doc entities+    return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' [])++  where+    renameLCon (L loc con) = return . L loc =<< renameCon con+    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'  <- mapM renameLTyVarBndr ltyvars+      lcontext' <- renameLContext lcontext+      details'  <- renameDetails details+      restype'  <- renameResType restype+      mbldoc'   <- mapM renameLDoc mbldoc+      return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'+                   , con_details = details', con_res = restype', con_doc = mbldoc' })++    renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields+    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps+    renameDetails (InfixCon a b) = do+      a' <- renameLType a+      b' <- renameLType b+      return (InfixCon a' b')++    renameField (ConDeclField name t doc) = do+      name' <- renameL name+      t'   <- renameLType t+      doc' <- mapM renameLDoc doc+      return (ConDeclField name' t' doc')++    renameResType (ResTyH98) = return ResTyH98+    renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t++    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+++renameSig :: Sig Name -> RnM (Sig DocName)+renameSig sig = case sig of+  TypeSig lname ltype -> do+    lname' <- renameL lname+    ltype' <- renameLType ltype+    return (TypeSig lname' ltype')+  -- 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 x) = do+  lname' <- renameL lname+  ltype' <- renameLType ltype+  return (ForeignImport lname' ltype' x)+renameForD (ForeignExport lname ltype x) = do+  lname' <- renameL lname+  ltype' <- renameLType ltype+  return (ForeignExport lname' ltype' x)+++renameInstD :: InstDecl Name -> RnM (InstDecl DocName)+renameInstD (InstDecl ltype _ _ lATs) = do+  ltype' <- renameLType ltype+  lATs' <- mapM renameLTyClD lATs+  return (InstDecl ltype' emptyBag [] lATs')+++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 -> do+    decl' <- renameLDecl decl+    doc'  <- mapM renameDoc doc+    subs' <- mapM renameSub subs+    instances' <- mapM renameInstHead instances+    return (ExportDecl decl' doc' subs' instances')+  ExportNoDecl x subs -> do+    x'    <- lookupRn id x+    subs' <- mapM (lookupRn id) subs+    return (ExportNoDecl x' subs')+  ExportDoc doc -> do+    doc' <- renameDoc doc+    return (ExportDoc doc')+++renameSub :: (Name, Maybe (HsDoc Name)) -> RnM (DocName, Maybe (HsDoc DocName))+renameSub (n,doc) = do+  n' <- rename n+  doc' <- mapM renameDoc doc+  return (n', doc')
+ src/Haddock/InterfaceFile.hs view
@@ -0,0 +1,526 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.InterfaceFile+-- Copyright   :  (c) David Waern 2006-2009+-- License     :  BSD-like+--+-- Maintainer  :  haddock@projects.haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Reading and writing the .haddock interface file+-----------------------------------------------------------------------------++module Haddock.InterfaceFile (+  InterfaceFile(..),+  readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,+  writeInterfaceFile+) where+++import Haddock.Types+import Haddock.Utils hiding (out)++import Data.List+import Data.Word+import Data.Array+import Data.IORef+import qualified Data.Map as Map++import GHC hiding (NoLink)+import Binary+import Name+import UniqSupply+import UniqFM+import IfaceEnv+import HscTypes+import FastMutInt+#if __GLASGOW_HASKELL__ >= 609 +import FastString+import Unique+#endif++data InterfaceFile = InterfaceFile {+  ifLinkEnv         :: LinkEnv,+  ifInstalledIfaces :: [InstalledInterface]+} +++binaryInterfaceMagic :: Word32+binaryInterfaceMagic = 0xD0Cface+++-- 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.+binaryInterfaceVersion :: Word16+#if __GLASGOW_HASKELL__ == 610+binaryInterfaceVersion = 12+#elif __GLASGOW_HASKELL__ == 611+binaryInterfaceVersion = 13+#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+#if __GLASGOW_HASKELL__ >= 609+  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 }+  ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)+#else+  ud <- newWriteState+#endif++  -- put the main thing+  bh <- return $ setUserData bh0 ud+  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+#if __GLASGOW_HASKELL__ >= 609+  symtab_next' <- readFastMutInt symtab_next+  symtab_map'  <- readIORef symtab_map+#else+  symtab_next' <- readFastMutInt (ud_symtab_next ud)+  symtab_map'  <- readIORef (ud_symtab_map ud)+#endif+  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+#if __GLASGOW_HASKELL__ >= 609+  dict_next <- readFastMutInt dict_next_ref+  dict_map  <- readIORef dict_map_ref+#else+  dict_next <- readFastMutInt (ud_dict_next ud)+  dict_map  <- readIORef (ud_dict_map ud)+#endif+  putDictionary bh dict_next dict_map++  -- and send the result to the file+  writeBinMem bh filename+  return ()++type NameCacheAccessor m = (m NameCache, NameCache -> m ())+++#if __GLASGOW_HASKELL__ >= 609+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'+#else+nameCacheFromGhc :: Session -> NameCacheAccessor IO+nameCacheFromGhc session = ( read_from_session , write_to_session )+  where+    read_from_session = readIORef . hsc_NC =<< sessionHscEnv session+    write_to_session nc' = do+      ref <- liftM hsc_NC $ sessionHscEnv session+      writeIORef ref nc'+#endif+++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 :: 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 /= binaryInterfaceVersion -> return . Left $+      "Interface file is of wrong version: " ++ filename+      | otherwise -> do++      dict  <- get_dictionary bh0+      bh1   <- init_handle_user_data bh0 dict++      theNC <- get_name_cache+      (nc', symtab) <- get_symbol_table bh1 theNC+      set_name_cache nc'++      -- set the symbol table+      let ud' = getUserData bh1+      bh2 <- return $! setUserData bh1 ud'{ud_symtab = symtab}++      -- load the actual data+      iface <- liftIO $ get bh2+      return (Right iface)+ where+   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++   init_handle_user_data bin_handle dict = liftIO $ do+      ud <- newReadState dict+      return (setUserData bin_handle ud)++   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+-------------------------------------------------------------------------------+++#if __GLASGOW_HASKELL__ >= 609+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 off+      Nothing -> do+         off <- readFastMutInt symtab_next+         writeFastMutInt symtab_next (off+1)+         writeIORef symtab_map_ref+             $! addToUFM symtab_map name (off,name)+         put_ bh off+++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 j+        Nothing -> do+           j <- readFastMutInt j_r+           put_ bh j+           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+  }+#endif+++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 <- sequence (replicate 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 Binary InterfaceFile where+  put_ bh (InterfaceFile env ifaces) = do+    put_ bh (Map.toList env)+    put_ bh ifaces++  get bh = do+    env    <- get bh+    ifaces <- get bh+    return (InterfaceFile (Map.fromList env) ifaces)+++instance Binary InstalledInterface where+  put_ bh (InstalledInterface modu info docMap exps visExps opts subMap) = do+    put_ bh modu+    put_ bh info+    put_ bh (Map.toList docMap)+    put_ bh exps+    put_ bh visExps+    put_ bh opts+    put_ bh (Map.toList subMap)++  get bh = do+    modu    <- get bh+    info    <- get bh+    docMap  <- get bh+    exps    <- get bh+    visExps <- get bh+    opts    <- get bh+    subMap  <- get bh+    +    return (InstalledInterface modu info (Map.fromList docMap)+            exps visExps opts (Map.fromList subMap))+++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+    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+              _ -> fail "invalid binary data found"+++{-* Generated by DrIFT : Look, but Don't Touch. *-}+instance (Binary id) => Binary (HsDoc 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 (DocURL 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+    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 (DocURL am)+              13 -> do+                    x <- get bh+                    return (DocPic x)+              14 -> do+                    an <- get bh+                    return (DocAName an)+              _ -> fail "invalid binary data found"+++instance Binary name => Binary (HaddockModInfo name) where+  put_ bh hmi = do+    put_ bh (hmi_description hmi)+    put_ bh (hmi_portability hmi)+    put_ bh (hmi_stability   hmi)+    put_ bh (hmi_maintainer  hmi)+  +  get bh = do+    descr <- get bh+    porta <- get bh+    stabi <- get bh+    maint <- get bh+    return (HaddockModInfo descr porta stabi maint)+++instance Binary DocName where+  put_ bh (Documented name modu) = do+    putByte bh 0+    put_ bh name+    put_ bh modu+  put_ bh (Undocumented name) = do+    putByte bh 1+    put_ bh name++  get bh = do+    h <- getByte bh+    case h of+      0 -> do+        name <- get bh+        modu <- get bh+        return (Documented name modu)+      1 -> do+        name <- get bh+        return (Undocumented name)+      _ -> error "get DocName: Bad h"+
+ src/Haddock/ModuleTree.hs view
@@ -0,0 +1,53 @@+-----------------------------------------------------------------------------+-- |+-- 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 GHC           ( HsDoc, Name )+import Module        ( Module, moduleNameString, moduleName, modulePackageId )+#if __GLASGOW_HASKELL__ >= 609+import Module (packageIdString)+#else+import PackageConfig (packageIdString)+#endif++data ModuleTree = Node String Bool (Maybe String) (Maybe (HsDoc Name)) [ModuleTree]++mkModuleTree :: Bool -> [(Module, Maybe (HsDoc 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) trees = addToTrees mod_ pkg short trees++addToTrees :: [String] -> Maybe String -> Maybe (HsDoc 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 (HsDoc Name) -> [ModuleTree]+mkSubTree []     _   _     = []+mkSubTree [s]    pkg short = [Node s True pkg short []]+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]++splitModule :: Module -> [String]+splitModule mdl = split (moduleNameString (moduleName mdl))+  where split mod0 = case break (== '.') mod0 of+     			(s1, '.':s2) -> s1 : split s2+     			(s1, _)      -> [s1]
+ src/Haddock/Options.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Options+-- Copyright   :  (c) Simon Marlow 2003-2006,+--                    David Waern  2006-2009+-- 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,+  ghcFlags,+  ifacePairs+) where+++import Haddock.Utils+import Haddock.Types+import System.Console.GetOpt +++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)+++ghcFlags :: [Flag] -> [String]+ghcFlags flags = [ option | Flag_OptGhc option <- flags ]+++ifacePairs :: [Flag] -> [(FilePath, FilePath)]+ifacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]+++parseIfaceOption :: String -> (FilePath, FilePath)+parseIfaceOption s = +  case break (==',') s of+	(fpath,',':file) -> (fpath, file)+	(file, _)        -> ("", file)+++data Flag+  = Flag_CSS String+  | Flag_Debug+--  | Flag_DocBook+  | Flag_ReadInterface String+  | Flag_DumpInterface String+  | Flag_Heading String+  | Flag_Html+  | Flag_Hoogle+  | Flag_HtmlHelp String+  | Flag_Lib String+  | Flag_OutputDir FilePath+  | Flag_Prologue FilePath+  | Flag_SourceBaseURL   String+  | Flag_SourceModuleURL String+  | Flag_SourceEntityURL String+  | Flag_WikiBaseURL   String+  | Flag_WikiModuleURL String+  | Flag_WikiEntityURL String+  | Flag_Help+  | Flag_Verbosity String+  | Flag_Version+  | Flag_UseContents String+  | Flag_GenContents+  | Flag_UseIndex String+  | Flag_GenIndex+  | Flag_IgnoreAllExports+  | Flag_HideModule String+  | Flag_OptGhc String+  | Flag_GhcLibDir String+  | Flag_GhcVersion+  | Flag_NoWarnings+  | Flag_UseUnicode+  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") +  "interface file name",+--    Option ['S']  ["docbook"]  (NoArg Flag_DocBook)+--	"output in DocBook XML",+    Option ['h']  ["html"]     (NoArg Flag_Html)+	"output in HTML",+    Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",+    Option []  ["hoogle"]     (NoArg Flag_Hoogle)+    "output for Hoogle",+    Option []  ["html-help"]    (ReqArg Flag_HtmlHelp "format")+	"produce index and table of contents in\nmshelp, mshelp2 or devhelp format (with -h)",+    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 []  ["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"]         (ReqArg Flag_CSS "FILE") +	"the CSS file to use for HTML output",+    Option ['p']  ["prologue"] (ReqArg Flag_Prologue "FILE")+	"file containing prologue text",+    Option ['t']  ["title"]    (ReqArg Flag_Heading "TITLE")+	"page heading",+    Option ['d']  ["debug"]  (NoArg Flag_Debug)+	"extra debugging output",+    Option ['?']  ["help"]  (NoArg Flag_Help)+	"display this help and exit",+    Option ['V']  ["version"]  (NoArg Flag_Version)+	"output version information 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 [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")+ 	"option to be forwarded to GHC",+    Option []  ["ghc-version"]  (NoArg Flag_GhcVersion)+	"output GHC version in numeric format",+    Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings"+   ]
+ src/Haddock/Types.hs view
@@ -0,0 +1,294 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Haddock.Types+-- Copyright   :  (c) Simon Marlow 2003-2006,+--                    David Waern  2006-2009+-- 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 where+++import Control.Exception+import Data.Typeable+import Data.Map (Map)+import GHC hiding (NoLink)+import Name+++-- convenient short-hands+type Decl = LHsDecl Name+type Doc  = HsDoc Name+++-- | A declaration that may have documentation, including its subordinates,+-- which may also have documentation+type DeclInfo = (Decl, Maybe Doc, [(Name, Maybe Doc)])+++-- | A 'DocName' is an identifier that may be documented. The 'Module'+-- component specifies the place which we want to link to in the documentation.+data DocName = Documented Name Module | Undocumented Name+  deriving Eq+++-- | The 'OccName' belonging to this name+docNameOcc :: DocName -> OccName+docNameOcc = nameOccName . getName+++instance NamedThing DocName where+  getName (Documented name _) = name+  getName (Undocumented name) = name+++{-! for DocOption derive: Binary !-}+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.+  deriving (Eq, Show)+++data ExportItem name++  = ExportDecl {		  		+	+      -- | A declaration+      expItemDecl :: LHsDecl name, +			       +      -- | Maybe a doc comment+      expItemMbDoc :: Maybe (HsDoc name),++      -- | Subordinate names, possibly with documentation+      expItemSubDocs :: [(name, Maybe (HsDoc name))],++      -- | Instances relevant to this declaration+      expItemInstances :: [InstHead name]+	+	  }	-- ^ An exported declaration +		    +  | ExportNoDecl {+      expItemName :: name,++      -- | Subordinate names+      expItemSubs :: [name]++		} -- ^ An exported entity for which we have no +          -- documentation (perhaps because it resides in+          -- another package)++  | ExportGroup { ++      -- | Section level (1, 2, 3, ... )+      expItemSectionLevel :: Int,++      -- | Section id (for hyperlinks)+      expItemSectionId :: String,     +			+      -- | Section heading text+      expItemSectionText :: HsDoc name++    } -- ^ A section heading++  | ExportDoc (HsDoc name) -- ^ Some documentation++  | ExportModule Module    -- ^ A cross-reference to another module+++type InstHead name = ([HsPred name], name, [HsType name])+type ModuleMap     = Map Module Interface+type InstIfaceMap  = Map Module InstalledInterface+type DocMap        = Map Name (HsDoc DocName)+type LinkEnv       = Map Name Module+++-- | This structure holds the module information we get from GHC's +-- type checking phase+data GhcModule = GhcModule {+   ghcModule         :: Module,+   ghcFilename       :: FilePath,+   ghcMbDocOpts      :: Maybe String,+   ghcHaddockModInfo :: HaddockModInfo Name,+   ghcMbDoc          :: Maybe (HsDoc Name),+   ghcGroup          :: HsGroup Name,+   ghcMbExports      :: Maybe [LIE Name],+   ghcExportedNames  :: [Name],+   ghcDefinedNames   :: [Name],+   ghcNamesInScope   :: [Name],+   ghcInstances      :: [Instance]+}+++-- | This is the data structure used to render a Haddock page for a module - it+-- is the "interface" of the module. The core of Haddock lies in creating this +-- structure (see Haddock.Interface). The structure also holds intermediate+-- data needed during its creation.+data Interface = Interface {++  -- | The module represented by this interface+  ifaceMod             :: Module,++  -- | The original filename for this module+  ifaceOrigFilename    :: FilePath,++  -- | Textual information about the module +  ifaceInfo            :: !(HaddockModInfo Name),++  -- | The documentation header for this module+  ifaceDoc             :: !(Maybe (HsDoc Name)),++  -- | The renamed documentation header for this module+  ifaceRnDoc           :: Maybe (HsDoc DocName),++  -- | The Haddock options for this module (prune, ignore-exports, etc)+  ifaceOptions         :: ![DocOption],++  -- | The declarations of the module.  Excludes declarations that don't+  -- have names (instances and stand-alone documentation comments). Includes+  -- subordinate names, but they are mapped to their parent declarations.+  ifaceDeclMap         :: Map Name DeclInfo,++  -- | Everything declared in the module (including subordinates) that has docs+  ifaceRnDocMap        :: Map Name (HsDoc DocName),++  ifaceSubMap          :: Map Name [Name],++  ifaceExportItems     :: ![ExportItem Name],+  ifaceRnExportItems   :: [ExportItem DocName],++  -- | All names defined in this module+  ifaceLocals          :: ![Name],++  -- | All names exported by this module+  ifaceExports         :: ![Name],++  -- | All the visible names exported by this module+  -- For a name to be visible, it has to:+  --+  --  * be exported normally, and not via a full module re-exportation.+  --+  --  * have a declaration in this module or any of it's imports, with the+  --    exception that it can't be from another package.+  --+  -- Basically, a visible name is a name that will show up in the documentation+  -- for this module.+  ifaceVisibleExports  :: ![Name],++  -- | The instances exported by this module+  ifaceInstances       :: ![Instance]+}+++-- | A smaller version of 'Interface' that we can get from the Haddock+-- interface files.+data InstalledInterface = InstalledInterface {++  -- | The module represented by this interface+  instMod            :: Module,++  -- | Textual information about the module +  instInfo           :: HaddockModInfo Name,++  -- | Everything declared in the module (including subordinates) that has docs+  instDocMap         :: Map Name (HsDoc DocName),++  -- | All names exported by this module+  instExports        :: [Name],++  -- | All the visible names exported by this module+  -- For a name to be visible, it has to:+  --+  --  * be exported normally, and not via a full module re-exportation.+  --+  --  * have a declaration in this module or any of it's imports, with the+  --    exception that it can't be from another package.+  --+  -- Basically, a visible name is a name that will show up in the documentation+  -- for this module.+  instVisibleExports :: [Name],++  -- | The Haddock options for this module (prune, ignore-exports, etc)+  instOptions        :: [DocOption],++  instSubMap         :: Map Name [Name]+}+++-- | Convert an 'Interface' to an 'InstalledInterface'+toInstalledIface :: Interface -> InstalledInterface+toInstalledIface interface = InstalledInterface {+  instMod            = ifaceMod            interface,+  instInfo           = ifaceInfo           interface,+  instDocMap         = ifaceRnDocMap       interface,+  instExports        = ifaceExports        interface,+  instVisibleExports = ifaceVisibleExports interface,+  instOptions        = ifaceOptions        interface,+  instSubMap         = ifaceSubMap         interface+}+++data DocMarkup id a = Markup {+  markupEmpty         :: a,+  markupString        :: String -> a,+  markupParagraph     :: a -> a,+  markupAppend        :: a -> a -> a,+  markupIdentifier    :: [id] -> a,+  markupModule        :: String -> a,+  markupEmphasis      :: a -> a,+  markupMonospaced    :: a -> a,+  markupUnorderedList :: [a] -> a,+  markupOrderedList   :: [a] -> a,+  markupDefList       :: [(a,a)] -> a,+  markupCodeBlock     :: a -> a,+  markupURL           :: String -> a,+  markupAName         :: String -> a,+  markupPic           :: String -> a+}+++-- 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 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+#if __GLASGOW_HASKELL__ >= 609+instance Exception HaddockException+throwE str = throw (HaddockException str)+#else+throwE str = throwDyn (HaddockException str)+#endif
+ src/Haddock/Utils.hs view
@@ -0,0 +1,389 @@+-----------------------------------------------------------------------------+-- |+-- 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, +  toDescription, toInstalledDescription,++  -- * Filename utilities+  moduleHtmlFile, nameHtmlRef,+  contentsHtmlFile, indexHtmlFile,+  frameIndexHtmlFile,+  moduleIndexFrameName, mainFrameName, synopsisFrameName,+  subIndexHtmlFile, pathJoin,+  anchorNameStr,+  cssFile, iconFile, jsFile, plusFile, minusFile, framesFile,++  -- * Miscellaneous utilities+  getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,+ +  -- * HTML cross reference mapping+  html_xrefs_ref,++  -- * HsDoc markup +  markup, +  idMarkup,++  -- * List utilities+  replace,++  -- * Binary extras+--  FormatVersion, mkFormatVersion  +  +  -- * MTL stuff+  MonadIO(..),+  +  -- * Logging+  parseVerbosity,+  out+ ) where++import Haddock.Types+import Haddock.GhcUtils++import GHC+import Name+import Binary++import Control.Monad ( liftM )+import Data.Char ( isAlpha, 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 ( fromJust )+import Data.Word ( Word8 )+import Data.Bits ( testBit )+import System.Environment ( getProgName )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO ( hPutStr, stderr )+import System.IO.Unsafe	 ( unsafePerformIO )+import System.FilePath+import Distribution.Verbosity+import Distribution.ReadE++#if __GLASGOW_HASKELL__ >= 609+import MonadUtils ( MonadIO(..) )+#else+class Monad m => MonadIO m where+    liftIO :: IO a -> m a                                              +instance MonadIO IO where liftIO = id+#endif+++-- -----------------------------------------------------------------------------+-- 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 (HsDoc Name)+toDescription = hmi_description . ifaceInfo++-- | extract a module's short description.+toInstalledDescription :: InstalledInterface -> Maybe (HsDoc 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 && tcdND d == DataType -> +    TyClD (d { tcdCons = restrictCons names (tcdCons d) }) +  TyClD d | isDataDecl d && tcdND d == NewType -> +    case restrictCons names (tcdCons d) of+      []    -> TyClD (d { tcdND = DataType, tcdCons = [] }) +      [con] -> TyClD (d { tcdCons = [con] })+      _ -> error "Should not happen"+  TyClD d | isClassDecl d -> +    TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),+               tcdATs = restrictATs names (tcdATs d) })+  _ -> decl+   +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 _ | otherwise = Nothing++restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]+restrictDecls names decls = filter keep decls+  where keep d = fromJust (sigName d) `elem` names+        -- has to have a name, since it's a class method type signature+++restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]+restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]+++-- -----------------------------------------------------------------------------+-- Filename mangling functions stolen from s main/DriverUtil.lhs.++moduleHtmlFile :: Module -> FilePath+moduleHtmlFile mdl =+  case Map.lookup mdl html_xrefs of+    Nothing  -> mdl' ++ ".html"+    Just fp0 -> pathJoin [fp0, mdl' ++ ".html"]+  where+   mdl' = map (\c -> if c == '.' then '-' else c) +              (moduleNameString (moduleName mdl))++nameHtmlRef :: Module -> OccName -> String	+nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n)++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 :: Char -> String+subIndexHtmlFile a = "doc-index-" ++ b ++ ".html"+   where b | isAlpha a = [a]+           | otherwise = show (ord a)++anchorNameStr :: OccName -> String+anchorNameStr name | isValOcc name = "v:" ++ occNameString name +                   | otherwise     = "t:" ++ occNameString name++pathJoin :: [FilePath] -> FilePath+pathJoin = foldr join []+  where join :: FilePath -> FilePath -> FilePath+        join path1 ""    = path1+	join ""    path2 = path2+	join path1 path2+          | isPathSeparator (last path1) = path1++path2+          | otherwise                    = path1++pathSeparator:path2++-- -----------------------------------------------------------------------------+-- Files we need to copy from our $libdir++cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String+cssFile   = "haddock.css"+iconFile  = "haskell_icon.gif"+jsFile    = "haddock-util.js"+plusFile  = "plus.gif"+minusFile = "minus.gif"+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 >> exitWith 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 #-}+html_xrefs :: Map Module 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) +++-----------------------------------------------------------------------------+-- put here temporarily++markup :: DocMarkup id a -> HsDoc 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 ids)   = markupIdentifier m ids+markup m (DocModule mod0)      = markupModule m mod0+markup m (DocEmphasis d)       = markupEmphasis 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 (DocURL url)          = markupURL m url+markup m (DocAName ref)        = markupAName m ref+markup m (DocPic img)          = markupPic m img++markupPair :: DocMarkup id a -> (HsDoc id, HsDoc id) -> (a, a)+markupPair m (a,b) = (markup m a, markup m b)++-- | The identity markup+idMarkup :: DocMarkup a (HsDoc a)+idMarkup = Markup {+  markupEmpty         = DocEmpty,+  markupString        = DocString,+  markupParagraph     = DocParagraph,+  markupAppend        = DocAppend,+  markupIdentifier    = DocIdentifier,+  markupModule        = DocModule,+  markupEmphasis      = DocEmphasis,+  markupMonospaced    = DocMonospaced,+  markupUnorderedList = DocUnorderedList,+  markupOrderedList   = DocOrderedList,+  markupDefList       = DocDefList,+  markupCodeBlock     = DocCodeBlock,+  markupURL           = DocURL,+  markupAName         = DocAName,+  markupPic           = DocPic+  }+++-----------------------------------------------------------------------------+-- put here temporarily++newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)++nullFormatVersion :: FormatVersion+nullFormatVersion = mkFormatVersion 0++mkFormatVersion :: Int -> FormatVersion+mkFormatVersion = FormatVersion++instance Binary FormatVersion where+   put_ bh (FormatVersion i) =+      case compare i 0 of+         EQ -> return ()+         GT -> put_ bh (-i)+         LT -> error (+            "Binary.hs: negative FormatVersion " ++ show i +               ++ " is not allowed")+   get bh =+      do+         (w8 :: Word8) <- get bh   +         if testBit w8 7+            then+               do+                  i <- get bh+                  return (FormatVersion (-i))+            else+               return nullFormatVersion
+ src/Haddock/Utils/BlockTable.hs view
@@ -0,0 +1,180 @@+{- | ++  Module      :  Text.Html.BlockTable+  Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of +                 Science and Technology, 1999-2001+  License     :  BSD-style (see the file libraries/core/LICENSE)+ +  Maintainer  :  Andy Gill <andy@galconn.com>+  Stability   :  experimental+  Portability :  portable++  $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $++  An Html combinator library++-}++module Haddock.Utils.BlockTable (++-- Datatypes:++      BlockTable,             -- abstract++-- Contruction Functions: ++      single,+      empty,+      above,+      beside,++-- Investigation Functions: ++      getMatrix,+      showsTable,+      showTable,++      ) where++import Prelude++infixr 4 `beside`+infixr 3 `above`++-- These combinators can be used to build formated 2D tables.+-- The specific target useage is for HTML table generation.++{-+   Examples of use:++  	> table1 :: BlockTable String+  	> table1 = single "Hello"	+-----++					|Hello|+	  This is a 1x1 cell		+-----++	  Note: single has type+	 +		single :: a -> BlockTable a+	+	  So the cells can contain anything.+	+	> table2 :: BlockTable String+	> table2 = single "World"	+-----++					|World|+					+-----++++	> table3 :: BlockTable String+	> table3 = table1 %-% table2	+-----%-----++					|Hello%World|+	 % is used to indicate		+-----%-----++	 the join edge between+	 the two Tables.  ++	> table4 :: BlockTable String+	> table4 = table3 %/% table2	+-----+-----++					|Hello|World|+	  Notice the padding on the	%%%%%%%%%%%%%+	  smaller (bottom) cell to	|World      |+	  force the table to be a	+-----------++	  rectangle.++	> table5 :: BlockTable String+	> table5 = table1 %-% table4	+-----%-----+-----++					|Hello%Hello|World|+	  Notice the padding on the	|     %-----+-----++	  leftmost cell, again to	|     %World      |+	  force the table to be a	+-----%-----------++	  rectangle.+ +   Now the table can be rendered with processTable, for example:+	Main> processTable table5+	[[("Hello",(1,2)),+	  ("Hello",(1,1)),+	  ("World",(1,1))],+	 [("World",(2,1))]] :: [[([Char],(Int,Int))]]+	Main> +-}++-- ---------------------------------------------------------------------------+-- Contruction Functions++-- Perhaps one day I'll write the Show instance+-- to show boxes aka the above ascii renditions.++instance (Show a) => Show (BlockTable a) where+      showsPrec _ = showsTable++type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]++data BlockTable a = Table (Int -> Int -> TableI a) Int Int+++-- You can create a (1x1) table entry++single :: a -> BlockTable a+single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1++empty :: BlockTable a+empty = Table (\ _ _ r -> r) 0 0+++-- You can compose tables, horizonally and vertically++above  :: BlockTable a -> BlockTable a -> BlockTable a+beside :: BlockTable a -> BlockTable a -> BlockTable a++t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))++t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->+    let+      -- Note this depends on the fact that+      -- that the result has the same number+      -- of lines as the y dimention; one list+      -- per line. This is not true in general+      -- but is always true for these combinators.+      -- I should assert this!+      -- I should even prove this.+      beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys+      beside' (x:xs) []     = x        : xs ++ r+      beside' []     (y:ys) = y        : ys ++ r+      beside' []     []     =                  r+    in+      beside' (lst1 []) (lst2 []))++-- trans flips (transposes) over the x and y axis of+-- the table. It is only used internally, and typically+-- in pairs, ie. (flip ... munge ... (un)flip).++trans :: BlockTable a -> BlockTable a+trans (Table f1 x1 y1) = Table (flip f1) y1 x1++combine :: BlockTable a +      -> BlockTable b +      -> (TableI a -> TableI b -> TableI c) +      -> BlockTable c+combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y+    where+      max_y = max y1 y2+      new_fn x y =+         case compare y1 y2 of+          EQ -> comb (f1 0 y)             (f2 x y)+          GT -> comb (f1 0 y)             (f2 x (y + y1 - y2))+          LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)++-- ---------------------------------------------------------------------------+-- Investigation Functions++-- This is the other thing you can do with a Table;+-- turn it into a 2D list, tagged with the (x,y)+-- sizes of each cell in the table.++getMatrix :: BlockTable a -> [[(a,(Int,Int))]]+getMatrix (Table r _ _) = r 0 0 []++-- You can also look at a table++showsTable :: (Show a) => BlockTable a -> ShowS+showsTable table = shows (getMatrix table)++showTable :: (Show a) => BlockTable a -> String+showTable table = showsTable table ""
+ src/Haddock/Utils/FastMutInt2.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+--+-- (c) The University of Glasgow 2002+--+-- Unboxed mutable Ints++module Haddock.Utils.FastMutInt2(+	FastMutInt, newFastMutInt,+	readFastMutInt, writeFastMutInt,+	incFastMutInt, incFastMutIntBy+  ) where++#include "MachDeps.h"++#ifndef SIZEOF_HSINT+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES+#endif+++#if __GLASGOW_HASKELL__ < 503+import GlaExts+import PrelIOBase+#else+import GHC.Base+import GHC.IOBase+#endif++#if __GLASGOW_HASKELL__ < 411+newByteArray# = newCharArray#+#endif++#ifdef __GLASGOW_HASKELL__+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)++newFastMutInt :: IO FastMutInt+newFastMutInt = IO $ \s0 ->+  case newByteArray# size s0 of { (# s, arr #) ->+  (# s, FastMutInt arr #) }+  where !(I# size) = SIZEOF_HSINT++readFastMutInt :: FastMutInt -> IO Int+readFastMutInt (FastMutInt arr) = IO $ \s0 ->+  case readIntArray# arr 0# s0 of { (# s, i #) ->+  (# s, I# i #) }++writeFastMutInt :: FastMutInt -> Int -> IO ()+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 ->+  case writeIntArray# arr 0# i s0 of { s ->+  (# s, () #) }++incFastMutInt :: FastMutInt -> IO Int	-- Returns original value+incFastMutInt (FastMutInt arr) = IO $ \s0 ->+  case readIntArray# arr 0# s0 of { (# s1, i #) ->+  case writeIntArray# arr 0# (i +# 1#) s1 of { s ->+  (# s, I# i #) } }++incFastMutIntBy :: FastMutInt -> Int -> IO Int	-- Returns original value+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 ->+  case readIntArray# arr 0# s0 of { (# s1, i #) ->+  case writeIntArray# arr 0# (i +# n) s1 of { s ->+  (# s, I# i #) } }+#endif+
+ src/Haddock/Utils/Html.hs view
@@ -0,0 +1,1037 @@+-----------------------------------------------------------------------------+-- +-- Module      :  Text.Html+-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of +--		  Science and Technology, 1999-2001+-- License     :  BSD-style (see the file libraries/core/LICENSE)+-- +-- Maintainer  :  Andy Gill <andy@galconn.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- An Html combinator library+--+-----------------------------------------------------------------------------++module Haddock.Utils.Html (+      module Haddock.Utils.Html,+      ) where++import qualified Haddock.Utils.BlockTable as BT++import Data.Char (isAscii, ord)+import Numeric (showHex)++infixr 2 +++  -- combining Html+infixr 7 <<   -- nesting Html+infixl 8 !    -- adding optional arguments+++-- A important property of Html is that all strings inside the+-- structure are already in Html friendly format.+-- For example, use of &gt;,etc.++data HtmlElement+{-+ -    ..just..plain..normal..text... but using &copy; and &amb;, etc.+ -}+      = HtmlString String+{-+ -    <thetag {..attrs..}> ..content.. </thetag>+ -}+      | HtmlTag {                   -- tag with internal markup+              markupTag      :: String,+              markupAttrs    :: [HtmlAttr],+              markupContent  :: Html+              }++{- These are the index-value pairs.+ - The empty string is a synonym for tags with no arguments.+ - (not strictly HTML, but anyway).+ -}+++data HtmlAttr = HtmlAttr String String+++newtype Html = Html { getHtmlElements :: [HtmlElement] }++-- Read MARKUP as the class of things that can be validly rendered+-- inside MARKUP tag brackets. So this can be one or more Html's,+-- or a String, for example.++class HTML a where+      toHtml     :: a -> Html+      toHtmlFromList :: [a] -> Html++      toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])++instance HTML Html where+      toHtml a    = a++instance HTML Char where+      toHtml       a = toHtml [a]+      toHtmlFromList []  = Html []+      toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]++instance (HTML a) => HTML [a] where+    toHtml xs = toHtmlFromList xs++class ADDATTRS a where+      (!) :: a -> [HtmlAttr] -> a++instance (ADDATTRS b) => ADDATTRS (a -> b) where+      (!) fn attr = \ arg -> fn arg ! attr++instance ADDATTRS Html where+      (!) (Html htmls) attr = Html (map addAttrs htmls)+        where+              addAttrs html =+                  case html of+                       HtmlTag { markupAttrs   = markupAttrs0+                               , markupTag     = markupTag0+                               , markupContent = markupContent0 } ->+                               HtmlTag { markupAttrs   = markupAttrs0 ++ attr+                                       , markupTag     = markupTag0+                                       , markupContent = markupContent0 }+                       _                                         -> html+++(<<)            :: (HTML a) => (Html -> b) -> a        -> b+fn << arg = fn (toHtml arg)+++concatHtml :: (HTML a) => [a] -> Html+concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))++(+++) :: (HTML a,HTML b) => a -> b -> Html+a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))++noHtml :: Html+noHtml = Html []+++isNoHtml :: Html -> Bool+isNoHtml (Html xs) = null xs+++tag  :: String -> Html -> Html+tag str htmls =+    Html [ HtmlTag { markupTag = str,+                     markupAttrs = [],+                     markupContent = htmls }+         ]++itag :: String -> Html+itag str = tag str noHtml++emptyAttr :: String -> HtmlAttr+emptyAttr s = HtmlAttr s ""++intAttr :: String -> Int -> HtmlAttr+intAttr s i = HtmlAttr s (show i)++strAttr :: String -> String -> HtmlAttr+strAttr s t = HtmlAttr s t+++{-+foldHtml :: (String -> [HtmlAttr] -> [a] -> a) +      -> (String -> a)+      -> Html+      -> a+foldHtml f g (HtmlTag str attr fmls) +      = f str attr (map (foldHtml f g) fmls) +foldHtml f g (HtmlString  str)           +      = g str++-}+-- Processing Strings into Html friendly things.+-- This converts a String to a Html String.+stringToHtmlString :: String -> String+stringToHtmlString = concatMap fixChar+    where+      fixChar '<' = "&lt;"+      fixChar '>' = "&gt;"+      fixChar '&' = "&amp;"+      fixChar '"' = "&quot;"+      fixChar c+	| isAscii c = [c]+	| otherwise = "&#x" ++ showHex (ord c) ";"++-- ---------------------------------------------------------------------------+-- Classes++instance Show Html where+      showsPrec _ html = showString (prettyHtml html)+      showList htmls   = showString (concat (map show htmls))++instance Show HtmlAttr where+      showsPrec _ (HtmlAttr str val) = +              showString str .+              showString "=" .+              shows val+++-- ---------------------------------------------------------------------------+-- Data types++type URL = String++-- ---------------------------------------------------------------------------+-- Basic primitives++-- This is not processed for special chars. +-- use stringToHtml or lineToHtml instead, for user strings, +-- because they  understand special chars, like '<'.++primHtml      :: String                                -> Html+primHtml x    = Html [HtmlString x]++-- ---------------------------------------------------------------------------+-- Basic Combinators++stringToHtml          :: String                       -> Html+stringToHtml = primHtml . stringToHtmlString ++-- This converts a string, but keeps spaces as non-line-breakable++lineToHtml            :: String                       -> Html+lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString +   where +      htmlizeChar2 ' ' = "&nbsp;"+      htmlizeChar2 c   = [c]++-- ---------------------------------------------------------------------------+-- Html Constructors++-- (automatically generated)++address             :: Html -> Html+anchor              :: Html -> Html+applet              :: Html -> Html+area                ::         Html+basefont            ::         Html+big                 :: Html -> Html+blockquote          :: Html -> Html+body                :: Html -> Html+bold                :: Html -> Html+br                  ::         Html+button		    :: Html -> Html+caption             :: Html -> Html+center              :: Html -> Html+cite                :: Html -> Html+ddef                :: Html -> Html+define              :: Html -> Html+dlist               :: Html -> Html+dterm               :: Html -> Html+emphasize           :: Html -> Html+fieldset            :: Html -> Html+font                :: Html -> Html+form                :: Html -> Html+frame               :: Html -> Html+frameset            :: Html -> Html+h1                  :: Html -> Html+h2                  :: Html -> Html+h3                  :: Html -> Html+h4                  :: Html -> Html+h5                  :: Html -> Html+h6                  :: Html -> Html+header              :: Html -> Html+hr                  ::         Html+image               ::         Html+input               ::         Html+italics             :: Html -> Html+keyboard            :: Html -> Html+legend              :: Html -> Html+li                  :: Html -> Html+meta                ::         Html+noframes            :: Html -> Html+olist               :: Html -> Html+option              :: Html -> Html+paragraph           :: Html -> Html+param               ::         Html+pre                 :: Html -> Html+sample              :: Html -> Html+script		    :: Html -> Html+select              :: Html -> Html+small               :: Html -> Html+strong              :: Html -> Html+style               :: Html -> Html+sub                 :: Html -> Html+sup                 :: Html -> Html+table               :: Html -> Html+thetd               :: Html -> Html+textarea            :: Html -> Html+th                  :: Html -> Html+thebase             ::         Html+thecode             :: Html -> Html+thediv              :: Html -> Html+thehtml             :: Html -> Html+thelink             ::         Html+themap              :: Html -> Html+thespan             :: Html -> Html+thetitle            :: Html -> Html+tr                  :: Html -> Html+tt                  :: Html -> Html+ulist               :: Html -> Html+underline           :: Html -> Html+variable            :: Html -> Html++address             =  tag "ADDRESS"+anchor              =  tag "A"+applet              =  tag "APPLET"+area                = itag "AREA"+basefont            = itag "BASEFONT"+big                 =  tag "BIG"+blockquote          =  tag "BLOCKQUOTE"+body                =  tag "BODY"+bold                =  tag "B"+br                  = itag "BR"+button		    =  tag "BUTTON"+caption             =  tag "CAPTION"+center              =  tag "CENTER"+cite                =  tag "CITE"+ddef                =  tag "DD"+define              =  tag "DFN"+dlist               =  tag "DL"+dterm               =  tag "DT"+emphasize           =  tag "EM"+fieldset            =  tag "FIELDSET"+font                =  tag "FONT"+form                =  tag "FORM"+frame               =  tag "FRAME"+frameset            =  tag "FRAMESET"+h1                  =  tag "H1"+h2                  =  tag "H2"+h3                  =  tag "H3"+h4                  =  tag "H4"+h5                  =  tag "H5"+h6                  =  tag "H6"+header              =  tag "HEAD"+hr                  = itag "HR"+image               = itag "IMG"+input               = itag "INPUT"+italics             =  tag "I"+keyboard            =  tag "KBD"+legend              =  tag "LEGEND"+li                  =  tag "LI"+meta                = itag "META"+noframes            =  tag "NOFRAMES"+olist               =  tag "OL"+option              =  tag "OPTION"+paragraph           =  tag "P"+param               = itag "PARAM"+pre                 =  tag "PRE"+sample              =  tag "SAMP"+script		    =  tag "SCRIPT"+select              =  tag "SELECT"+small               =  tag "SMALL"+strong              =  tag "STRONG"+style               =  tag "STYLE"+sub                 =  tag "SUB"+sup                 =  tag "SUP"+table               =  tag "TABLE"+thetd               =  tag "TD"+textarea            =  tag "TEXTAREA"+th                  =  tag "TH"+thebase             = itag "BASE"+thecode             =  tag "CODE"+thediv              =  tag "DIV"+thehtml             =  tag "HTML"+thelink             = itag "LINK"+themap              =  tag "MAP"+thespan             =  tag "SPAN"+thetitle            =  tag "TITLE"+tr                  =  tag "TR"+tt                  =  tag "TT"+ulist               =  tag "UL"+underline           =  tag "U"+variable            =  tag "VAR"++-- ---------------------------------------------------------------------------+-- Html Attributes++-- (automatically generated)++action              :: String -> HtmlAttr+align               :: String -> HtmlAttr+alink               :: String -> HtmlAttr+alt                 :: String -> HtmlAttr+altcode             :: String -> HtmlAttr+archive             :: String -> HtmlAttr+background          :: String -> HtmlAttr+base                :: String -> HtmlAttr+bgcolor             :: String -> HtmlAttr+border              :: Int    -> HtmlAttr+bordercolor         :: String -> HtmlAttr+cellpadding         :: Int    -> HtmlAttr+cellspacing         :: Int    -> HtmlAttr+checked             ::           HtmlAttr+clear               :: String -> HtmlAttr+code                :: String -> HtmlAttr+codebase            :: String -> HtmlAttr+color               :: String -> HtmlAttr+cols                :: String -> HtmlAttr+colspan             :: Int    -> HtmlAttr+compact             ::           HtmlAttr+content             :: String -> HtmlAttr+coords              :: String -> HtmlAttr+enctype             :: String -> HtmlAttr+face                :: String -> HtmlAttr+frameborder         :: Int    -> HtmlAttr+height              :: Int    -> HtmlAttr+href                :: String -> HtmlAttr+hspace              :: Int    -> HtmlAttr+httpequiv           :: String -> HtmlAttr+identifier          :: String -> HtmlAttr+ismap               ::           HtmlAttr+lang                :: String -> HtmlAttr+link                :: String -> HtmlAttr+marginheight        :: Int    -> HtmlAttr+marginwidth         :: Int    -> HtmlAttr+maxlength           :: Int    -> HtmlAttr+method              :: String -> HtmlAttr+multiple            ::           HtmlAttr+name                :: String -> HtmlAttr+nohref              ::           HtmlAttr+noresize            ::           HtmlAttr+noshade             ::           HtmlAttr+nowrap              ::           HtmlAttr+onclick		    :: String -> HtmlAttr+rel                 :: String -> HtmlAttr+rev                 :: String -> HtmlAttr+rows                :: String -> HtmlAttr+rowspan             :: Int    -> HtmlAttr+rules               :: String -> HtmlAttr+scrolling           :: String -> HtmlAttr+selected            ::           HtmlAttr+shape               :: String -> HtmlAttr+size                :: String -> HtmlAttr+src                 :: String -> HtmlAttr+start               :: Int    -> HtmlAttr+target              :: String -> HtmlAttr+text                :: String -> HtmlAttr+theclass            :: String -> HtmlAttr+thestyle            :: String -> HtmlAttr+thetype             :: String -> HtmlAttr+title               :: String -> HtmlAttr+usemap              :: String -> HtmlAttr+valign              :: String -> HtmlAttr+value               :: String -> HtmlAttr+version             :: String -> HtmlAttr+vlink               :: String -> HtmlAttr+vspace              :: Int    -> HtmlAttr+width               :: String -> HtmlAttr++action              =   strAttr "ACTION"+align               =   strAttr "ALIGN"+alink               =   strAttr "ALINK"+alt                 =   strAttr "ALT"+altcode             =   strAttr "ALTCODE"+archive             =   strAttr "ARCHIVE"+background          =   strAttr "BACKGROUND"+base                =   strAttr "BASE"+bgcolor             =   strAttr "BGCOLOR"+border              =   intAttr "BORDER"+bordercolor         =   strAttr "BORDERCOLOR"+cellpadding         =   intAttr "CELLPADDING"+cellspacing         =   intAttr "CELLSPACING"+checked             = emptyAttr "CHECKED"+clear               =   strAttr "CLEAR"+code                =   strAttr "CODE"+codebase            =   strAttr "CODEBASE"+color               =   strAttr "COLOR"+cols                =   strAttr "COLS"+colspan             =   intAttr "COLSPAN"+compact             = emptyAttr "COMPACT"+content             =   strAttr "CONTENT"+coords              =   strAttr "COORDS"+enctype             =   strAttr "ENCTYPE"+face                =   strAttr "FACE"+frameborder         =   intAttr "FRAMEBORDER"+height              =   intAttr "HEIGHT"+href                =   strAttr "HREF"+hspace              =   intAttr "HSPACE"+httpequiv           =   strAttr "HTTP-EQUIV"+identifier          =   strAttr "ID"+ismap               = emptyAttr "ISMAP"+lang                =   strAttr "LANG"+link                =   strAttr "LINK"+marginheight        =   intAttr "MARGINHEIGHT"+marginwidth         =   intAttr "MARGINWIDTH"+maxlength           =   intAttr "MAXLENGTH"+method              =   strAttr "METHOD"+multiple            = emptyAttr "MULTIPLE"+name                =   strAttr "NAME"+nohref              = emptyAttr "NOHREF"+noresize            = emptyAttr "NORESIZE"+noshade             = emptyAttr "NOSHADE"+nowrap              = emptyAttr "NOWRAP"+onclick             =   strAttr "ONCLICK"+rel                 =   strAttr "REL"+rev                 =   strAttr "REV"+rows                =   strAttr "ROWS"+rowspan             =   intAttr "ROWSPAN"+rules               =   strAttr "RULES"+scrolling           =   strAttr "SCROLLING"+selected            = emptyAttr "SELECTED"+shape               =   strAttr "SHAPE"+size                =   strAttr "SIZE"+src                 =   strAttr "SRC"+start               =   intAttr "START"+target              =   strAttr "TARGET"+text                =   strAttr "TEXT"+theclass            =   strAttr "CLASS"+thestyle            =   strAttr "STYLE"+thetype             =   strAttr "TYPE"+title               =   strAttr "TITLE"+usemap              =   strAttr "USEMAP"+valign              =   strAttr "VALIGN"+value               =   strAttr "VALUE"+version             =   strAttr "VERSION"+vlink               =   strAttr "VLINK"+vspace              =   intAttr "VSPACE"+width               =   strAttr "WIDTH"++-- ---------------------------------------------------------------------------+-- Html Constructors++-- (automatically generated)++validHtmlTags :: [String]+validHtmlTags = [+      "ADDRESS",+      "A",+      "APPLET",+      "BIG",+      "BLOCKQUOTE",+      "BODY",+      "B",+      "CAPTION",+      "CENTER",+      "CITE",+      "DD",+      "DFN",+      "DL",+      "DT",+      "EM",+      "FIELDSET",+      "FONT",+      "FORM",+      "FRAME",+      "FRAMESET",+      "H1",+      "H2",+      "H3",+      "H4",+      "H5",+      "H6",+      "HEAD",+      "I",+      "KBD",+      "LEGEND",+      "LI",+      "NOFRAMES",+      "OL",+      "OPTION",+      "P",+      "PRE",+      "SAMP",+      "SELECT",+      "SMALL",+      "STRONG",+      "STYLE",+      "SUB",+      "SUP",+      "TABLE",+      "TD",+      "TEXTAREA",+      "TH",+      "CODE",+      "DIV",+      "HTML",+      "LINK",+      "MAP",+      "TITLE",+      "TR",+      "TT",+      "UL",+      "U",+      "VAR"]++validHtmlITags :: [String]+validHtmlITags = [+      "AREA",+      "BASEFONT",+      "BR",+      "HR",+      "IMG",+      "INPUT",+      "LINK",+      "META",+      "PARAM",+      "BASE"]++validHtmlAttrs :: [String]+validHtmlAttrs = [+      "ACTION",+      "ALIGN",+      "ALINK",+      "ALT",+      "ALTCODE",+      "ARCHIVE",+      "BACKGROUND",+      "BASE",+      "BGCOLOR",+      "BORDER",+      "BORDERCOLOR",+      "CELLPADDING",+      "CELLSPACING",+      "CHECKED",+      "CLEAR",+      "CODE",+      "CODEBASE",+      "COLOR",+      "COLS",+      "COLSPAN",+      "COMPACT",+      "CONTENT",+      "COORDS",+      "ENCTYPE",+      "FACE",+      "FRAMEBORDER",+      "HEIGHT",+      "HREF",+      "HSPACE",+      "HTTP-EQUIV",+      "ID",+      "ISMAP",+      "LANG",+      "LINK",+      "MARGINHEIGHT",+      "MARGINWIDTH",+      "MAXLENGTH",+      "METHOD",+      "MULTIPLE",+      "NAME",+      "NOHREF",+      "NORESIZE",+      "NOSHADE",+      "NOWRAP",+      "REL",+      "REV",+      "ROWS",+      "ROWSPAN",+      "RULES",+      "SCROLLING",+      "SELECTED",+      "SHAPE",+      "SIZE",+      "SRC",+      "START",+      "TARGET",+      "TEXT",+      "CLASS",+      "STYLE",+      "TYPE",+      "TITLE",+      "USEMAP",+      "VALIGN",+      "VALUE",+      "VERSION",+      "VLINK",+      "VSPACE",+      "WIDTH"]++-- ---------------------------------------------------------------------------+-- Html colors++aqua          :: String+black         :: String+blue          :: String+fuchsia       :: String+gray          :: String+green         :: String+lime          :: String+maroon        :: String+navy          :: String+olive         :: String+purple        :: String+red           :: String+silver        :: String+teal          :: String+yellow        :: String+white         :: String++aqua          = "aqua"+black         = "black"+blue          = "blue"+fuchsia       = "fuchsia"+gray          = "gray"+green         = "green"+lime          = "lime"+maroon        = "maroon"+navy          = "navy"+olive         = "olive"+purple        = "purple"+red           = "red"+silver        = "silver"+teal          = "teal"+yellow        = "yellow"+white         = "white"++-- ---------------------------------------------------------------------------+-- Basic Combinators++linesToHtml :: [String]       -> Html++linesToHtml []     = noHtml+linesToHtml (x:[]) = lineToHtml x+linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs+++-- ---------------------------------------------------------------------------+-- Html abbriviations++primHtmlChar  :: String -> Html+copyright     :: Html+spaceHtml     :: Html+bullet        :: Html+p             :: Html -> Html++primHtmlChar  = \ x -> primHtml ("&" ++ x ++ ";")+copyright     = primHtmlChar "copy"+spaceHtml     = primHtmlChar "nbsp"+bullet        = primHtmlChar "#149"++p             = paragraph++-- ---------------------------------------------------------------------------+-- Html tables++cell :: Html -> HtmlTable+cell h = let+              cellFn x y = h ! (add x colspan $ add y rowspan $ [])+              add 1 _  rest = rest+              add n fn rest = fn n : rest+              r = BT.single cellFn+         in +              mkHtmlTable r++-- We internally represent the Cell inside a Table with an+-- object of the type+-- \pre{+-- 	   Int -> Int -> Html+-- } 	+-- When we render it later, we find out how many columns+-- or rows this cell will span over, and can+-- include the correct colspan/rowspan command.++newtype HtmlTable +      = HtmlTable (BT.BlockTable (Int -> Int -> Html))++td :: Html -> HtmlTable+td = cell . thetd++tda :: [HtmlAttr] -> Html -> HtmlTable+tda as = cell . (thetd ! as)++above, beside :: HtmlTable -> HtmlTable -> HtmlTable+above  a b = combine BT.above a b+beside a b = combine BT.beside a b++infixr 3 </>  -- combining table cells +infixr 4 <->  -- combining table cells+(</>), (<->) :: HtmlTable -> HtmlTable -> HtmlTable+(</>) = above+(<->) = beside++emptyTable :: HtmlTable+emptyTable = HtmlTable BT.empty++aboves, besides :: [HtmlTable] -> HtmlTable+aboves  = foldr above  emptyTable+besides = foldr beside emptyTable++mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable+mkHtmlTable r = HtmlTable r++combine :: (BT.BlockTable (Int -> Int -> Html)+	    -> BT.BlockTable (Int -> Int -> Html)+	    -> BT.BlockTable (Int -> Int -> Html))+	-> HtmlTable -> HtmlTable -> HtmlTable+combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b)++-- renderTable takes the HtmlTable, and renders it back into+-- and Html object.++renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html+renderTable theTable+      = concatHtml+          [tr << [theCell x y | (theCell,(x,y)) <- theRow ]+                      | theRow <- BT.getMatrix theTable]++instance HTML HtmlTable where+      toHtml (HtmlTable tab) = renderTable tab++instance Show HtmlTable where+      showsPrec _ (HtmlTable tab) = shows (renderTable tab)+++-- If you can't be bothered with the above, then you+-- can build simple tables with simpleTable.+-- Just provide the attributes for the whole table,+-- attributes for the cells (same for every cell),+-- and a list of lists of cell contents,+-- and this function will build the table for you.+-- It does presume that all the lists are non-empty,+-- and there is at least one list.+--  +-- Different length lists means that the last cell+-- gets padded. If you want more power, then+-- use the system above, or build tables explicitly.++simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html+simpleTable attr cellAttr lst+      = table ! attr +          <<  (aboves +              . map (besides . map (cell . (thetd ! cellAttr) . toHtml))+              ) lst+++-- ---------------------------------------------------------------------------+-- Tree Displaying Combinators+ +-- The basic idea is you render your structure in the form+-- of this tree, and then use treeHtml to turn it into a Html+-- object with the structure explicit.++data HtmlTree+      = HtmlLeaf Html+      | HtmlNode Html [HtmlTree] Html++treeHtml :: [String] -> HtmlTree -> Html+treeHtml colors h = table ! [+                    border 0,+                    cellpadding 0,+                    cellspacing 2] << treeHtml' colors h+     where+      manycolors = scanr (:) []++      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable+      treeHtmls c ts = aboves (zipWith treeHtml' c ts)++      treeHtml' :: [String] -> HtmlTree -> HtmlTable+      treeHtml' (_:_) (HtmlLeaf leaf) = cell+                                         (thetd ! [width "100%"] +                                            << bold  +                                               << leaf)+      treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =+          if null ts && isNoHtml hclose+          then+              hd +          else if null ts+          then+              hd </> bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml)+                 </> tl+          else+              hd </> (bar `beside` treeHtmls morecolors ts)+                 </> tl+        where+              -- This stops a column of colors being the same+              -- color as the immeduately outside nesting bar.+              morecolors = filter ((/= c).head) (manycolors cs)+              bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml)+              hd = cell (thetd ! [bgcolor c] << hopen)+              tl = cell (thetd ! [bgcolor c] << hclose)+      treeHtml' _ _ = error "The imposible happens"++instance HTML HtmlTree where+      toHtml x = treeHtml treeColors x++-- type "length treeColors" to see how many colors are here.+treeColors :: [String]+treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors+++-- ---------------------------------------------------------------------------+-- Html Debugging Combinators+ +-- This uses the above tree rendering function, and displays the+-- Html as a tree structure, allowing debugging of what is+-- actually getting produced.++debugHtml :: (HTML a) => a -> Html+debugHtml obj = table ! [border 0] << (+                  cell (th ! [bgcolor "#008888"] +                     	<< underline+                       	   << "Debugging Output")+               </>  td << (toHtml (debug' (toHtml obj)))+              )+  where++      debug' :: Html -> [HtmlTree]+      debug' (Html markups) = map debug markups++      debug :: HtmlElement -> HtmlTree+      debug (HtmlString str) = HtmlLeaf (spaceHtml ++++                                              linesToHtml (lines str))+      debug (HtmlTag {+              markupTag = markupTag0,+              markupContent = markupContent0,+              markupAttrs  = markupAttrs0+              }) =+              case markupContent0 of+                Html [] -> HtmlNode hd [] noHtml+                Html xs -> HtmlNode hd (map debug xs) tl+        where+              args = if null markupAttrs0+                     then ""+                     else "  " ++ unwords (map show markupAttrs0) +              hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">")+              tl = font ! [size "1"] << ("</" ++ markupTag0 ++ ">")++-- ---------------------------------------------------------------------------+-- Hotlink datatype++data HotLink = HotLink {+      hotLinkURL        :: URL,+      hotLinkContents   :: [Html],+      hotLinkAttributes :: [HtmlAttr]+      } deriving Show++instance HTML HotLink where+      toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)+                      << hotLinkContents hl++hotlink :: URL -> [Html] -> HotLink+hotlink url h = HotLink {+      hotLinkURL = url,+      hotLinkContents = h,+      hotLinkAttributes = [] }+++-- ---------------------------------------------------------------------------+-- More Combinators++-- (Abridged from Erik Meijer's Original Html library)++ordList   :: (HTML a) => [a] -> Html+ordList items = olist << map (li <<) items++unordList :: (HTML a) => [a] -> Html+unordList items = ulist << map (li <<) items++defList   :: (HTML a,HTML b) => [(a,b)] -> Html+defList items+ = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]+++widget :: String -> String -> [HtmlAttr] -> Html+widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0)++checkbox :: String -> String -> Html+hidden   :: String -> String -> Html+radio    :: String -> String -> Html+reset    :: String -> String -> Html+submit   :: String -> String -> Html+password :: String           -> Html+textfield :: String          -> Html+afile    :: String           -> Html+clickmap :: String           -> Html++checkbox n v = widget "CHECKBOX" n [value v]+hidden   n v = widget "HIDDEN"   n [value v]+radio    n v = widget "RADIO"    n [value v]+reset    n v = widget "RESET"    n [value v]+submit   n v = widget "SUBMIT"   n [value v]+password n   = widget "PASSWORD" n []+textfield n  = widget "TEXT"     n []+afile    n   = widget "FILE"     n []+clickmap n   = widget "IMAGE"    n []++menu :: String -> [Html] -> Html+menu n choices+   = select ! [name n] << [ option << p << choice | choice <- choices ]++gui :: String -> Html -> Html+gui act = form ! [action act,method "POST"]++-- ---------------------------------------------------------------------------+-- Html Rendering+ +-- Uses the append trick to optimize appending.+-- The output is quite messy, because space matters in+-- HTML, so we must not generate needless spaces.++renderHtml :: (HTML html) => html -> String+renderHtml theHtml =+      renderMessage ++ +         foldr (.) id (map unprettyHtml+                           (getHtmlElements (tag "HTML" << theHtml))) "\n"++renderMessage :: String+renderMessage =+      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" +++      "<!--Rendered using the Haskell Html Library v0.2-->\n"++unprettyHtml :: HtmlElement -> ShowS+unprettyHtml (HtmlString str) = (++) str+unprettyHtml (HtmlTag+              { markupTag = name0,+                markupContent = html,+                markupAttrs = markupAttrs0 })+      = if isNoHtml html && elem name0 validHtmlITags+        then renderTag True name0 markupAttrs0 0+        else (renderTag True name0 markupAttrs0 0+             . foldr (.) id (map unprettyHtml (getHtmlElements html))+             . renderTag False name0 [] 0)++-- Local Utilities+prettyHtml :: (HTML html) => html -> String+prettyHtml theHtml = +        unlines+      $ concat+      $ map prettyHtml'+      $ getHtmlElements+      $ toHtml theHtml++prettyHtml' :: HtmlElement -> [String]+prettyHtml' (HtmlString str) = [str]+prettyHtml' (HtmlTag+              { markupTag = name0,+                markupContent = html,+                markupAttrs = markupAttrs0 })+      = if isNoHtml html && elem name0 validHtmlITags+        then +         [rmNL (renderTag True name0 markupAttrs0 0 "")]+        else+         [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ +          shift (concat (map prettyHtml' (getHtmlElements html))) +++         [rmNL (renderTag False name0 [] 0 "")]+  where+      shift = map (\x -> "   " ++ x)++rmNL :: [Char] -> [Char]+rmNL = filter (/= '\n')++-- This prints the Tags The lack of spaces in intentunal, because Html is+-- actually space dependant.++renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS+renderTag x name0 markupAttrs0 n r+      = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r+  where+      open = if x then "<" else "</"+      +      nl = "\n" ++ replicate (n `div` 8) '\t' +                ++ replicate (n `mod` 8) ' '++      rest []   = nl+      rest attr = " " ++ unwords (map showPair attr) ++ nl++      showPair :: HtmlAttr -> String+      showPair (HtmlAttr tag0 val)+              = tag0 ++ "=\"" ++ val  ++ "\""+
+ src/Haddock/Version.hs view
@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- 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_leksah ( version )+import Data.Version  ( showVersion )++projectName, projectUrl :: String+projectName = "Haddock"+projectUrl  = "http://www.haskell.org/haddock/"++projectVersion :: String+projectVersion = showVersion version
+ src/Main.hs view
@@ -0,0 +1,491 @@+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) Simon Marlow 2003-2006,+--                    David Waern  2006-2009+-- 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 Main (main) where+++import Haddock.Backends.Html+import Haddock.Backends.Hoogle+import Haddock.Interface+import Haddock.Types+import Haddock.Version+import Haddock.InterfaceFile+import Haddock.Options+import Haddock.Utils+import Haddock.GhcUtils+import Paths_haddock_leksah++import Control.Monad+#if __GLASGOW_HASKELL__ >= 609+import Control.OldException+import qualified Control.Exception as NewException+#else+import Control.Exception+#endif+import Data.Maybe+import Data.IORef+import qualified Data.Map as Map+import System.IO+import System.Exit+import System.Environment+import System.FilePath+import Distribution.Verbosity++#if defined(mingw32_HOST_OS)+import Foreign+import Foreign.C+import Data.Int+#endif++#ifndef IN_GHC_TREE+import GHC.Paths+#endif++import GHC hiding (flags, verbosity)+import Config+import DynFlags hiding (flags, verbosity)+#if __GLASGOW_HASKELL__ >= 609+import Panic (handleGhcException)+import MonadUtils ( MonadIO(..) )+#else+import Util hiding (handle)+#endif+++--------------------------------------------------------------------------------+-- Exception handling+--------------------------------------------------------------------------------+++handleTopExceptions :: IO a -> IO a+handleTopExceptions =+  handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions+++handleNormalExceptions :: IO a -> IO a+handleNormalExceptions inner =+  handle (\exception -> do+    hFlush stdout+    case exception of+      AsyncException StackOverflow -> do+        putStrLn "stack overflow: use -g +RTS -K<size> to increase it"+        exitFailure+      ExitException code -> exitWith code+      _other -> do+        putStrLn ("haddock: internal Haddock or GHC error: " ++ show exception)+        exitFailure+  ) inner+++handleHaddockExceptions :: IO a -> IO a+handleHaddockExceptions inner =+#if __GLASGOW_HASKELL__ >= 609+  NewException.catches inner [NewException.Handler handler]+#else+  handleDyn handler inner+#endif+  where+    handler (e::HaddockException) = do+      putStrLn $ "haddock: " ++ (show e)+      exitFailure+++handleGhcExceptions :: IO a -> IO a+handleGhcExceptions inner =+  -- compilation errors: messages with locations attached+#if __GLASGOW_HASKELL__ < 609+ handleDyn (\e -> do+    putStrLn "haddock: Compilation error(s):"+    printBagOfErrors defaultDynFlags (unitBag e)+    exitFailure+  ) $+#endif++  -- error messages propagated as exceptions+#if __GLASGOW_HASKELL__ >= 609+  handleGhcException (\e -> do+#else+  handleDyn (\e -> do+#endif+    hFlush stdout+    case e of+      PhaseFailed _ code -> exitWith code+      Interrupted -> exitFailure+      _ -> do+        print (e :: GhcException)+        exitFailure+  ) inner+++-------------------------------------------------------------------------------+-- Top level+-------------------------------------------------------------------------------+++main :: IO ()+main = handleTopExceptions $ do++  -- parse command-line flags and handle some of them initially+  args <- getArgs+  (flags, fileArgs) <- parseHaddockOpts args+  handleEasyFlags flags+  verbosity <- getVerbosity flags++  let renderStep packages interfaces = do+        updateHTMLXRefs packages+        let ifaceFiles = map fst packages+            installedIfaces = concatMap ifInstalledIfaces ifaceFiles+        render flags interfaces installedIfaces++  if not (null fileArgs)+    then do++      libDir <- case getGhcLibDir flags of+                Just dir -> return dir+                Nothing ->+#ifdef IN_GHC_TREE+                    do m <- getExecDir+                       case m of+                           Nothing -> error "No GhcLibDir found"+#ifdef NEW_GHC_LAYOUT+                           Just d -> return (d </> ".." </> "lib")+#else+                           Just d -> return (d </> "..")+#endif+#else+                    return libdir -- from GHC.Paths+#endif++#if __GLASGOW_HASKELL__ >= 609+      -- We have one global error handler for all GHC source errors.  Other kinds+      -- of exceptions will be propagated to the top-level error handler.+      let handleSrcErrors action = flip handleSourceError action $ \err -> do+            printExceptionAndWarnings err+            liftIO exitFailure++      -- initialize GHC+      startGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do++        -- get packages supplied with --read-interface+        packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags)+++        -- create the interfaces -- this is the core part of Haddock+        (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags+                                                    (map fst packages)++        liftIO $ do+          -- render the interfaces+          renderStep packages interfaces++          -- last but not least, dump the interface file+          dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags+#else+      -- initialize GHC+      (session, dynflags) <- startGhc libDir (ghcFlags flags)++      -- get packages supplied with --read-interface+      packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags)++      -- create the interfaces -- this is the core part of Haddock+      (interfaces, homeLinks) <- createInterfaces verbosity session fileArgs flags+                                                  (map fst packages)++      -- render the interfaces+      renderStep packages interfaces++      -- last but not least, dump the interface file+      dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags+#endif+    else do+      -- get packages supplied with --read-interface+      packages <- readInterfaceFiles freshNameCache (ifacePairs flags)++      -- render even though there are no input files (usually contents/index)+      renderStep packages []+++-------------------------------------------------------------------------------+-- Rendering+-------------------------------------------------------------------------------+++-- | Render the interfaces with whatever backend is specified in the flags+render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO ()+render flags ifaces installedIfaces = do+  let+    title = case [str | Flag_Heading str <- flags] of+              [] -> ""+              (t:_) -> t++    maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL   str <- flags]+                        ,listToMaybe [str | Flag_SourceModuleURL str <- flags]+                        ,listToMaybe [str | Flag_SourceEntityURL str <- flags])++    maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL   str <- flags]+                      ,listToMaybe [str | Flag_WikiModuleURL str <- flags]+                      ,listToMaybe [str | Flag_WikiEntityURL str <- flags])++  libDir <- case [str | Flag_Lib str <- flags] of+    [] ->+#ifdef IN_GHC_TREE+                      do m <- getExecDir+                         case m of+                             Nothing -> error "No libdir found"+#ifdef NEW_GHC_LAYOUT+                             Just d -> return (d </> ".." </> "lib")+#else+                             Just d -> return (d </> "..")+#endif+#else+                      getDataDir -- provided by Cabal+#endif+    fs -> return (last fs)+  let unicode = Flag_UseUnicode `elem` flags+  let css_file = case [str | Flag_CSS str <- flags] of+                   [] -> Nothing+                   fs -> Just (last fs)++  odir <- case [str | Flag_OutputDir str <- flags] of+            [] -> return "."+            fs -> return (last fs)++  let+    maybe_contents_url =+      case [url | Flag_UseContents url <- flags] of+        [] -> Nothing+        us -> Just (last us)++    maybe_index_url =+      case [url | Flag_UseIndex url <- flags] of+        [] -> Nothing+        us -> Just (last us)++    maybe_html_help_format =+      case [hhformat | Flag_HtmlHelp hhformat <- flags] of+        []      -> Nothing+        formats -> Just (last formats)++  prologue <- getPrologue flags++  let+    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 ]++    packageMod       = ifaceMod (head ifaces)+    packageStr       = Just (modulePackageString packageMod)+    (pkgName,pkgVer) = modulePackageInfo packageMod+++  when (Flag_GenIndex `elem` flags) $ do+    ppHtmlIndex odir title packageStr maybe_html_help_format+                maybe_contents_url maybe_source_urls maybe_wiki_urls+                allVisibleIfaces+    copyHtmlBits odir libDir css_file++  when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do+    ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format []++  when (Flag_GenContents `elem` flags) $ do+    ppHtmlContents odir title packageStr maybe_html_help_format+                   maybe_index_url maybe_source_urls maybe_wiki_urls+                   allVisibleIfaces True prologue+    copyHtmlBits odir libDir css_file++  when (Flag_Html `elem` flags) $ do+    ppHtml title packageStr visibleIfaces odir+                prologue maybe_html_help_format+                maybe_source_urls maybe_wiki_urls+                maybe_contents_url maybe_index_url unicode+    copyHtmlBits odir libDir css_file++  when (Flag_Hoogle `elem` flags) $ do+    let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName+    ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir+++-------------------------------------------------------------------------------+-- Reading and dumping interface files+-------------------------------------------------------------------------------+++readInterfaceFiles :: MonadIO m =>+                      NameCacheAccessor m+                   -> [(FilePath, FilePath)] ->+                      m [(InterfaceFile, FilePath)]+readInterfaceFiles name_cache_accessor pairs = do+  mbPackages <- mapM tryReadIface pairs+  return (catMaybes mbPackages)+  where+    -- try to read an interface, warn if we can't+    tryReadIface (html, iface) = do+      eIface <- readInterfaceFile name_cache_accessor iface+      case eIface of+        Left err -> liftIO $ do+          putStrLn ("Warning: Cannot read " ++ iface ++ ":")+          putStrLn ("   " ++ show err)+          putStrLn "Skipping this interface."+          return Nothing+        Right f -> return $ Just (f, html)+++dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO ()+dumpInterfaceFile ifaces homeLinks flags =+  case [str | Flag_DumpInterface str <- flags] of+    [] -> return ()+    fs -> let filename = last fs in writeInterfaceFile filename ifaceFile+  where+    ifaceFile = InterfaceFile {+        ifInstalledIfaces = ifaces,+        ifLinkEnv         = homeLinks+      }+++-------------------------------------------------------------------------------+-- Creating a GHC session+-------------------------------------------------------------------------------++-- | Start a GHC session with the -haddock flag set. Also turn off+-- compilation and linking.+#if __GLASGOW_HASKELL__ >= 609+startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a+startGhc libDir flags ghcActs = do+  -- TODO: handle warnings?+  (restFlags, _) <- parseStaticFlags (map noLoc flags)+  runGhc (Just libDir) $ do+    dynflags  <- getSessionDynFlags+#else+startGhc :: String -> [String] -> IO (Session, DynFlags)+startGhc libDir flags = do+  restFlags <- parseStaticFlags flags+  session <- newSession (Just libDir)+  dynflags <- getSessionDynFlags session+  do+#endif+    let dynflags' = dopt_set dynflags Opt_Haddock+    let dynflags'' = dynflags' {+        hscTarget = HscNothing,+        ghcMode   = CompManager,+        ghcLink   = NoLink+      }+    dynflags''' <- parseGhcFlags dynflags'' restFlags flags+    defaultCleanupHandler dynflags''' $ do+#if __GLASGOW_HASKELL__ >= 609+        setSessionDynFlags dynflags'''+        ghcActs dynflags'''+#else+        setSessionDynFlags session dynflags'''+        return (session, dynflags''')+#endif+  where+    parseGhcFlags :: Monad m => DynFlags -> [Located String]+                  -> [String] -> m DynFlags+    parseGhcFlags dynflags flags_ origFlags = do+      -- TODO: handle warnings?+#if __GLASGOW_HASKELL__ >= 609+      (dynflags', rest, _) <- parseDynamicFlags dynflags flags_+#else+      (dynflags', rest) <- parseDynamicFlags dynflags flags_+#endif+      if not (null rest)+        then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags))+        else return dynflags'+++-------------------------------------------------------------------------------+-- Misc+-------------------------------------------------------------------------------+++getGhcLibDir :: [Flag] -> Maybe String+getGhcLibDir flags =+  case [ dir | Flag_GhcLibDir dir <- flags ] of+    [] -> Nothing+    xs -> Just $ last xs+++getVerbosity :: Monad m => [Flag] -> m Verbosity+getVerbosity flags =+  case [ str | Flag_Verbosity str <- flags ] of+    [] -> return normal+    x:_ -> case parseVerbosity x of+      Left e -> throwE e+      Right v -> return v+++handleEasyFlags :: [Flag] -> IO ()+handleEasyFlags flags = do+  usage <- getUsage++  when (Flag_Help       `elem` flags) (bye usage)+  when (Flag_Version    `elem` flags) byeVersion+  when (Flag_GhcVersion `elem` flags) byeGhcVersion++  when (Flag_UseUnicode `elem` flags && not (Flag_Html `elem` 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")+  where+    byeVersion = bye $+      "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"+      ++ "Ported to use the GHC API by David Waern 2006-2008\n"++    byeGhcVersion = bye (cProjectVersion ++ "\n")+++updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO ()+updateHTMLXRefs packages = do+  writeIORef html_xrefs_ref (Map.fromList mapping)+  where+    mapping = [ (instMod iface, html) | (ifaces, html) <- packages+              , iface <- ifInstalledIfaces ifaces ]+++getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))+getPrologue flags =+  case [filename | Flag_Prologue filename <- flags ] of+    [] -> return Nothing+    [filename] -> do+      str <- readFile filename+      case parseHaddockComment str of+        Left err -> throwE err+        Right doc -> return (Just doc)+    _otherwise -> throwE "multiple -p/--prologue options"+++getExecDir :: IO (Maybe String)+#if defined(mingw32_HOST_OS)+getExecDir = allocaArray len $ \buf -> do+    ret <- getModuleFileName nullPtr buf len+    if ret == 0+        then return Nothing+        else do s <- peekCString buf+                return (Just (dropFileName s))+  where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.++foreign import stdcall unsafe "GetModuleFileNameA"+  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32+#else+getExecDir = return Nothing+#endif+
+ src/haddock.sh view
@@ -0,0 +1,7 @@+# Mini-driver for Haddock++# needs the following variables:+#	HADDOCKLIB+#	HADDOCKBIN++$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}