diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -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 <> 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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 or +Simon Marlow + + +[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/ diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#! /usr/bin/runhaskell +\begin{code} +import Distribution.Simple +main = defaultMain +\end{code} diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,6 @@ +include config.mk + +XML_DOC = haddock +INSTALL_XML_DOC = haddock + +include docbook-xml.mk diff --git a/doc/README b/doc/README new file mode 100644 --- /dev/null +++ b/doc/README @@ -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. diff --git a/doc/aclocal.m4 b/doc/aclocal.m4 new file mode 100644 --- /dev/null +++ b/doc/aclocal.m4 @@ -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 + + + + A DocBook Test Document + + A Chapter Title + This is a paragraph, referencing . + + + Another Chapter Title + This is another paragraph, referencing . + + +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 + + + + + + + + + + + Test! + + + + +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 diff --git a/doc/config.mk.in b/doc/config.mk.in new file mode 100644 --- /dev/null +++ b/doc/config.mk.in @@ -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 diff --git a/doc/configure.ac b/doc/configure.ac new file mode 100644 --- /dev/null +++ b/doc/configure.ac @@ -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 diff --git a/doc/docbook-xml.mk b/doc/docbook-xml.mk new file mode 100644 --- /dev/null +++ b/doc/docbook-xml.mk @@ -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 diff --git a/doc/fptools.css b/doc/fptools.css new file mode 100644 --- /dev/null +++ b/doc/fptools.css @@ -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 } diff --git a/doc/haddock.xml b/doc/haddock.xml new file mode 100644 --- /dev/null +++ b/doc/haddock.xml @@ -0,0 +1,1648 @@ + + + + + + 2004-08-02 + Haddock User Guide + + Simon + Marlow + +
simonmar@microsoft.com
+ + 2004 + Simon Marlow + + + This document describes Haddock version 2.5.0, a Haskell + documentation tool. + + + + + + + + Introduction + + This is Haddock, a tool for automatically generating + documentation from annotated Haskell source code. Haddock was + designed with several goals in mind: + + + + 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. + + + 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. + + + 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 IDoc. + In fact, Haddock can understand IDoc-annotated source + code. + + + 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. + + 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. + + + 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. + + + 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. + + + +
+ Obtaining Haddock + + Distributions (source & binary) of Haddock can be obtained + from its web + site. + + Up-to-date sources can also be obtained from our public + darcs repository. The Haddock sources are at + http://code.haskell.org/haddock. See + darcs.net for more + information on the darcs version control utility. +
+ +
+ License + + The following license covers this documentation, and the + Haddock source code, except where otherwise indicated. + +
+ 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. +
+
+ +
+ Acknowledgements + + Several documentation systems provided the inspiration for + Haddock, most notably: + + + + + IDoc + + + HDoc + + + + Doxygen + + + + and probably several others I've forgotten. + + 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 haskelldoc@haskell.org, and everyone who + contributed to the many libraries that Haddock makes use + of. +
+ + + + + Invoking Haddock + Haddock is invoked from the command line, like so: + + + haddock + option + file + + + Where each file is a filename + containing a Haskell source module (.hs) or a Literate Haskell source + module (.lhs) or just a module name. + + 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. + + 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. + + The modules should not be mutually + recursive, as Haddock don't like swimming in circles. + + You must also specify an option for the output format. + Currently only the option for HTML and the + option for outputting Hoogle data are + functional. + + The packaging + tool Cabal + has Haddock support, and is often used instead of invoking Haddock + directly. + + The following options are available: + + + + + + + dir + + + Tell GHC that that its lib directory is + dir. Can be used to override the default path. + + + + + + + =option + + + Pass option to GHC. + + + + + + + + dir + + + + =dir + + + Generate files into dir + instead of the current directory. + + + + + + + path,file + + + + =path,file + + + Read the interface file in + file, which must have been + produced by running Haddock with the + option. The interface + describes a set of modules whose HTML documentation is + located in path (which may be a + relative pathname). The path is + optional, and defaults to .. + + This option allows Haddock to produce separate sets of + documentation with hyperlinks between them. The + path 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 path means that a + documentation subtree can still be moved around without + breaking links. + + Multiple options may + be given. + + + + + + + file + + + + =file + + + Produce an interface + fileHaddock interface files are + not the same as Haskell interface files, I just couldn't + think of a better name. + in the file file. An interface + file contains information Haddock needs to produce more + documentation that refers to the modules currently being + processed - see the option + for more details. The interface file is in a binary format; + don't try to read it. + + + + + + + dir + + + + =dir + + + Use auxiliary files in dir. + + + + + + + + + + + + + + Reserved for future use (output documentation in DocBook XML + format). + + + + + + + + + + + + + + Generate documentation in HTML format. Several files + will be generated into the current directory (or the + specified directory if the option is + given), including the following: + + + index.html + + The top level page of the documentation: lists + the modules available, using indentation to represent + the hierarchy if the modules are hierarchical. + + + + haddock.css + + 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. + + + + haddock-util.js + + A small piece of JavaScript for collapsing sections + of the generated HTML. + + + + module.html + + An HTML page for each + module. + + + + doc-index.html + doc-index-XX.html + + The index, split into two + (functions/constructors and types/classes, as per + Haskell namespaces) and further split + alphabetically. + + + + + + + + + + + + + + + + + (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. + + 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. + + In order to create a compiled Microsoft help file, you + also need the Microsoft HTML Help compiler, which is + available free from + http://www.microsoft.com/ + (search for HTML Help compiler). + + Viewers + + + Microsoft HTML Help Viewer + Distributed with Microsoft Windows + + + xCHM + a CHM viewer for UNIX (Linux, *BSD, Solaris), written by Razvan Cojocaru + + + JouleData Solutions' CHM Viewer + a comercial 100% native Cocoa .chm file viewer for the Mac OS X platform + + + GnoCHM + a CHM file viewer. It is designed to integrate nicely with Gnome. + + + + 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. + + + + + + + + =URL + + + + =URL + + + + =URL + + + Include links to the source files in the generated + documentation. Use the option to add a + source code link in the header bar of the contents and index pages. + Use the to add a source code link in + the header bar of each module page. Use the + option to add a source code link + next to the documentation for every value and type in each module. + + + In each case URL 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 URL: + + + + The string %M or %{MODULE} + is replaced by the module name. Note that for the per-entity URLs + this is the name of the exporting module. + + + The string %F or %{FILE} + is replaced by the original source file name. Note that for the + per-entity URLs this is the name of the defining + module. + + + The string %N or %{NAME} + is replaced by the name of the exported value or type. This is + only valid for the option. + + + The string %K or %{KIND} + is replaced by a flag indicating whether the exported name is a value + 'v' or a type 't'. This is + only valid for the option. + + + The string %L or %{LINE} + is replaced by the number of the line where the exported value or + type is defined. This is only valid for the + option. + + + The string %% is replaced by + %. + + + + + For example, if your sources are online under some directory, + you would say + haddock --source-base=url/ + --source-module=url/%F + + If you have html versions of your sources online with anchors + for each type and function name, you would say + haddock --source-base=url/ + --source-module=url/%M.html + --source-entity=url/%M.html#%N + + For the %{MODULE} substitution you may want to + replace the '.' character in the module names with + some other character (some web servers are known to get confused by + multiple '.' characters in a file name). To + replace it with a character c use + %{MODULE/./c}. + + Similarly, for the %{FILE} substitution + you may want to replace the '/' 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 c use + %{FILE///c}/ + + One example of a tool that can generate syntax-highlighted + HTML from your source code, complete with anchors suitable for use + from haddock, is + hscolour. + + + + + + + + URL + + + + =URL + + + Deprecated aliases for + + + + + + + =URL + + + + =URL + + + + =URL + + + Include links to pages where readers may comment on the + documentation. This feature would typically be used in conjunction + with a Wiki system. + + Use the option to add a + user comments link in the header bar of the contents and index pages. + Use the to add a user comments + link in the header bar of each module page. Use the + option to add a comments link + next to the documentation for every value and type in each module. + + + In each case URL 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 and + options above. + + For example, if you want to link the contents page to a wiki + page, and every module to subpages, you would say + haddock --comments-base=url + --comments-module=url/%M + + If your Wiki system doesn't like the '.' character + in Haskell module names, you can replace it with a different character. For + example to replace the '.' characters with + '_' use haddock + --comments-base=url + --comments-module=url/%{MODULE/./_} + Similarly, you can replace the '/' in a file name (may + be useful for entity comments, but probably not.) + + + + + + + + file + + + + =file + + + 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. + + + + + + + file + + + + =file + + + Specify a file containing documentation which is + placed on the main contents page under the heading + “Description”. The file is parsed as a normal + Haddock doc comment (but the comment markers are not + required). + + + + + + + title + + + + =title + + + Use title as the page + heading for each page in the documentation.This will + normally be the name of the library being documented. + + The title should be a plain string (no markup + please!). + + + + + + + + + + + + + + Produce extra debugging output. + + + + + + + + + + + + + + Display help and exit. + + + + + + + + + + + + + + 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 Prelude). + + + + + + + + + + + + + + Output version information and exit. + + + + + + + + + + When generating HTML, do not generate an index. + Instead, redirect the Index link on each page to + URL. This option is intended for + use in conjuction with for + generating a separate index covering multiple + libraries. + + + + + + + + + + Generate an HTML index containing entries pulled from + all the specified interfaces (interfaces are specified using + or ). + This is used to generate a single index for multiple sets of + Haddock documentation. + + + + + + + + + + + Causes Haddock to behaves as if every module has the + ignore-exports attribute (). This might be useful for + generating implementation documentation rather than interface + documetnation, for example. + + + + + + + +  module + + + Causes Haddock to behaves as if module + module has the hide + atribute. (). + + + + + + + + + + + + + + Turn off all warnings. + + + + +
+ Using literate or pre-processed source + + 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 to GHC + using . + +
+ + + + + Documentation and Markup + + 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. + +
+ Documenting a top-level declaration + + 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: + + +square :: Int -> Int +square x = x * x + + + Then we can document it like this: + + +-- |The 'square' function squares an integer. +square :: Int -> Int +square x = x * x + + + + The -- | syntax begins a + documentation annotation, which applies to the + following declaration in the source file. + Note that the annotation is just a comment in Haskell — it + will be ignored by the Haskell compiler. + + The declaration following a documentation annotation + should be one of the following: + + + A type signature for a top-level function, + + + A data declaration, + + + A newtype declaration, + + + A type declaration, or + + + A class declaration. + + + + If the annotation is followed by a different kind of + declaration, it will probably be ignored by Haddock. + + Some people like to write their documentation + after the declaration; this is possible in + Haddock too: + + +square :: Int -> Int +-- ^The 'square' function squares an integer. +square x = x * x + + + Note that Haddock doesn't contain a Haskell type system + — 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. + + Documentation annotations may span several lines; the + annotation continues until the first non-comment line in the + source file. For example: + + +-- |The 'square' function squares an integer. +-- It takes one argument, of type 'Int'. +square :: Int -> Int +square x = x * x + + + You can also use Haskell's nested-comment style for + documentation annotations, which is sometimes more convenient + when using multi-line comments: + + +{-| + The 'square' function squares an integer. + It takes one argument, of type 'Int'. +-} +square :: Int -> Int +square x = x * x + + +
+
+ Documenting parts of a declaration + + In addition to documenting the whole declaration, in some + cases we can also document individual parts of the + declaration. + +
+ Class methods + + Class methods are documented in the same way as top + level type signatures, by using either the + -- | or + -- ^ + annotations: + + +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 + +
+ +
+ Constructors and record fields + + Constructors are documented like so: + + +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 + + + or like this: + + +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 + + + Record fields are documented using one of these + styles: + + +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 + } + + + 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. +
+ +
+ Function arguments + + Individual arguments to a function may be documented + like this: + + +f :: Int -- ^ The 'Int' argument + -> Float -- ^ The 'Float' argument + -> IO () -- ^ The return value + +
+
+ +
+ The module description + + 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 Description in the + documentation for the module. For example: + + +-- | This is the description for module "Foo" +module Foo where +... + +
+ +
+ Controlling the documentation structure + + Haddock produces interface documentation that lists only + the entities actually exported by the module. The documentation + for a module will include all 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. + + 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 + order 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 module 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. + + You can insert headings and sub-headings in the + documentation by including annotations at the appropriate point + in the export list. For example: + + +module Foo ( + -- * Classes + C(..), + -- * Types + -- ** A data type + T, + -- ** A record + R, + -- * Some functions + f, g + ) where + + + Headings are introduced with the syntax + -- *, + -- ** and so on, where + the number of *s indicates the level of the + heading (section, sub-section, sub-sub-section, etc.). + + If you use section headings, then Haddock will generate a + table of contents at the top of the module documentation for + you. + + The alternative style of placing the commas at the + beginning of each line is also supported. eg.: + + +module Foo ( + -- * Classes + , C(..) + -- * Types + -- ** A data type + , T + -- ** A record + , R + -- * Some functions + , f + , g + ) where + + +
+ Re-exporting an entire module + + 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: + + +module A ( + module B, + module C + ) where + + + What will the Haddock-generated documentation for this + module look like? Well, it depends on how the modules + B and C are imported. + If they are imported wholly and without any + hiding qualifiers, then the documentation + will just contain a cross-reference to the documentation for + B and C. However, if + the modules are not completely + re-exported, for example: + + +module A ( + module B, + module C + ) where + +import B hiding (f) +import C (a, b) + + + then Haddock behaves as if the set of entities + re-exported from B and C + had been listed explicitly in the export + listNOTE: this is not fully implemented at the + time of writing (version 0.2). At the moment, Haddock always + inserts a cross-reference. + . + + The exception to this rule is when the re-exported + module is declared with the hide attribute + (), in which case the module + is never cross-referenced; the contents are always expanded in + place in the re-exporting module. +
+ +
+ Omitting the export list + + If there is no export list in the module, how does + Haddock generate documentation? Well, when the export list is + omitted, e.g.: + +module Foo where + + 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). +
+
+ +
+ Named chunks of documentation + + 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: + + + + The documentation can be included in the export list + directly, e.g.: + + +module Foo ( + -- * A section heading + + -- | Some documentation not attached to a particular Haskell entity + ... + ) where + + + + + 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 + -- $: + + +module Foo ( + -- * A section heading + + -- $doc + ... + ) where + +-- $doc +-- Here is a large chunk of documentation which may be referred to by +-- the name $doc. + + + The documentation chunk is given a name, which is the + sequence of alphanumeric characters directly after the + -- $, and it may be + referred to by the same name in the export list. + + +
+ +
+ Hyperlinking and re-exported entities + + 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? + + Let's look at an example. Suppose we have three modules + A, B and + C defined as follows: + + +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 + + + Module A exports a datatype + T. Module B imports + A and exports a function f + whose type refers to T. Also, both + T and f are re-exported from + module C. + + Haddock takes the view that each entity has a + home 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. + + How is the home module for an entity determined? + Haddock uses the following rules: + + + + If modules A and B both export the entity, and module A imports + (directly or indirectly) module B, then B is preferred. + + + A module with the hide attribute is never + chosen as the home. + + + A module with the not-home atribute is only + chosen if there are no other modules to choose. + + + + 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. + + In the example above, module A is chosen as the + home for T because it does not import any other + module that exports T. The link from + f's + type in module B will therefore point to + A.T. However, C also exports + T and f, and the link from + f's type in C will therefore + point locally to C.T. +
+ +
+ Module Attributes + + 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 + {-# OPTIONS_HADDOCK ... #-} pragma at the + top of the module, either before or after the module + description. For example: + + +{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-} + +-- |Module description +module A where +... + + + The options and module description can be in either order. + + The following attributes are currently understood by + Haddock: + + + + + hide + hide + + + Omit this module from the generated documentation, + but nevertheless propagate definitions and documentation + from within this module to modules that re-export those + definitions. + + + + + + hide + prune + + + Omit definitions that have no documentation + annotations from the generated documentation. + + + + + + ignore-exports + ignore-exports + + + 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. + + + + + + not-home + not-home + + + 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 + for more details. + + + + +
+ +
+ Markup + + Haddock understands certain textual cues inside + documentation annotations that tell it how to render the + documentation. The cues (or markup) have been + designed to be simple and mnemonic in ASCII so that the + programmer doesn't have to deal with heavyweight annotations + when editing documentation comments. + +
+ Paragraphs + + One or more blank lines separates two paragraphs in a + documentation comment. +
+ +
+ Special characters + + The following characters have special meanings in + documentation comments: /, + ', `, + ", @, + <. To insert a literal occurrence of + one of these special characters, precede it with a backslash + (\). + + Additionally, the character > has + a special meaning at the beginning of a line, and the + following characters have special meanings at the beginning of + a paragraph: + *, -. These characters + can also be escaped using \. +
+ +
+ Character references + + Although Haskell source files may contain any character + from the Unicode character set, the encoding of these characters + as bytes varies between systems, so that only source files + restricted to the ASCII character set 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 + &#D; + and + &#xH; + where D and H + are decimal and hexadecimal numbers denoting a code position + in Unicode (or ISO 10646). For example, the references + &#x3BB;, &#x3bb; + and &#955; all represent the lower-case + letter lambda. +
+ +
+ Code Blocks + + Displayed blocks of code are indicated by surrounding a + paragraph with @...@ or by preceding each + line of a paragraph with > (we often + call these “bird tracks”). For + example: + + +-- | This documentation includes two blocks of code: +-- +-- @ +-- f x = x + x +-- @ +-- +-- > g x = x * 42 + + + There is an important difference between the two forms + of code block: in the bird-track form, the text to the right + of the ‘>’ is interpreted + literally, whereas the @...@ form + interprets markup as normal inside the code block. +
+ +
+ Hyperlinked Identifiers + + Referring to a Haskell identifier, whether it be a type, + class, constructor, or function, is done by surrounding it + with single quotes: + + +-- | This module defines the type 'T'. + + + If there is an entity T in scope in + the current module, then the documentation will hyperlink the + reference in the text to the definition of + T (if the output format supports + hyperlinking, of course; in a printed format it might instead + insert a page reference to the definition). + + 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: + + +-- | The identifier 'M.T' is not in scope + + + If M.T is not otherwise in scope, + then Haddock will simply emit a link pointing to the entity + T exported from module M + (without checking to see whether either M + or M.T exist). + + 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: + + +-- | I don't have to escape my apostrophes; great, isn't it? + + + For compatibility with other systems, the following + alternative form of markup is accepted + We chose not to use this as the primary markup for + identifiers because strictly speaking the ` + character should not be used as a left quote, it is a grave accent. + : `T'. +
+ +
+ Emphasis and Monospaced text + + Emphasis may be added by surrounding text with + /.../. + + Monospaced (or typewriter) text is indicated by + surrounding it with @...@. Other markup is + valid inside a monospaced span: for example + @'f' a b@ will hyperlink the + identifier f inside the code fragment. +
+ +
+ Linking to modules + + Linking to a module is done by surrounding the module + name with double quotes: + + +-- | This is a reference to the "Foo" module. + + +
+ +
+ Itemized and Enumerated lists + + A bulleted item is represented by preceding a paragraph + with either * or + -. A sequence of bulleted + paragraphs is rendered as an itemized list in the generated + documentation, eg.: + + +-- | This is a bulleted list: +-- +-- * first item +-- +-- * second item + + + An enumerated list is similar, except each paragraph + must be preceded by either + (n) + or + n. + where n is any integer. e.g. + + +-- | This is an enumerated list: +-- +-- (1) first item +-- +-- 2. second item + +
+ +
+ Definition lists + + Definition lists are written as follows: + + +-- | This is a definition list: +-- +-- [@foo@] The description of @foo@. +-- +-- [@bar@] The description of @bar@. + + + To produce output something like this: + + + + foo + + The description of foo. + + + + bar + + The description of bar. + + + + + Each paragraph should be preceded by the + “definition term” 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 [ character, then + it is assumed to be a definition paragraph, and the next + ] character found will close the definition + term. Other markup operators may be used freely within the + definition term. +
+ +
+ URLs + + A URL can be included in a documentation comment by + surrounding it in angle brackets: + <...>. If the output format supports + it, the URL will be turned into a hyperlink when + rendered. +
+ +
+ Anchors + + 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 anchors to be + included in a documentation comment. The syntax is + #label#, where + label is the name of the anchor. + An anchor is invisible in the generated documentation. + + To link to an anchor from elsewhere, use the syntax + "module#label" + where module is the module name + containing the anchor, and label is + the anchor label. The module does not have to be local, it + can be imported via an interface. +
+
+ + + diff --git a/examples/A.hs b/examples/A.hs new file mode 100644 --- /dev/null +++ b/examples/A.hs @@ -0,0 +1,2 @@ +module A where +data A = A diff --git a/examples/B.hs b/examples/B.hs new file mode 100644 --- /dev/null +++ b/examples/B.hs @@ -0,0 +1,2 @@ +module B ( module A ) where +import A diff --git a/examples/Bug1.hs b/examples/Bug1.hs new file mode 100644 --- /dev/null +++ b/examples/Bug1.hs @@ -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 + diff --git a/examples/Bug2.hs b/examples/Bug2.hs new file mode 100644 --- /dev/null +++ b/examples/Bug2.hs @@ -0,0 +1,4 @@ +module Bug2 ( x ) where +import B +x :: A +x = A diff --git a/examples/Bug3.hs b/examples/Bug3.hs new file mode 100644 --- /dev/null +++ b/examples/Bug3.hs @@ -0,0 +1,6 @@ +module Bug3 where + +-- | /multi-line +-- emphasis/ +foo :: Int + diff --git a/examples/Bug4.hs b/examples/Bug4.hs new file mode 100644 --- /dev/null +++ b/examples/Bug4.hs @@ -0,0 +1,4 @@ +module Bug4 where +-- | don't use apostrophe's in the wrong place's +foo :: Int + diff --git a/examples/Bug6.hs b/examples/Bug6.hs new file mode 100644 --- /dev/null +++ b/examples/Bug6.hs @@ -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 } diff --git a/examples/Bug7.hs b/examples/Bug7.hs new file mode 100644 --- /dev/null +++ b/examples/Bug7.hs @@ -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 diff --git a/examples/Bug8.hs b/examples/Bug8.hs new file mode 100644 --- /dev/null +++ b/examples/Bug8.hs @@ -0,0 +1,8 @@ +infix --> +infix ---> + +data Typ = Type (String,[Typ]) + | TFree (String, [String]) + +x --> y = Type("fun",[s,t]) +(--->) = flip $ foldr (-->) diff --git a/examples/Bug9.hs b/examples/Bug9.hs new file mode 100644 --- /dev/null +++ b/examples/Bug9.hs @@ -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 } diff --git a/examples/Hash.hs b/examples/Hash.hs new file mode 100644 --- /dev/null +++ b/examples/Hash.hs @@ -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 + diff --git a/examples/Hidden.hs b/examples/Hidden.hs new file mode 100644 --- /dev/null +++ b/examples/Hidden.hs @@ -0,0 +1,4 @@ +-- #hide +module Hidden where +hidden :: Int -> Int +hidden a = a diff --git a/examples/Makefile b/examples/Makefile new file mode 100644 --- /dev/null +++ b/examples/Makefile @@ -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 diff --git a/examples/NoLayout.hs b/examples/NoLayout.hs new file mode 100644 --- /dev/null +++ b/examples/NoLayout.hs @@ -0,0 +1,4 @@ +module NoLayout where { + -- | the class 'C' + g :: Int; + } diff --git a/examples/Test.hs b/examples/Test.hs new file mode 100644 --- /dev/null +++ b/examples/Test.hs @@ -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: . +-} + +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 diff --git a/examples/Visible.hs b/examples/Visible.hs new file mode 100644 --- /dev/null +++ b/examples/Visible.hs @@ -0,0 +1,3 @@ +module Visible where +visible :: Int -> Int +visible a = a diff --git a/examples/hide-bug/A.hs b/examples/hide-bug/A.hs new file mode 100644 --- /dev/null +++ b/examples/hide-bug/A.hs @@ -0,0 +1,2 @@ +-- #hide +module A where { data T = MkT; f :: T; f = MkT } diff --git a/examples/hide-bug/B.hs b/examples/hide-bug/B.hs new file mode 100644 --- /dev/null +++ b/examples/hide-bug/B.hs @@ -0,0 +1,5 @@ +module B(Test, vis) where + +vis = id + +data Test = Test diff --git a/examples/hide-bug/C.hs b/examples/hide-bug/C.hs new file mode 100644 --- /dev/null +++ b/examples/hide-bug/C.hs @@ -0,0 +1,6 @@ +module C(C.bla) where + +import D + +bla :: Test +bla = undefined diff --git a/examples/hide-bug/D.hs b/examples/hide-bug/D.hs new file mode 100644 --- /dev/null +++ b/examples/hide-bug/D.hs @@ -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 diff --git a/haddock-leksah.cabal b/haddock-leksah.cabal new file mode 100644 --- /dev/null +++ b/haddock-leksah.cabal @@ -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 +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 + diff --git a/haddock.spec b/haddock.spec new file mode 100644 --- /dev/null +++ b/haddock.spec @@ -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 +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} diff --git a/haskell.vim b/haskell.vim new file mode 100644 --- /dev/null +++ b/haskell.vim @@ -0,0 +1,68 @@ +" Attempt to add haddock highlighting for haskell comments +" It should be placed in ~/.vim/after/syntax/haskell.vim +" Brad Bowman + +syn match hsHdocChunk "$\i\+" contained +syn match hsHdocMod /"\(\i\|[.]\)\+"/ contained +syn match hsHdocLink "'\(\i\|[.#]\)\+'" contained +syn region hsHdocAnchor start="\\\@" contained oneline +syn region hsHdocCode start="\\\@" 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 + else + command -nargs=+ HiLink hi def link + 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 diff --git a/html/frames.html b/html/frames.html new file mode 100644 --- /dev/null +++ b/html/frames.html @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + diff --git a/html/haddock-DEBUG.css b/html/haddock-DEBUG.css new file mode 100644 --- /dev/null +++ b/html/haddock-DEBUG.css @@ -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 + } + diff --git a/html/haddock-util.js b/html/haddock-util.js new file mode 100644 --- /dev/null +++ b/html/haddock-util.js @@ -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; + } +} diff --git a/html/haddock.css b/html/haddock.css new file mode 100644 --- /dev/null +++ b/html/haddock.css @@ -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; +} + +/* 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; +} + + diff --git a/html/haskell_icon.gif b/html/haskell_icon.gif new file mode 100644 Binary files /dev/null and b/html/haskell_icon.gif differ diff --git a/html/minus.gif b/html/minus.gif new file mode 100644 Binary files /dev/null and b/html/minus.gif differ diff --git a/html/plus.gif b/html/plus.gif new file mode 100644 Binary files /dev/null and b/html/plus.gif differ diff --git a/src/Distribution/Haddock.hs b/src/Distribution/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Haddock.hs @@ -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 + diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/DevHelp.hs @@ -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 "" $$ + (text "text doctitle<> + text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$ + text "" $$ + nest 4 (ppModuleTree [] tree) $+$ + text "" $$ + text "" $$ + nest 4 (ppList index) $+$ + text "" $$ + text "" + 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 "ppAttribs<>text "/>" + _ -> + text "ppAttribs<>text ">" $$ + nest 4 (ppModuleTree (s:ss) ts) $+$ + text "" + 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 "text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$ + ppReference name refs diff --git a/src/Haddock/Backends/HH.hs b/src/Haddock/Backends/HH.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/HH.hs @@ -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 "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + ppModuleTree tree $$ + text "" + writeFile (pathJoin [odir, contentsHHFile]) (render html) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [ModuleTree] -> Doc + ppModuleTree ts = + text "" $$ + text "" $$ + text "" $$ + text "
    " $+$ + nest 4 (text "
  • " <> nest 4 + (text "" $$ + nest 4 (text "text doctitle<>text "\">" $$ + text "") $$ + text "") $+$ + text "
    • " $$ + text "
      " $+$ + nest 4 (fn [] ts) $+$ + text "
    ") $+$ + text "
" + + 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 "
    " $+$ + nest 4 (fn (s:ss) ts) $+$ + text "
" + + ppLeaf s ss isleaf = + text "
  • " <> nest 4 + (text "" $$ + text " text s <> text "\">" $$ + (if isleaf then text " text (moduleHtmlFile mdl) <> text "\">" else empty) $$ + text "") $+$ + text "
    • " + 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 "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "
      " $+$ + nest 4 (ppList index) $+$ + text "
    " $$ + text "" + 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 "
  • " <> nest 4 + (text "" $$ + text " text (show name) <> text "\">" $$ + ppReference name refs $$ + text "") $+$ + text "
    • " $$ + ppList mdls + + ppReference name [] = empty + ppReference name (Module mdl:refs) = + text " 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 +-} diff --git a/src/Haddock/Backends/HH2.hs b/src/Haddock/Backends/HH2.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/HH2.hs @@ -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 "" $$ + text "" $$ + text "" $$ + nest 4 (text "text doctitle<>text"\" Url=\"index.html\">" $$ + nest 4 (ppModuleTree [] tree) $+$ + text "") $$ + text "" + 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 " ppAttributes leaf (s:ss) <> text "/>" + ppNode ss (Node s leaf _pkg _short ts) = + text " ppAttributes leaf (s:ss) <> text ">" $$ + nest 4 (ppModuleTree (s:ss) ts) $+$ + text "" + + 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 "" $$ + text "" $$ + text "" $$ + nest 4 (ppList index) $+$ + text "" + docN = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + nest 4 (text "text contentsHtmlFile<>text "\"/>") $$ + text "" $$ + text "" + 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 " text (escapeStr (show name)) <> text "\">" $$ + nest 4 (vcat (map (ppJump name) mdls)) $$ + text "" $$ + ppList vs + + ppJump name (Module mdl) = text " 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 "" $$ + text "" $$ + text "" $$ + nest 4 (ppMods ifaces $$ + text "text contentsHtmlFile<>text "\"/>" $$ + text "text indexHtmlFile<>text "\"/>" $$ + ppIndexFiles chars $$ + ppLibFiles ("":pkg_paths)) $$ + text "" + writeFile (pathJoin [odir, filesHH2File]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppMods [] = empty + ppMods (iface:ifaces) = + text " text (moduleHtmlFile mdl) <> text "\"/>" $$ + ppMods ifaces + where Module mdl = iface_module iface + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text "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 "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 "" $$ + text "" $$ + text " text doctitle <> text "\">" $$ + nest 4 (text "" $$ + nest 4 (text " text package <> text ".HxF\"/>") $$ + text "" $$ + text " text package <> text ".HxT\"/>" $$ + text " text package <> text "K.HxK\"/>" $$ + text " text package <> text "N.HxK\"/>" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "") $$ + text "" + writeFile (pathJoin [odir, collectionHH2File]) (render doc) +-} diff --git a/src/Haddock/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/HaddockDB.hs @@ -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 "" + $$ text "" + $$ text "" + $$ text "HaskellDoc version 0.0" + $$ text "" + $$ text "
    " + $$ vcat (map do_mod mods) + $$ text "
    " + where + do_mod (Module mod, iface) + = text " text mod <> text "\">" + $$ text "<literal>" + <> text mod + <> text "</literal>" + $$ text "" + <> text mod + <> text "" + $$ text "" + $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) + $$ text "" + $$ text "" + + do_export mod decl | (nm:_) <- declBinders decl + = text "" + <> do_decl decl + <> text "" + $$ text "" + $$ text "" + $$ text "" + $$ text "" + $$ text "" + do_export _ _ = empty + + do_decl (HsTypeSig _ [nm] ty _) + = ppHsName nm <> text " :: " <> ppHsType ty + do_decl (HsTypeDecl _ nm args ty _) + = hsep ([text "type", ppHsName nm ] + ++ map ppHsName args + ++ [equals, ppHsType ty]) + do_decl (HsNewTypeDecl loc ctx nm args con drv _) + = hsep ([text "data", ppHsName nm] -- data, not newtype + ++ map ppHsName args + ) <+> equals <+> ppHsConstr con -- ToDo: derivings + do_decl (HsDataDecl loc ctx nm args cons drv _) + = hsep ([text "data", {-ToDo: context-}ppHsName nm] + ++ map ppHsName args) + <+> vcat (zipWith (<+>) (equals : repeat (char '|')) + (map ppHsConstr cons)) + do_decl (HsClassDecl loc ty fds decl _) + = hsep [text "class", ppHsType ty] + do_decl decl + = empty + +ppHsConstr :: HsConDecl -> Doc +ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = + ppHsName name + <> (braces . hsep . punctuate comma . map ppField $ fieldList) +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = + hsep (ppHsName name : map ppHsBangType typeList) + +ppField (HsFieldDecl ns ty doc) + = hsep (punctuate comma (map ppHsName ns) ++ + [text "::", ppHsBangType ty]) + +ppHsBangType :: HsBangType -> Doc +ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty +ppHsBangType (HsUnBangedTy ty) = ppHsType ty + +ppHsContext :: HsContext -> Doc +ppHsContext [] = empty +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> + hsep (map ppHsAType b)) context) + +ppHsType :: HsType -> Doc +ppHsType (HsForAllType Nothing context htype) = + hsep [ ppHsContext context, text "=>", ppHsType htype] +ppHsType (HsForAllType (Just tvs) [] htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) +ppHsType (HsForAllType (Just tvs) context htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : + ppHsContext context : text "=>" : [ppHsType htype]) +ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] +ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] +ppHsType t = ppHsBType t + +ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b] +ppHsBType t = ppHsAType t + +ppHsAType :: HsType -> Doc +ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l +ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l +-- special case +ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsAType (HsTyVar name) = ppHsName name +ppHsAType (HsTyCon name) = ppHsQName name +ppHsAType t = parens $ ppHsType t + +ppHsQName :: HsQName -> Doc +ppHsQName (UnQual str) = ppHsName str +ppHsQName n@(Qual (Module mod) str) + | n == unit_con_name = ppHsName str + | isSpecial str = ppHsName str + | otherwise + = text "" + +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 "#)" +-} diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Hoogle.hs @@ -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 | " " `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) = ["
    "] ++ showPre xs ++ ["
    "] +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) ++ "" + 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 ++ "" + f x = fs $ asInline x + + +unwordsWrap :: Int -> [String] -> [String] +unwordsWrap n = f n [] + where + f _ s [] = [g s | s /= []] + f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs + | otherwise = f (i - nx - 1) (x:s) xs + where nx = length x + + g = unwords . reverse + + +escape :: String -> String +escape = concatMap f + where + f '<' = "<" + f '>' = ">" + f '&' = "&" + f x = [x] diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Html.hs @@ -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

    (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

    ..

    +-- 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"] diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/GhcUtils.hs @@ -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 _ _ = [] diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Interface.hs @@ -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 diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Interface/AttachInstances.hs @@ -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) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Interface/Create.hs @@ -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 diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Interface/Rename.hs @@ -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') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/InterfaceFile.hs @@ -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" + diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/ModuleTree.hs @@ -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] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Options.hs @@ -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" + ] diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Types.hs @@ -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 diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils.hs @@ -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 diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/BlockTable.hs @@ -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 + 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 "" diff --git a/src/Haddock/Utils/FastMutInt2.hs b/src/Haddock/Utils/FastMutInt2.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/FastMutInt2.hs @@ -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 + diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Utils/Html.hs @@ -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 +-- 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 >,etc. + +data HtmlElement +{- + - ..just..plain..normal..text... but using © and &amb;, etc. + -} + = HtmlString String +{- + - ..content.. + -} + | 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 '<' = "<" + fixChar '>' = ">" + fixChar '&' = "&" + fixChar '"' = """ + 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 ' ' = " " + 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"] << ("") + +-- --------------------------------------------------------------------------- +-- 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 = + "\n" ++ + "\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 " String + showPair (HtmlAttr tag0 val) + = tag0 ++ "=\"" ++ val ++ "\"" + diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Version.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 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 + diff --git a/src/haddock.sh b/src/haddock.sh new file mode 100644 --- /dev/null +++ b/src/haddock.sh @@ -0,0 +1,7 @@ +# Mini-driver for Haddock + +# needs the following variables: +# HADDOCKLIB +# HADDOCKBIN + +$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}