diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,33 @@ +Changes in version 2.15.0 + + * Always read in prologue files as UTF8 (#286 and Cabal #1721) + + * parser: don't wrap headers in DocParagraph (#307) + + * parser: don't mangle append order for nested lists (pandoc #1346) + + * parser: preserve list ordering in certain scenarios (#313) + + * parser: update the attoparsec version used internally giving slight + parsing performance boost. + + * Move development to be against latest GHC release and not GHC HEAD. + + * Further split up the package to separate the executable from the + library, necessary by things like GHCJS. We now have + ‘haddock-library’ which are the parts that don't use GHC API, + ‘haddock-api’ which are (some of) the parts that do use GHC API and + ‘haddock’ which merely provides the executable. + + * Export few extra functions in the API. + + * Add compatibility with GHC 7.8.2. + + * Omit unnecessary ‘forall’s (#315 and #86) + + * Remove some files which were really old or did not belong in the + repository in the first place. + Changes in version 2.14.3 * Fix parsing of identifiers with ^ or ⋆ in them (#298) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -5,11 +5,11 @@ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR diff --git a/README b/README --- a/README +++ b/README @@ -6,13 +6,12 @@ documenting library interfaces, but it should be useful for any kind of Haskell code. -Like other systems ([1],[2]), Haddock lets you write documentation -annotations next to the definitions of functions and types in the -source code, in a syntax that is easy on the eye when writing the -source code (no heavyweight mark-up). The documentation generated by -Haddock is fully hyperlinked - click on a type name in a type -signature to go straight to the definition, and documentation, for -that type. +Haddock lets you write documentation annotations next to the +definitions of functions and types in the source code, in a syntax +that is easy on the eye when writing the source code (no heavyweight +mark-up). The documentation generated by Haddock is fully hyperlinked +- click on a type name in a type signature to go straight to the +definition, and documentation, for that type. Haddock understands Haskell's module system, so you can structure your code however you like without worrying that internal structure will be @@ -28,21 +27,11 @@ useful documentation from your source code. Haddock can generate documentation in multiple formats; currently HTML -is implemented, and there is partial support for generating DocBook. -The generated HTML uses stylesheets, so you need a fairly up-to-date -browser to view it properly (Mozilla, Konqueror, Opera, and IE 6 -should all be ok). +is implemented, and there is partial support for generating LaTeX and +Hoogle. Full documentation can be found in the doc/ subdirectory, in DocBook format. -Please send questions and suggestions to: - -David Waern 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/ +Please create issues when you have any problems and pull requests if +you have some code. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/doc/haddock.xml b/doc/haddock.xml --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -21,2096 +21,2100 @@ Simon Marlow, David Waern - This document describes Haddock version 2.14.3, 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 obscure the code and to make reading and writing - documentation annotations easy. The easier it is to write - documentation, the more likely the programmer is to do it. - Haddock therefore uses lightweight markup in its annotations, - taking several ideas from 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, LaTeX, - and Hoogle backends, and it is structured in such a way that adding new - backends 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-2010, Simon Marlow. All rights reserved. - - Redistribution and use in source and binary forms, with - or without modification, are permitted provided that the - following conditions are met: - - - - Redistributions of source code must retain the above - copyright notice, this list of conditions and the - following disclaimer. - - - Redistributions in binary form must reproduce the - above copyright notice, this list of conditions and the - following disclaimer in the documentation and/or other - materials provided with the distribution. - - - - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS - IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND - FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT - SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, - INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; - OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF - LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF - THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY - OF SUCH DAMAGE. -
-
- -
- Contributors - Haddock was originally written by Simon Marlow. Since it is an open source - project, many people have contributed to its development over the years. - Below is a list of contributors in alphabetical order that we hope is - somewhat complete. If you think you are missing from this list, please contact - us. - - - Ashley Yakeley - Benjamin Franksen - Brett Letner - Clemens Fruhwirth - Conal Elliott - David Waern - Duncan Coutts - George Pollard - George Russel - Hal Daume - Ian Lynagh - Isaac Dupree - Joachim Breitner - Krasimir Angelov - Lennart Augustsson - Luke Plant - Malcolm Wallace - Manuel Chakravarty - Mark Lentczner - Mark Shields - Mateusz Kowalczyk - Mike Thomas - Neil Mitchell - Oliver Brown - Roman Cheplyaka - Ross Paterson - Sigbjorn Finne - Simon Hengel - Simon Marlow - Simon Peyton-Jones - Stefan O'Rear - Sven Panne - Thomas Schilling - Wolfgang Jeltsch - Yitzchak Gale - -
-
- Acknowledgements - - Several documentation systems provided the inspiration for - Haddock, most notably: - - - - - IDoc - - - HDoc - - - - Doxygen - - - - and probably several others I've forgotten. - - Thanks to the the members - of haskelldoc@haskell.org, - haddock@projects.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 - identifiers it couldn't resolve. - - The modules should not be mutually - recursive, as Haddock don't like swimming in circles. - - Note that while older version would fail on invalid markup, this is considered a bug in the - new versions. If you ever get failed parsing message, please report it. - - 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. - - - - - - - dir - - - - =dir - - - Generate files into dir - instead of the current directory. - - - - - - - dir - - - - =dir - - - Use Haddock auxiliary files (themes, javascript, etc...) in dir. - - - - - - - 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. - - - - - - - - - - - - - - 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: - - - module.html - mini_module.html - - An HTML page for each - module, and a "mini" page for - each used when viewing in frames. - - - - index.html - - The top level page of the documentation: lists - the modules available, using indentation to represent - the hierarchy if the modules are hierarchical. - - - - doc-index.html - doc-index-X.html - - The alphabetic index, possibly split into multiple - pages if big enough. - - - - frames.html - - The top level document when viewing in frames. - - - - some.css - etc... - - Files needed for the themes used. Specify your themes - using the option. - - - - haddock-util.js - - Some JavaScript utilities used to implement some of the - dynamic features like collapsible sections, and switching to - frames view. - - - - - - - - - - - - - Generate documentation in LaTeX format. Several files - will be generated into the current directory (or the - specified directory if the option is - given), including the following: - - - - package.tex - - The top-level LaTeX source file; to format the - documentation into PDF you might run something like - this: - -$ pdflatex package.tex - - - - haddock.sty - - The default style. The file contains - definitions for various macros used in the LaTeX - sources generated by Haddock; to change the way the - formatted output looks, you might want to override - these by specifying your own style with - the option. - - - - module.tex - - The LaTeX documentation for - each module. - - - - - - - - - - - - - This option lets you override the default style used - by the LaTeX generated by the option. - Normally Haddock puts a - standard haddock.sty in the output - directory, and includes the - command \usepackage{haddock} in the - LaTeX source. If this option is given, - then haddock.sty is not generated, - and the command is - instead \usepackage{style}. - - - - - - - - - - - - - - - Reserved for future use (output documentation in DocBook XML - format). - - - - - - - =URL - - - - =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. - is a flag that gets used for - entities that need to link to an exact source location rather than a - name, eg. since they were defined inside a Template Haskell splice. - - - 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.) - - - - - - - - =path - - - Specify a theme to be used for HTML () - documentation. If given multiple times then the pages will use the - first theme given by default, and have alternate style sheets for - the others. The reader can switch between themes with browsers that - support alternate style sheets, or with the "Style" menu that gets - added when the page is loaded. If - no themes are specified, then just the default built-in theme - ("Ocean") is used. - - - The path parameter can be one of: - - - - - A directory: The base name of - the directory becomes the name of the theme. The directory - must contain exactly one - some.css file. - Other files, usually image files, will be copied, along with - the some.css - file, into the generated output directory. - - - A CSS file: The base name of - the file becomes the name of the theme. - - - The name of a built-in theme - ("Ocean" or "Classic"). - - - - - - - - - - - - Includes the built-in themes ("Ocean" and "Classic"). - Can be combined with . Note that order - matters: The first specified theme will be the default. - - - - - - - file - - - - =file - - - Deprecated aliases for - - - - - - - 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!). - - - - - - - mode - - - - =mode - - - - Specify how identifiers are qualified. - - - mode should be one of - - - none (default): don't qualify any identifiers - - - full: always qualify identifiers completely - - - local: only qualify identifiers that are not part - of the module - - - relative: like local, but strip name of the module - from qualifications of identifiers in submodules - - - - - Example: If you generate documentation for module A, then the - identifiers A.x, A.B.y and C.z are qualified as follows. - - - - - none: x, y, z - - - full: A.x, A.B.y, C.z - - - local: x, A.B.y, C.z - - - relative: x, B.y, C.z - - - - - - - - - - - - - - - - - Display help and exit. - - - - - - - - - - - - - - Output version information 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). - - - - - - - - - - - - - - When generating HTML, do not generate an index. - Instead, redirect the Contents and/or Index link on each page to - URL. This option is intended for - use in conjunction with and/or - for - generating a separate contents and/or index covering multiple - libraries. - - - - - - - - - - - - - - Generate an HTML contents and/or index containing entries pulled - from all the specified interfaces (interfaces are specified using - or ). - This is used to generate a single contents and/or index for multiple - sets of Haddock documentation. - - - - - - - - - - - Causes Haddock to behave as if every module has the - ignore-exports attribute (). This might be useful for - generating implementation documentation rather than interface - documentation, for example. - - - - - - - -  module - - - Causes Haddock to behave as if module - module has the hide - attribute. (). - - - - - - - -  module - - - Causes Haddock to behave as if module - module has the show-extensions - attribute. (). - - - - - - - =option - - - Pass option to GHC. Note that there is a double dash there, unlike for GHC. - - - - - - - - - - - - - - Turn off all warnings. - - - - - - - - - - - Prints out space-separated versions of binary Haddock interface files that this version is compatible - with. - - - - - - - - - - - - Do not use a temporary directory for reading and writing compilation output files - (.o, .hi, and stub files). Instead, use the - present directory or another directory that you have explicitly told GHC to use - via the --optghc flag. - - - This flag can be used to avoid recompilation if compilation files already exist. - Compilation files are produced when Haddock has to process modules that make use of - Template Haskell, in which case Haddock compiles the modules using the GHC API. - - - - - -
- 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 - - - A class declaration, - - - A data family or - type family declaration, or - - - A data instance or - type instance 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. - - In case that more than one constructor exports a field - with the same name, the documentation attached to the first - occurence of the field will be used, even if a comment is not - present. - - - -data T a = A { someField :: a -- ^ Doc for someField of A - } - | B { someField :: a -- ^ Doc for someField of B - } - - - In the above example, all occurences of - someField in the documentation are going to - be documented with Doc for someField of A. - Note that Haddock versions 2.14.0 and before would join up - documentation of each field and render the result. The reason - for this seemingly weird behaviour is the fact that - someField is actually the same (partial) - function. - -
- -
- 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 itself may be documented with multiple fields - that can then be displayed by the backend. In particular, the - HTML backend displays all the fields it currently knows - about. We first show the most complete module documentation - example and then talk about the fields. - - -{-| -Module : W -Description : Short description -Copyright : (c) Some Guy, 2013 - Someone Else, 2014 -License : GPL-3 -Maintainer : sample@email.com -Stability : experimental -Portability : POSIX - -Here is a longer description of this module, containing some -commentary with @some markup@. --} -module W where -... - - - The Module field should be clear. It - currently doesn't affect the output of any of the backends but - you might want to include it for human information or for any - other tools that might be parsing these comments without the - help of GHC. - - The Description field accepts some short text - which outlines the general purpose of the module. If you're - generating HTML, it will show up next to the module link in - the module index. - - The Copyright, License, - Maintainer and Stability fields - should be obvious. An alternative spelling for the - License field is accepted as - Licence but the output will always prefer - License. - - The Portability field has seen varied use - by different library authors. Some people put down things like - operating system constraints there while others put down which GHC - extensions are used in the module. Note that you might want to - consider using the show-extensions module flag for the - latter. - - Finally, a module may contain a documentation comment - before the module header, in which case this comment is - interpreted by Haddock as an overall description of the module - itself, and placed in a section entitled - Description in the documentation for the module. - All usual Haddock markup is valid in this comment. - - All fields are optional but they must be in order if they - do appear. Multi-line fields are accepted but the consecutive - lines have to start indented more than their label. If your - label is indented one space as is often the case with - -- syntax, the consecutive lines have to start at - two spaces at the very least. Please note that we do not enforce - the format for any of the fields and the established formats are - just a convention. - -
- -
- 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). - - -module Foo where - --- * This heading will now appear before foo. - --- | Documentation for 'foo'. -foo :: Integer -foo = 5 - - -
-
- -
- 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 attribute 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. - - - - - - show-extensions - show-extensions - - - Indicates that we should render the extensions used in this module in the - resulting documentation. This will only render if the output format supports it. - If Language is set, it will be shown as well and all the extensions implied by it won't. - All enabled extensions will be rendered, including those implied by their more powerful versions. - - - - - -
- -
- 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 \. - - Furthermore, the character sequence >>> - has a special meaning at the beginning of a line. To - escape it, just prefix the characters in the sequence with a - backslash. -
- -
- 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. -
- -
- Examples - - Haddock has markup support for examples of interaction with a - read-eval-print loop (REPL). An - example is introduced with - >>> followed by an expression followed - by zero or more result lines: - - --- | Two examples are given below: --- --- >>> fib 10 --- 55 --- --- >>> putStrLn "foo\nbar" --- foo --- bar - - Result lines that only contain the string - <BLANKLINE> are rendered as blank lines in the - generated documentation. -
- -
- Properties - - Haddock provides markup for properties: - --- | Addition is commutative: --- --- prop> a + b = b + a - - This allows third-party applications to extract and verify them. - -
- -
- 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, Bold and Monospaced text - - Emphasis may be added by surrounding text with - /.../. Other markup is valid inside emphasis. To have a forward - slash inside of emphasis, just escape it: /fo\/o/ - - Bold (strong) text is indicated by surrounding it with __...__. - Other markup is valid inside bold. For example, __/foo/__ will make the emphasised - text foo bold. You don't have to escape a single underscore if you need it bold: - __This_text_with_underscores_is_bold__. - - - Monospaced (or typewriter) text is indicated by - surrounding it with @...@. Other markup is - valid inside a monospaced span: for example - @'f' a b@ will hyperlink the - identifier f inside the code fragment. -
- -
- 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. - - - A basic check is done on the syntax of the header name to ensure that it is valid - before turning it into a link but unlike with identifiers, whether the module is in scope isn't checked - and will always be turned into a link. - - -
- -
- 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 - - - Lists of the same type don't have to be separated by a newline: - --- | This is an enumerated list: --- --- (1) first item --- 2. second item --- --- This is a bulleted list: --- --- * first item --- * second item - - - You can have more than one line of content in a list element: - - --- | --- * first item --- and more content for the first item --- * second item --- and more content for the second item - - - You can even nest whole paragraphs inside of list elements. The rules - are 4 spaces for each indentation level. You're required to use a newline before - such nested paragraph: - - -{-| -* Beginning of list -This belongs to the list above! - - > nested - > bird - > tracks - - * Next list - More of the indented list. - - * Deeper - - @ - even code blocks work - @ - - * Deeper - - 1. Even deeper! - 2. No newline separation even in indented lists. --} - - -
- -
- 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. You can escape ] with a backslash as usual. - - Same rules about nesting and no newline separation as for bulleted and numbered lists apply. - - -
- -
- 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. - - The URL can be followed by an optional label: - -<http://example.com label> - - The label is then used as a descriptive text for the hyperlink, if the - output format supports it. - - If Haddock sees something that looks like a URL (such as something starting with - http:// or ssh://) where the URL markup is valid, - it will automatically make it a hyperlink. -
- -
- Images - - An image can be included in a documentation comment by - surrounding it in double angle brackets: - <<...>>. If the output format supports - it, the image will be rendered inside the documentation. - - Title text can be included using an optional label: - -<<pathtoimage.png title>> - - -
- -
- 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. Please note that in Haddock - versions 2.13.x and earlier, the syntax was - "module\#label". - This is deprecated as of version 2.14.3 and will be removed in - future versions. -
- -
- Headings + This document describes Haddock version 2.15.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 obscure the code and to make reading and writing + documentation annotations easy. The easier it is to write + documentation, the more likely the programmer is to do it. + Haddock therefore uses lightweight markup in its annotations, + taking several ideas from 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, LaTeX, + and Hoogle backends, and it is structured in such a way that adding new + backends 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-2010, Simon Marlow. All rights reserved. + + Redistribution and use in source and binary forms, with + or without modification, are permitted provided that the + following conditions are met: + + + + Redistributions of source code must retain the above + copyright notice, this list of conditions and the + following disclaimer. + + + Redistributions in binary form must reproduce the + above copyright notice, this list of conditions and the + following disclaimer in the documentation and/or other + materials provided with the distribution. + + + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS + IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND + FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT + SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, + INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF + THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY + OF SUCH DAMAGE. +
+
+ +
+ Contributors + Haddock was originally written by Simon Marlow. Since it is an open source + project, many people have contributed to its development over the years. + Below is a list of contributors in alphabetical order that we hope is + somewhat complete. If you think you are missing from this list, please contact + us. + + + Ashley Yakeley + Benjamin Franksen + Brett Letner + Clemens Fruhwirth + Conal Elliott + David Waern + Duncan Coutts + George Pollard + George Russel + Hal Daume + Ian Lynagh + Isaac Dupree + Joachim Breitner + Krasimir Angelov + Lennart Augustsson + Luke Plant + Malcolm Wallace + Manuel Chakravarty + Mark Lentczner + Mark Shields + Mateusz Kowalczyk + Mike Thomas + Neil Mitchell + Oliver Brown + Roman Cheplyaka + Ross Paterson + Sigbjorn Finne + Simon Hengel + Simon Marlow + Simon Peyton-Jones + Stefan O'Rear + Sven Panne + Thomas Schilling + Wolfgang Jeltsch + Yitzchak Gale + +
+
+ Acknowledgements + + Several documentation systems provided the inspiration for + Haddock, most notably: + + + + + IDoc + + + HDoc + + + + Doxygen + + + + and probably several others I've forgotten. + + Thanks to the the members + of haskelldoc@haskell.org, + haddock@projects.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 + identifiers it couldn't resolve. + + The modules should not be mutually + recursive, as Haddock don't like swimming in circles. + + Note that while older version would fail on invalid markup, this is considered a bug in the + new versions. If you ever get failed parsing message, please report it. + + 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. + + + + + + + dir + + + + =dir + + + Generate files into dir + instead of the current directory. + + + + + + + dir + + + + =dir + + + Use Haddock auxiliary files (themes, javascript, etc...) in dir. + + + + + + + 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. + + + + + + + + + + + + + + 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: + + + module.html + mini_module.html + + An HTML page for each + module, and a "mini" page for + each used when viewing in frames. + + + + index.html + + The top level page of the documentation: lists + the modules available, using indentation to represent + the hierarchy if the modules are hierarchical. + + + + doc-index.html + doc-index-X.html + + The alphabetic index, possibly split into multiple + pages if big enough. + + + + frames.html + + The top level document when viewing in frames. + + + + some.css + etc... + + Files needed for the themes used. Specify your themes + using the option. + + + + haddock-util.js + + Some JavaScript utilities used to implement some of the + dynamic features like collapsible sections, and switching to + frames view. + + + + + + + + + + + + + Generate documentation in LaTeX format. Several files + will be generated into the current directory (or the + specified directory if the option is + given), including the following: + + + + package.tex + + The top-level LaTeX source file; to format the + documentation into PDF you might run something like + this: + +$ pdflatex package.tex + + + + haddock.sty + + The default style. The file contains + definitions for various macros used in the LaTeX + sources generated by Haddock; to change the way the + formatted output looks, you might want to override + these by specifying your own style with + the option. + + + + module.tex + + The LaTeX documentation for + each module. + + + + + + + + + + + + + This option lets you override the default style used + by the LaTeX generated by the option. + Normally Haddock puts a + standard haddock.sty in the output + directory, and includes the + command \usepackage{haddock} in the + LaTeX source. If this option is given, + then haddock.sty is not generated, + and the command is + instead \usepackage{style}. + + + + + + + + + + + + + + + Reserved for future use (output documentation in DocBook XML + format). + + + + + + + =URL + + + + =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. + is a flag that gets used for + entities that need to link to an exact source location rather than a + name, eg. since they were defined inside a Template Haskell splice. + + + 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.) + + + + + + + + =path + + + Specify a theme to be used for HTML () + documentation. If given multiple times then the pages will use the + first theme given by default, and have alternate style sheets for + the others. The reader can switch between themes with browsers that + support alternate style sheets, or with the "Style" menu that gets + added when the page is loaded. If + no themes are specified, then just the default built-in theme + ("Ocean") is used. + + + The path parameter can be one of: + + + + + A directory: The base name of + the directory becomes the name of the theme. The directory + must contain exactly one + some.css file. + Other files, usually image files, will be copied, along with + the some.css + file, into the generated output directory. + + + A CSS file: The base name of + the file becomes the name of the theme. + + + The name of a built-in theme + ("Ocean" or "Classic"). + + + + + + + + + + + + Includes the built-in themes ("Ocean" and "Classic"). + Can be combined with . Note that order + matters: The first specified theme will be the default. + + + + + + + file + + + + =file + + + Deprecated aliases for + + + + + + + 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!). + + + + + + + mode + + + + =mode + + + + Specify how identifiers are qualified. + + + mode should be one of + + + none (default): don't qualify any identifiers + + + full: always qualify identifiers completely + + + local: only qualify identifiers that are not part + of the module + + + relative: like local, but strip name of the module + from qualifications of identifiers in submodules + + + + + Example: If you generate documentation for module A, then the + identifiers A.x, A.B.y and C.z are qualified as follows. + + + + + none: x, y, z + + + full: A.x, A.B.y, C.z + + + local: x, A.B.y, C.z + + + relative: x, B.y, C.z + + + + + + + + + + + + + + + + + Display help and exit. + + + + + + + + + + + + + + Output version information 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). + + + + + + + + + + + + + + When generating HTML, do not generate an index. + Instead, redirect the Contents and/or Index link on each page to + URL. This option is intended for + use in conjunction with and/or + for + generating a separate contents and/or index covering multiple + libraries. + + + + + + + + + + + + + + Generate an HTML contents and/or index containing entries pulled + from all the specified interfaces (interfaces are specified using + or ). + This is used to generate a single contents and/or index for multiple + sets of Haddock documentation. + + + + + + + + + + + Causes Haddock to behave as if every module has the + ignore-exports attribute (). This might be useful for + generating implementation documentation rather than interface + documentation, for example. + + + + + + + +  module + + + Causes Haddock to behave as if module + module has the hide + attribute. (). + + + + + + + +  module + + + Causes Haddock to behave as if module + module has the show-extensions + attribute. (). + + + + + + + =option + + + Pass option to GHC. Note that there is a double dash there, unlike for GHC. + + + + + + + + + + + + + + Turn off all warnings. + + + + + + + + + + + Prints out space-separated versions of binary Haddock interface files that this version is compatible + with. + + + + + + + + + + + + Do not use a temporary directory for reading and writing compilation output files + (.o, .hi, and stub files). Instead, use the + present directory or another directory that you have explicitly told GHC to use + via the --optghc flag. + + + This flag can be used to avoid recompilation if compilation files already exist. + Compilation files are produced when Haddock has to process modules that make use of + Template Haskell, in which case Haddock compiles the modules using the GHC API. + + + + + +
+ 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 + + + A class declaration, + + + A data family or + type family declaration, or + + + A data instance or + type instance 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. + + In case that more than one constructor exports a field + with the same name, the documentation attached to the first + occurence of the field will be used, even if a comment is not + present. + + + +data T a = A { someField :: a -- ^ Doc for someField of A + } + | B { someField :: a -- ^ Doc for someField of B + } + + + In the above example, all occurences of + someField in the documentation are going to + be documented with Doc for someField of A. + Note that Haddock versions 2.14.0 and before would join up + documentation of each field and render the result. The reason + for this seemingly weird behaviour is the fact that + someField is actually the same (partial) + function. + +
+ +
+ 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 itself may be documented with multiple fields + that can then be displayed by the backend. In particular, the + HTML backend displays all the fields it currently knows + about. We first show the most complete module documentation + example and then talk about the fields. + + +{-| +Module : W +Description : Short description +Copyright : (c) Some Guy, 2013 + Someone Else, 2014 +License : GPL-3 +Maintainer : sample@email.com +Stability : experimental +Portability : POSIX + +Here is a longer description of this module, containing some +commentary with @some markup@. +-} +module W where +... + + + The Module field should be clear. It + currently doesn't affect the output of any of the backends but + you might want to include it for human information or for any + other tools that might be parsing these comments without the + help of GHC. + + The Description field accepts some short text + which outlines the general purpose of the module. If you're + generating HTML, it will show up next to the module link in + the module index. + + The Copyright, License, + Maintainer and Stability fields + should be obvious. An alternative spelling for the + License field is accepted as + Licence but the output will always prefer + License. + + The Portability field has seen varied use + by different library authors. Some people put down things like + operating system constraints there while others put down which GHC + extensions are used in the module. Note that you might want to + consider using the show-extensions module flag for the + latter. + + Finally, a module may contain a documentation comment + before the module header, in which case this comment is + interpreted by Haddock as an overall description of the module + itself, and placed in a section entitled + Description in the documentation for the module. + All usual Haddock markup is valid in this comment. + + All fields are optional but they must be in order if they + do appear. Multi-line fields are accepted but the consecutive + lines have to start indented more than their label. If your + label is indented one space as is often the case with + -- syntax, the consecutive lines have to start at + two spaces at the very least. Please note that we do not enforce + the format for any of the fields and the established formats are + just a convention. + +
+ +
+ 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). + + +module Foo where + +-- * This heading will now appear before foo. + +-- | Documentation for 'foo'. +foo :: Integer +foo = 5 + + +
+
+ +
+ 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 attribute 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. + + + + + + show-extensions + show-extensions + + + Indicates that we should render the extensions used in this module in the + resulting documentation. This will only render if the output format supports it. + If Language is set, it will be shown as well and all the extensions implied by it won't. + All enabled extensions will be rendered, including those implied by their more powerful versions. + + + + + +
+ +
+ 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 \. + + Furthermore, the character sequence >>> + has a special meaning at the beginning of a line. To + escape it, just prefix the characters in the sequence with a + backslash. +
+ +
+ 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. +
+ +
+ Examples + + Haddock has markup support for examples of interaction with a + read-eval-print loop (REPL). An + example is introduced with + >>> followed by an expression followed + by zero or more result lines: + + +-- | Two examples are given below: +-- +-- >>> fib 10 +-- 55 +-- +-- >>> putStrLn "foo\nbar" +-- foo +-- bar + + Result lines that only contain the string + <BLANKLINE> are rendered as blank lines in the + generated documentation. +
+ +
+ Properties + + Haddock provides markup for properties: + +-- | Addition is commutative: +-- +-- prop> a + b = b + a + + This allows third-party applications to extract and verify them. + +
+ +
+ 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? + + + Nothing special is needed to hyperlink identifiers which + contain apostrophes themselves: to hyperlink + foo' one would simply type + 'foo''. + + 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, Bold and Monospaced text + + Emphasis may be added by surrounding text with + /.../. Other markup is valid inside emphasis. To have a forward + slash inside of emphasis, just escape it: /fo\/o/ + + Bold (strong) text is indicated by surrounding it with __...__. + Other markup is valid inside bold. For example, __/foo/__ will make the emphasised + text foo bold. You don't have to escape a single underscore if you need it bold: + __This_text_with_underscores_is_bold__. + + + Monospaced (or typewriter) text is indicated by + surrounding it with @...@. Other markup is + valid inside a monospaced span: for example + @'f' a b@ will hyperlink the + identifier f inside the code fragment. +
+ +
+ 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. + + + A basic check is done on the syntax of the header name to ensure that it is valid + before turning it into a link but unlike with identifiers, whether the module is in scope isn't checked + and will always be turned into a link. + + +
+ +
+ 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 + + + Lists of the same type don't have to be separated by a newline: + +-- | This is an enumerated list: +-- +-- (1) first item +-- 2. second item +-- +-- This is a bulleted list: +-- +-- * first item +-- * second item + + + You can have more than one line of content in a list element: + + +-- | +-- * first item +-- and more content for the first item +-- * second item +-- and more content for the second item + + + You can even nest whole paragraphs inside of list elements. The rules + are 4 spaces for each indentation level. You're required to use a newline before + such nested paragraph: + + +{-| +* Beginning of list +This belongs to the list above! + + > nested + > bird + > tracks + + * Next list + More of the indented list. + + * Deeper + + @ + even code blocks work + @ + + * Deeper + + 1. Even deeper! + 2. No newline separation even in indented lists. +-} + + +
+ +
+ 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. You can escape ] with a backslash as usual. + + Same rules about nesting and no newline separation as for bulleted and numbered lists apply. + + +
+ +
+ 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. + + The URL can be followed by an optional label: + +<http://example.com label> + + The label is then used as a descriptive text for the hyperlink, if the + output format supports it. + + If Haddock sees something that looks like a URL (such as something starting with + http:// or ssh://) where the URL markup is valid, + it will automatically make it a hyperlink. +
+ +
+ Images + + An image can be included in a documentation comment by + surrounding it in double angle brackets: + <<...>>. If the output format supports + it, the image will be rendered inside the documentation. + + Title text can be included using an optional label: + +<<pathtoimage.png title>> + + +
+ +
+ 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. Please note that in Haddock + versions 2.13.x and earlier, the syntax was + "module\#label". + It is considered deprecated and will be removed in the future. +
+ +
+ Headings Headings inside of comment documentation are possible be preceding them with a number of =s. From 1 to 6 are accepted. Extra =s will be treated as belonging to the text of the heading. Note that it's up to the output format to decide diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Documentation/Haddock.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Documentation.Haddock +-- Copyright : (c) David Waern 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskellorg +-- Stability : experimental +-- Portability : portable +-- +-- The Haddock API: A rudimentory, highly experimental API exposing some of +-- the internals of Haddock. Don't expect it to be stable. +----------------------------------------------------------------------------- +module Documentation.Haddock ( + + -- * Interface + Interface(..), + InstalledInterface(..), + createInterfaces, + processModules, + + -- * Export items & declarations + ExportItem(..), + DocForDecl, + FnArgsDoc, + + -- * Cross-referencing + LinkEnv, + DocName(..), + + -- * Instances + DocInstance, + InstHead, + + -- * Documentation comments + Doc, + DocH(..), + Example(..), + Hyperlink(..), + DocMarkup(..), + Documentation(..), + ArgMap, + AliasMap, + WarningMap, + DocMap, + HaddockModInfo(..), + markup, + + -- * Interface files + InterfaceFile(..), + readInterfaceFile, + nameCacheFromGhc, + freshNameCache, + NameCacheAccessor, + + -- * Flags and options + Flag(..), + DocOption(..), + + -- * Error handling + HaddockException(..), + + -- * Program entry point + haddock, + haddockWithGhc, + getGhcDirs, + withGhc +) where + + +import Haddock.InterfaceFile +import Haddock.Interface +import Haddock.Types +import Haddock.Options +import Haddock.Utils +import Haddock + + +-- | Create 'Interface' structures from a given list of Haddock command-line +-- flags and file or module names (as accepted by 'haddock' executable). Flags +-- that control documentation generation or show help or version information +-- are ignored. +createInterfaces + :: [Flag] -- ^ A list of command-line flags + -> [String] -- ^ File or module names + -> IO [Interface] -- ^ Resulting list of interfaces +createInterfaces flags modules = do + (_, ifaces, _) <- withGhc flags (readPackagesAndProcessModules flags modules) + return ifaces diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock.hs @@ -0,0 +1,488 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE LambdaCase #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2010, +-- Mateusz Kowalczyk 2014 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Haddock - A Haskell Documentation Tool +-- +-- Program entry point and top-level code. +----------------------------------------------------------------------------- +module Haddock ( + haddock, + haddockWithGhc, + getGhcDirs, + readPackagesAndProcessModules, + withGhc +) where + +import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Themes (getThemes) +import Haddock.Backends.LaTeX +import Haddock.Backends.Hoogle +import Haddock.Interface +import Haddock.Parser +import Haddock.Types +import Haddock.Version +import Haddock.InterfaceFile +import Haddock.Options +import Haddock.Utils +import Haddock.GhcUtils hiding (pretty) + +import Control.Monad hiding (forM_) +import Data.Foldable (forM_) +import Data.List (isPrefixOf) +import Control.Exception +import Data.Maybe +import Data.IORef +import qualified Data.Map as Map +import System.IO +import System.Exit +import System.Directory + +#if defined(mingw32_HOST_OS) +import Foreign +import Foreign.C +import Data.Int +#endif + +#ifdef IN_GHC_TREE +import System.FilePath +#else +import qualified GHC.Paths as GhcPaths +import Paths_haddock_api (getDataDir) +#endif + +import GHC hiding (verbosity) +import Config +import DynFlags hiding (verbosity) +import StaticFlags (discardStaticFlags) +import Panic (handleGhcException) +import Module + +-------------------------------------------------------------------------------- +-- * Exception handling +-------------------------------------------------------------------------------- + + +handleTopExceptions :: IO a -> IO a +handleTopExceptions = + handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions + + +-- | Either returns normally or throws an ExitCode exception; +-- all other exceptions are turned into exit exceptions. +handleNormalExceptions :: IO a -> IO a +handleNormalExceptions inner = + (inner `onException` hFlush stdout) + `catches` + [ Handler (\(code :: ExitCode) -> exitWith code) + + , Handler (\(ex :: AsyncException) -> + case ex of + StackOverflow -> do + putStrLn "stack overflow: use -g +RTS -K to increase it" + exitFailure + _ -> do + putStrLn ("haddock: " ++ show ex) + exitFailure) + + , Handler (\(ex :: SomeException) -> do + putStrLn ("haddock: internal error: " ++ show ex) + exitFailure) + ] + + +handleHaddockExceptions :: IO a -> IO a +handleHaddockExceptions inner = + catches inner [Handler handler] + where + handler (e::HaddockException) = do + putStrLn $ "haddock: " ++ show e + exitFailure + + +handleGhcExceptions :: IO a -> IO a +handleGhcExceptions = + -- error messages propagated as exceptions + handleGhcException $ \e -> do + hFlush stdout + case e of + PhaseFailed _ code -> exitWith code + _ -> do + print (e :: GhcException) + exitFailure + + +------------------------------------------------------------------------------- +-- * Top level +------------------------------------------------------------------------------- + + +-- | Run Haddock with given list of arguments. +-- +-- Haddock's own main function is defined in terms of this: +-- +-- > main = getArgs >>= haddock +haddock :: [String] -> IO () +haddock args = haddockWithGhc withGhc args + +haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO () +haddockWithGhc ghc args = handleTopExceptions $ do + + -- Parse command-line flags and handle some of them initially. + -- TODO: unify all of this (and some of what's in the 'render' function), + -- into one function that returns a record with a field for each option, + -- or which exits with an error or help message. + (flags, files) <- parseHaddockOpts args + shortcutFlags flags + qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} + + -- inject dynamic-too into flags before we proceed + flags' <- ghc flags $ do + df <- getDynFlags + case lookup "GHC Dynamic" (compilerInfo df) of + Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags + _ -> return flags + + unless (Flag_NoWarnings `elem` flags) $ do + forM_ (warnings args) $ \warning -> do + hPutStrLn stderr warning + + ghc flags' $ do + + dflags <- getDynFlags + + if not (null files) then do + (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + + -- Dump an "interface file" (.haddock file), if requested. + forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do + writeInterfaceFile path InterfaceFile { + ifInstalledIfaces = map toInstalledIface ifaces + , ifLinkEnv = homeLinks + } + + -- Render the interfaces. + liftIO $ renderStep dflags flags qual packages ifaces + + else do + when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ + throwE "No input file(s)." + + -- Get packages supplied with --read-interface. + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + + -- Render even though there are no input files (usually contents/index). + liftIO $ renderStep dflags flags qual packages [] + +-- | Create warnings about potential misuse of -optghc +warnings :: [String] -> [String] +warnings = map format . filter (isPrefixOf "-optghc") + where + format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] + + +withGhc :: [Flag] -> Ghc a -> IO a +withGhc flags action = do + libDir <- fmap snd (getGhcDirs flags) + + -- Catches all GHC source errors, then prints and re-throws them. + let handleSrcErrors action' = flip handleSourceError action' $ \err -> do + printException err + liftIO exitFailure + + withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action) + + +readPackagesAndProcessModules :: [Flag] -> [String] + -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) +readPackagesAndProcessModules flags files = do + -- Get packages supplied with --read-interface. + packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + + -- Create the interfaces -- this is the core part of Haddock. + let ifaceFiles = map snd packages + (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles + + return (packages, ifaces, homeLinks) + + +renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep dflags flags qual pkgs interfaces = do + updateHTMLXRefs pkgs + let + ifaceFiles = map snd pkgs + installedIfaces = concatMap ifInstalledIfaces ifaceFiles + srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] + render dflags flags qual interfaces installedIfaces srcMap + + +-- | Render the interfaces with whatever backend is specified in the flags. +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render dflags flags qual ifaces installedIfaces srcMap = do + + let + title = fromMaybe "" (optTitle flags) + unicode = Flag_UseUnicode `elem` flags + pretty = Flag_PrettyHtml `elem` flags + opt_wiki_urls = wikiUrls flags + opt_contents_url = optContentsUrl flags + opt_index_url = optIndexUrl flags + odir = outputDir flags + opt_latex_style = optLaTeXStyle flags + + visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] + + -- /All/ visible interfaces including external package modules. + allIfaces = map toInstalledIface ifaces ++ installedIfaces + allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] + + pkgMod = ifaceMod (head ifaces) + pkgId = modulePackageId pkgMod + pkgStr = Just (packageIdString pkgId) + (pkgName,pkgVer) = modulePackageInfo pkgMod + + (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags + srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity + -- TODO: Get these from the interface files as with srcMap + srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity + sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') + + libDir <- getHaddockLibDir flags + prologue <- getPrologue dflags flags + themes <- getThemes libDir flags >>= either bye return + + when (Flag_GenIndex `elem` flags) $ do + ppHtmlIndex odir title pkgStr + themes opt_contents_url sourceUrls' opt_wiki_urls + allVisibleIfaces pretty + copyHtmlBits odir libDir themes + + when (Flag_GenContents `elem` flags) $ do + ppHtmlContents odir title pkgStr + themes opt_index_url sourceUrls' opt_wiki_urls + allVisibleIfaces True prologue pretty + (makeContentsQual qual) + copyHtmlBits odir libDir themes + + when (Flag_Html `elem` flags) $ do + ppHtml title pkgStr visibleIfaces odir + prologue + themes sourceUrls' opt_wiki_urls + opt_contents_url opt_index_url unicode qual + pretty + copyHtmlBits odir libDir themes + + when (Flag_Hoogle `elem` flags) $ do + let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName + ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir + + when (Flag_LaTeX `elem` flags) $ do + ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style + libDir + + +------------------------------------------------------------------------------- +-- * Reading and dumping interface files +------------------------------------------------------------------------------- + + +readInterfaceFiles :: MonadIO m + => NameCacheAccessor m + -> [(DocPaths, FilePath)] + -> m [(DocPaths, InterfaceFile)] +readInterfaceFiles name_cache_accessor pairs = do + catMaybes `liftM` mapM tryReadIface pairs + where + -- try to read an interface, warn if we can't + tryReadIface (paths, file) = + readInterfaceFile name_cache_accessor file >>= \case + Left err -> liftIO $ do + putStrLn ("Warning: Cannot read " ++ file ++ ":") + putStrLn (" " ++ err) + putStrLn "Skipping this interface." + return Nothing + Right f -> return $ Just (paths, f) + + +------------------------------------------------------------------------------- +-- * Creating a GHC session +------------------------------------------------------------------------------- + + +-- | Start a GHC session with the -haddock flag set. Also turn off +-- compilation and linking. Then run the given 'Ghc' action. +withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a +withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do + dynflags <- getSessionDynFlags + dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) { + hscTarget = HscNothing, + ghcMode = CompManager, + ghcLink = NoLink + } + let dynflags'' = gopt_unset dynflags' Opt_SplitObjs + defaultCleanupHandler dynflags'' $ do + -- ignore the following return-value, which is a list of packages + -- that may need to be re-linked: Haddock doesn't do any + -- dynamic or static linking at all! + _ <- setSessionDynFlags dynflags'' + ghcActs dynflags'' + where + parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags + parseGhcFlags dynflags = do + -- TODO: handle warnings? + + -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot + -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if + -- we pass any, Haddock will fail. Since StaticFlags are global to the + -- GHC invocation, there's also no way to reparse/save them to set them + -- again properly. + -- + -- This is a bit of a hack until we get rid of the rest of the remaining + -- StaticFlags. See GHC issue #8276. + let flags' = discardStaticFlags flags + (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') + if not (null rest) + then throwE ("Couldn't parse GHC options: " ++ unwords flags') + else return dynflags' + +------------------------------------------------------------------------------- +-- * Misc +------------------------------------------------------------------------------- + + +getHaddockLibDir :: [Flag] -> IO String +getHaddockLibDir flags = + case [str | Flag_Lib str <- flags] of + [] -> do +#ifdef IN_GHC_TREE + getInTreeDir +#else + d <- getDataDir -- provided by Cabal + doesDirectoryExist d >>= \exists -> case exists of + True -> return d + False -> do + -- If directory does not exist then we are probably invoking from + -- ./dist/build/haddock/haddock so we use ./resources as a fallback. + doesDirectoryExist "resources" >>= \exists_ -> case exists_ of + True -> return "resources" + False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n") +#endif + fs -> return (last fs) + + +getGhcDirs :: [Flag] -> IO (String, String) +getGhcDirs flags = do + case [ dir | Flag_GhcLibDir dir <- flags ] of + [] -> do +#ifdef IN_GHC_TREE + libDir <- getInTreeDir + return (ghcPath, libDir) +#else + return (ghcPath, GhcPaths.libdir) +#endif + xs -> return (ghcPath, last xs) + where +#ifdef IN_GHC_TREE + ghcPath = "not available" +#else + ghcPath = GhcPaths.ghc +#endif + + +shortcutFlags :: [Flag] -> IO () +shortcutFlags flags = do + usage <- getUsage + + when (Flag_Help `elem` flags) (bye usage) + when (Flag_Version `elem` flags) byeVersion + when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n")) + when (Flag_CompatibleInterfaceVersions `elem` flags) + (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\n")) + when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) + + when (Flag_PrintGhcPath `elem` flags) $ do + dir <- fmap fst (getGhcDirs flags) + bye $ dir ++ "\n" + + when (Flag_PrintGhcLibDir `elem` flags) $ do + dir <- fmap snd (getGhcDirs flags) + bye $ dir ++ "\n" + + when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ + throwE "Unicode can only be enabled for HTML output." + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Html `elem` flags) $ + throwE "-h cannot be used with --gen-index or --gen-contents" + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_Hoogle `elem` flags) $ + throwE "--hoogle cannot be used with --gen-index or --gen-contents" + + when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) + && Flag_LaTeX `elem` flags) $ + throwE "--latex cannot be used with --gen-index or --gen-contents" + where + byeVersion = bye $ + "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" + ++ "Ported to use the GHC API by David Waern 2006-2008\n" + + +updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () +updateHTMLXRefs packages = do + writeIORef html_xrefs_ref (Map.fromList mapping) + writeIORef html_xrefs_ref' (Map.fromList mapping') + where + mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages + , iface <- ifInstalledIfaces ifaces ] + mapping' = [ (moduleName m, html) | (m, html) <- mapping ] + + +getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName)) +getPrologue dflags flags = + case [filename | Flag_Prologue filename <- flags ] of + [] -> return Nothing + [filename] -> withFile filename ReadMode $ \h -> do + hSetEncoding h utf8 + str <- hGetContents h + return . Just $ parseParas dflags str + _ -> throwE "multiple -p/--prologue options" + + +#ifdef IN_GHC_TREE + +getInTreeDir :: IO String +getInTreeDir = getExecDir >>= \case + Nothing -> error "No GhcDir found" + Just d -> return (d ".." "lib") + + +getExecDir :: IO (Maybe String) +#if defined(mingw32_HOST_OS) +getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf + | otherwise -> try_size (size * 2) + +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 +#else +getExecDir = return Nothing +#endif + +#endif diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.HaddockDB +-- Copyright : (c) Simon Marlow 2003 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.HaddockDB (ppDocBook) where + +{- +import HaddockTypes +import HaddockUtil +import HsSyn2 + +import Text.PrettyPrint +-} + +----------------------------------------------------------------------------- +-- Printing the results in DocBook format + +ppDocBook :: a +ppDocBook = error "not working" +{- +ppDocBook :: FilePath -> [(Module, Interface)] -> String +ppDocBook odir mods = render (ppIfaces mods) + +ppIfaces mods + = text "" + $$ 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/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -0,0 +1,331 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Hoogle +-- Copyright : (c) Neil Mitchell 2006-2008 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Write out Hoogle compatible documentation +-- http://www.haskell.org/hoogle/ +----------------------------------------------------------------------------- +module Haddock.Backends.Hoogle ( + ppHoogle + ) where + + +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils hiding (out) +import GHC +import Outputable + +import Data.Char +import Data.List +import Data.Maybe +import System.FilePath +import System.IO + +prefix :: [String] +prefix = ["-- Hoogle documentation, generated by Haddock" + ,"-- See Hoogle, http://www.haskell.org/hoogle/" + ,""] + + +ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags package version synopsis prologue ifaces odir = do + let filename = package ++ ".txt" + contents = prefix ++ + docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + ["@package " ++ package] ++ + ["@version " ++ version | version /= ""] ++ + concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + h <- openFile (odir filename) WriteMode + hSetEncoding h utf8 + hPutStr h (unlines contents) + hClose h + +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface = + "" : ppDocumentation dflags (ifaceDoc iface) ++ + ["module " ++ moduleString (ifaceMod iface)] ++ + concatMap (ppExport dflags) (ifaceExportItems iface) ++ + concatMap (ppInstance dflags) (ifaceInstances iface) + + +--------------------------------------------------------------------- +-- Utility functions + +dropHsDocTy :: HsType a -> HsType a +dropHsDocTy = f + where + g (L src x) = L src (f x) + f (HsForAllTy a b c d) = HsForAllTy a b c (g d) + f (HsBangTy a b) = HsBangTy a (g b) + f (HsAppTy a b) = HsAppTy (g a) (g b) + f (HsFunTy a b) = HsFunTy (g a) (g b) + f (HsListTy a) = HsListTy (g a) + f (HsPArrTy a) = HsPArrTy (g a) + f (HsTupleTy a b) = HsTupleTy a (map g b) + f (HsOpTy a b c) = HsOpTy (g a) b (g c) + f (HsParTy a) = HsParTy (g a) + f (HsKindSig a b) = HsKindSig (g a) b + f (HsDocTy a _) = f $ unL a + f x = x + +outHsType :: OutputableBndr a => DynFlags -> HsType a -> String +outHsType dflags = out dflags . dropHsDocTy + + +makeExplicit :: HsType a -> HsType a +makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c +makeExplicit x = x + +makeExplicitL :: LHsType a -> LHsType a +makeExplicitL (L src x) = L src (makeExplicit x) + + +dropComment :: String -> String +dropComment (' ':'-':'-':' ':_) = [] +dropComment (x:xs) = x : dropComment xs +dropComment [] = [] + + +out :: Outputable a => DynFlags -> a -> String +out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr + where + f xs | " " `isPrefixOf` xs = f $ drop 19 xs + f (x:xs) = x : f xs + f [] = [] + + +operator :: String -> String +operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" +operator x = x + + +--------------------------------------------------------------------- +-- How to print each export + +ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport dflags ExportDecl { expItemDecl = L _ decl + , expItemMbDoc = (dc, _) + , expItemSubDocs = subdocs + } = ppDocumentation dflags dc ++ f decl + where + f (TyClD d@DataDecl{}) = ppData dflags d subdocs + f (TyClD d@SynDecl{}) = ppSynonym dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (SigD sig) = ppSig dflags sig + f _ = [] +ppExport _ _ = [] + + +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags (TypeSig names sig) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] + where + prettyNames = intercalate ", " $ map (out dflags) names + typ = case unL sig of + HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c + x -> x +ppSig _ _ = [] + + +-- note: does not yet output documentation for class methods +ppClass :: DynFlags -> TyClDecl Name -> [String] +ppClass dflags x = out dflags x{tcdSigs=[]} : + concatMap (ppSig dflags . addContext . unL) (tcdSigs x) + where + addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) + addContext (MinimalSig sig) = MinimalSig sig + addContext _ = error "expected TypeSig" + + f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d + f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) + + context = nlHsTyConApp (tcdName x) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + + +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = [dropComment $ out dflags x] + + +ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym dflags x = [out dflags x] + +ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : + concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) + where + + -- GHC gives out "data Bar =", we want to delete the equals + -- also writes data : a b, when we want data (:) a b + showData d = unwords $ map f $ if last xs == "=" then init xs else xs + where + xs = words $ out dflags d + nam = out dflags $ tyClDeclLName d + f w = if w == nam then operator nam else w +ppData _ _ _ = panic "ppData" + +-- | for constructors, and named-fields... +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon dflags subdocs (L _ name) = case lookup name subdocs of + Just (d, _) -> ppDocumentation dflags d + _ -> [] + +ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) + ++ f (con_details con) + where + f (PrefixCon args) = [typeSig name $ args ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] + f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat + [lookupCon dflags subdocs (cd_fld_name r) ++ + [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] + | r <- recs] + + funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + apps = foldl1 (\x y -> reL $ HsAppTy x y) + + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + name = out dflags $ unL $ con_name con + + resType = case con_res con of + ResTyH98 -> apps $ map (reL . HsTyVar) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] + ResTyGADT x -> x + + +--------------------------------------------------------------------- +-- DOCUMENTATION + +ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] +ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w + + +doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] +doc dflags = docWith dflags "" + + +docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] +docWith _ [] Nothing = [] +docWith dflags header d + = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ + [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ + maybe [] (showTags . markup (markupTag dflags)) d + + +data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String + deriving Show + +type Tags = [Tag] + +box :: (a -> b) -> a -> [b] +box f x = [f x] + +str :: String -> [Tag] +str a = [Str a] + +-- want things like paragraph, pre etc to be handled by blank lines in the source document +-- and things like \n and \t converted away +-- much like blogger in HTML mode +-- everything else wants to be included as tags, neatly nested for some (ul,li,ol) +-- or inlne for others (a,i,tt) +-- entities (&,>,<) should always be appropriately escaped + +markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] +markupTag dflags = Markup { + markupParagraph = box TagP, + markupEmpty = str "", + markupString = str, + markupAppend = (++), + markupIdentifier = box (TagInline "a") . str . out dflags, + markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), + markupEmphasis = box (TagInline "i"), + markupBold = box (TagInline "b"), + markupMonospaced = box (TagInline "tt"), + markupPic = const $ str " ", + markupUnorderedList = box (TagL 'u'), + markupOrderedList = box (TagL 'o'), + markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), + markupCodeBlock = box TagPre, + markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), + markupAName = const $ str "", + markupProperty = box TagPre . str, + markupExample = box TagPre . str . unlines . map exampleToString, + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + } + + +showTags :: [Tag] -> [String] +showTags = intercalate [""] . map showBlock + + +showBlock :: Tag -> [String] +showBlock (TagP xs) = showInline xs +showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"] + where mid = concatMap (showInline . box (TagInline "li")) xs +showBlock (TagPre xs) = ["
"] ++ 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/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -0,0 +1,1221 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.LaTeX +-- Copyright : (c) Simon Marlow 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.LaTeX ( + ppLaTeX +) where + + +import Haddock.Types +import Haddock.Utils +import Haddock.GhcUtils +import Pretty hiding (Doc, quote) +import qualified Pretty + +import GHC +import OccName +import Name ( nameOccName ) +import RdrName ( rdrNameOcc ) +import FastString ( unpackFS, unpackLitString, zString ) + +import qualified Data.Map as Map +import System.Directory +import System.FilePath +import Data.Char +import Control.Monad +import Data.Maybe +import Data.List + +import Haddock.Doc (combineDocumentation) + +-- import Debug.Trace + +{- SAMPLE OUTPUT + +\haddockmoduleheading{\texttt{Data.List}} +\hrulefill +{\haddockverb\begin{verbatim} +module Data.List ( + (++), head, last, tail, init, null, length, map, reverse, + ) where\end{verbatim}} +\hrulefill + +\section{Basic functions} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +head\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the first element of a list, which must be non-empty. +\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +last\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the last element of a list, which must be finite and non-empty. +\par + +\end{haddockdesc} +-} + + +{- TODO + * don't forget fixity!! +-} + +ppLaTeX :: String -- Title + -> Maybe String -- Package name + -> [Interface] + -> FilePath -- destination directory + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- style file + -> FilePath + -> IO () + +ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir + = do + createDirectoryIfMissing True odir + when (isNothing maybe_style) $ + copyFile (libdir "latex" haddockSty) (odir haddockSty) + ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces + mapM_ (ppLaTeXModule title odir) visible_ifaces + + +haddockSty :: FilePath +haddockSty = "haddock.sty" + + +type LaTeX = Pretty.Doc + + +ppLaTeXTop + :: String + -> Maybe String + -> FilePath + -> Maybe (Doc GHC.RdrName) + -> Maybe String + -> [Interface] + -> IO () + +ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do + + let tex = vcat [ + text "\\documentclass{book}", + text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), + text "\\begin{document}", + text "\\begin{titlepage}", + text "\\begin{haddocktitle}", + text doctitle, + text "\\end{haddocktitle}", + case prologue of + Nothing -> empty + Just d -> vcat [text "\\begin{haddockprologue}", + rdrDocToLaTeX d, + text "\\end{haddockprologue}"], + text "\\end{titlepage}", + text "\\tableofcontents", + vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], + text "\\end{document}" + ] + + mods = sort (map (moduleBasename.ifaceMod) ifaces) + + filename = odir (fromMaybe "haddock" packageStr <.> "tex") + + writeFile filename (show tex) + + +ppLaTeXModule :: String -> FilePath -> Interface -> IO () +ppLaTeXModule _title odir iface = do + createDirectoryIfMissing True odir + let + mdl = ifaceMod iface + mdl_str = moduleString mdl + + exports = ifaceRnExportItems iface + + tex = vcat [ + text "\\haddockmoduleheading" <> braces (text mdl_str), + text "\\label{module:" <> text mdl_str <> char '}', + text "\\haddockbeginheader", + verb $ vcat [ + text "module" <+> text mdl_str <+> lparen, + text " " <> fsep (punctuate (text ", ") $ + map exportListItem $ + filter forSummary exports), + text " ) where" + ], + text "\\haddockendheader" $$ text "", + description, + body + ] + + description + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface + + body = processExports exports + -- + writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) + + +string_txt :: TextDetails -> String -> String +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = unpackFS s1 ++ s2 +string_txt (ZStr s1) s2 = zString s1 ++ s2 +string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + + +exportListItem :: ExportItem DocName -> LaTeX +exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } + = sep (punctuate comma . map ppDocBinder $ declNames decl) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) +exportListItem (ExportNoDecl y []) + = ppDocBinder y +exportListItem (ExportNoDecl y subs) + = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) +exportListItem (ExportModule mdl) + = text "module" <+> text (moduleString mdl) +exportListItem _ + = error "exportListItem" + + +-- Deal with a group of undocumented exports together, to avoid lots +-- of blank vertical space between them. +processExports :: [ExportItem DocName] -> LaTeX +processExports [] = empty +processExports (decl : es) + | Just sig <- isSimpleSig decl + = multiDecl [ ppTypeSig (map getName names) typ False + | (names,typ) <- sig:sigs ] $$ + processExports es' + where (sigs, es') = spanWith isSimpleSig es +processExports (ExportModule mdl : es) + = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ + processExports es' + where (mdls, es') = spanWith isExportModule es +processExports (e : es) = + processExport e $$ processExports es + + +isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) + , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } + | Map.null argDocs = Just (map unLoc lnames, t) +isSimpleSig _ = Nothing + + +isExportModule :: ExportItem DocName -> Maybe Module +isExportModule (ExportModule m) = Just m +isExportModule _ = Nothing + + +processExport :: ExportItem DocName -> LaTeX +processExport (ExportGroup lev _id0 doc) + = ppDocGroup lev (docToLaTeX doc) +processExport (ExportDecl decl doc subdocs insts fixities _splice) + = ppDecl decl doc insts subdocs fixities +processExport (ExportNoDecl y []) + = ppDocName y +processExport (ExportNoDecl y subs) + = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) +processExport (ExportModule mdl) + = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing +processExport (ExportDoc doc) + = docToLaTeX doc + + +ppDocGroup :: Int -> LaTeX -> LaTeX +ppDocGroup lev doc = sec lev <> braces doc + where sec 1 = text "\\section" + sec 2 = text "\\subsection" + sec 3 = text "\\subsubsection" + sec _ = text "\\paragraph" + + +declNames :: LHsDecl DocName -> [DocName] +declNames (L _ decl) = case decl of + TyClD d -> [tcdName d] + SigD (TypeSig lnames _) -> map unLoc lnames + SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + ForD (ForeignImport (L _ n) _ _ _) -> [n] + ForD (ForeignExport (L _ n) _ _ _) -> [n] + _ -> error "declaration not supported by declNames" + + +forSummary :: (ExportItem DocName) -> Bool +forSummary (ExportGroup _ _ _) = False +forSummary (ExportDoc _) = False +forSummary _ = True + + +moduleLaTeXFile :: Module -> FilePath +moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" + + +moduleBasename :: Module -> FilePath +moduleBasename mdl = map (\c -> if c == '.' then '-' else c) + (moduleNameString (moduleName mdl)) + + +------------------------------------------------------------------------------- +-- * Decls +------------------------------------------------------------------------------- + + +ppDecl :: LHsDecl DocName + -> DocForDecl DocName + -> [DocInstance DocName] + -> [(DocName, DocForDecl DocName)] + -> [(DocName, Fixity)] + -> LaTeX + +ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of + TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode + TyClD d@(DataDecl {}) + -> ppDataDecl instances subdocs loc (Just doc) d unicode + TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode +-- Family instances happen via FamInst now +-- TyClD d@(TySynonym {}) +-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode +-- Family instances happen via FamInst now + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode + ForD d -> ppFor loc (doc, fnArgsDoc) d unicode + InstD _ -> empty + _ -> error "declaration not supported by ppDecl" + where + unicode = False + + +ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> + TyClDecl DocName -> Bool -> LaTeX +ppTyFam _ _ _ _ _ = + error "type family declarations are currently not supported by --latex" + + +ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX +ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = + ppFunSig loc doc [name] typ unicode +ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +-- error "foreign declarations are currently not supported by --latex" + + +------------------------------------------------------------------------------- +-- * Type Synonyms +------------------------------------------------------------------------------- + + +-- we skip type patterns for now +ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX + +ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) unicode + = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode + where + hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + full = hdr <+> char '=' <+> ppLType unicode ltype + +ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" + + +------------------------------------------------------------------------------- +-- * Function signatures +------------------------------------------------------------------------------- + + +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName + -> Bool -> LaTeX +ppFunSig loc doc docnames typ unicode = + ppTypeOrFunSig loc docnames typ doc + ( ppTypeSig names typ False + , hsep . punctuate comma $ map ppSymName names + , dcolon unicode) + unicode + where + names = map getName docnames + +ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName + -> HsPatSynDetails (LHsType DocName) -> LHsType DocName + -> LHsContext DocName -> LHsContext DocName + -> Bool -> LaTeX +ppLPatSig loc doc docname args typ prov req unicode = + ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode + +ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName + -> HsPatSynDetails (HsType DocName) -> HsType DocName + -> HsContext DocName -> HsContext DocName + -> Bool -> LaTeX +ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) + where + pref1 = hsep [ keyword "pattern" + , pp_ctx prov + , pp_head + , dcolon unicode + , pp_ctx req + , ppType unicode typ + ] + + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] + + pp_type = ppParendType unicode + pp_ctx ctx = ppContext ctx unicode + +ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) + -> Bool -> LaTeX +ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) + unicode + | Map.null argDocs = + declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = + declWithDoc pref2 $ Just $ + text "\\haddockbeginargs" $$ + do_args 0 sep0 typ $$ + text "\\end{tabulary}\\par" $$ + fromMaybe empty (documentationToLaTeX doc) + where + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc (Map.lookup n argDocs) + + do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + = decltt leader <-> + decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader ltype + do_args n leader (HsFunTy lt r) + = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ + do_largs (n+1) (arrow unicode) r + do_args n leader t + = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl + + +ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX +ppTypeSig nms ty unicode = + hsep (punctuate comma $ map ppSymName nms) + <+> dcolon unicode + <+> ppType unicode ty + + +ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] +ppTyVars tvs = map ppSymName (tyvarNames tvs) + + +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames + + +declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX +declWithDoc decl doc = + text "\\begin{haddockdesc}" $$ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (show decl)) $$ + text "\\end{tabular}]" <> + (if isNothing doc then empty else text "\\haddockbegindoc") $$ + maybe empty id doc $$ + text "\\end{haddockdesc}" + + +-- in a group of decls, we don't put them all in the same tabular, +-- because that would prevent the group being broken over a page +-- boundary (breaks Foreign.C.Error for example). +multiDecl :: [LaTeX] -> LaTeX +multiDecl decls = + text "\\begin{haddockdesc}" $$ + vcat [ + text "\\item[" $$ + text (latexMonoFilter (show decl)) $$ + text "]" + | decl <- decls ] $$ + text "\\end{haddockdesc}" + + +------------------------------------------------------------------------------- +-- * Rendering Doc +------------------------------------------------------------------------------- + + +maybeDoc :: Maybe (Doc DocName) -> LaTeX +maybeDoc = maybe empty docToLaTeX + + +-- for table cells, we strip paragraphs out to avoid extra vertical space +-- and don't add a quote environment. +rDoc :: Maybe (Doc DocName) -> LaTeX +rDoc = maybeDoc . fmap latexStripTrailingWhitespace + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> Bool -> LaTeX +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppFds fds unicode + + +ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX +ppFds fds unicode = + if null fds then empty else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> + hsep (map ppDocName vars2) + + +ppClassDecl :: [DocInstance DocName] -> SrcSpan + -> Documentation DocName -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> LaTeX +ppClassDecl instances loc doc subdocs + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode + = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ + instancesBit + where + classheader + | null lsigs = hdr unicode + | otherwise = hdr unicode <+> keyword "where" + + hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds + + body = catMaybes [documentationToLaTeX doc, body_] + + body_ + | null lsigs, null ats, null at_defs = Nothing + | null ats, null at_defs = Just methodTable +--- | otherwise = atTable $$ methodTable + | otherwise = error "LaTeX.ppClassDecl" + + methodTable = + text "\\haddockpremethods{}\\textbf{Methods}" $$ + vcat [ ppFunSig loc doc names typ unicode + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + + instancesBit = ppDocInstances unicode instances + +ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + +ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX +ppDocInstances _unicode [] = empty +ppDocInstances unicode (i : rest) + | Just ihead <- isUndocdInstance i + = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ + ppDocInstances unicode rest' + | otherwise + = ppDocInstance unicode i $$ ppDocInstances unicode rest + where + (is, rest') = spanWith isUndocdInstance rest + +isUndocdInstance :: DocInstance a -> Maybe (InstHead a) +isUndocdInstance (i,Nothing) = Just i +isUndocdInstance _ = Nothing + +-- | Print a possibly commented instance. The instance header is printed inside +-- an 'argBox'. The comment is printed to the right of the box in normal comment +-- style. +ppDocInstance :: Bool -> DocInstance DocName -> LaTeX +ppDocInstance unicode (instHead, doc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) + + +ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead + + +ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode +ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ks ts unicode + <+> maybe empty (\t -> equals <+> ppType unicode t) rhs +ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = + error "data instances not supported by --latex yet" + +lookupAnySubdoc :: (Eq name1) => + name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 +lookupAnySubdoc n subdocs = case lookup n subdocs of + Nothing -> noDocForDecl + Just docs -> docs + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +ppDataDecl :: [DocInstance DocName] -> + [(DocName, DocForDecl DocName)] -> SrcSpan -> + Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> + LaTeX +ppDataDecl instances subdocs _loc doc dataDecl unicode + + = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + + where + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + body = catMaybes [constrBit, doc >>= documentationToLaTeX] + + (whereBit, leaders) + | null cons = (empty,[]) + | otherwise = case resTy of + ResTyGADT _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + + constrBit + | null cons = Nothing + | otherwise = Just $ + text "\\haddockbeginconstrs" $$ + vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ + text "\\end{tabulary}\\par" + + instancesBit = ppDocInstances unicode instances + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr forall tvs ctxt unicode + = (if null tvs then empty else ppForall) + <+> + (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") + where + ppForall = case forall of + Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + Implicit -> empty + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> + case con_res con of + ResTyH98 -> case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppBinder occ) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon fields -> + (decltt (header_ unicode <+> ppBinder occ) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppBinder occ, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could also use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> doGADTCon args resTy + cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ + doRecordFields fields + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) fields) + + doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs (con_cxt con) unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + ) <-> rDoc mbDoc + + + header_ = ppConstrHdr forall tyVars context + occ = nameOccName . getName . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall = con_explicit con + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mkFunTy a b = noLoc (HsFunTy a b) + + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX +ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = + decltt (ppBinder (nameOccName . getName $ name) + <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = lookup name subdocs >>= combineDocumentation . fst + +-- {- +-- ppHsFullConstr :: HsConDecl -> LaTeX +-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = +-- declWithDoc False doc ( +-- hsep ((ppHsConstrHdr tvs ctxt +++ +-- ppHsBinder False nm) : map ppHsBangType typeList) +-- ) +-- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = +-- td << vanillaTable << ( +-- case doc of +-- Nothing -> aboves [hdr, fields_html] +-- Just _ -> aboves [hdr, constr_doc, fields_html] +-- ) +-- +-- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) +-- +-- constr_doc +-- | isJust doc = docBox (docToLaTeX (fromJust doc)) +-- | otherwise = LaTeX.emptyTable +-- +-- fields_html = +-- td << +-- table ! [width "100%", cellpadding 0, cellspacing 8] << ( +-- aboves (map ppFullField (concat (map expandField fields))) +-- ) +-- -} +-- +-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX +-- ppShortField summary unicode (ConDeclField (L _ name) ltype _) +-- = tda [theclass "recfield"] << ( +-- ppBinder summary (docNameOcc name) +-- <+> dcolon unicode <+> ppLType unicode ltype +-- ) +-- +-- {- +-- ppFullField :: HsFieldDecl -> LaTeX +-- ppFullField (HsFieldDecl [n] ty doc) +-- = declWithDoc False doc ( +-- ppHsBinder False n <+> dcolon <+> ppHsBangType ty +-- ) +-- ppFullField _ = error "ppFullField" +-- +-- expandField :: HsFieldDecl -> [HsFieldDecl] +-- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] +-- -} + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX +ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars + , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> + -- context + ppLContext ctxt unicode <+> + -- T a b c ..., or a :+: b + ppAppDocNameNames False name (tyvarNames tyvars) +ppDataHeader _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and two lists of HsTypes (kinds, types) +ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX +ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX +ppAppDocNameNames _summ n ns = + ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX +ppTypeApp n [] (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN n <+> ppT t2 + +ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX +ppContextNoArrow [] _ = empty +ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX +ppContextNoLocs [] _ = empty +ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode + + +ppContext :: HsContext DocName -> Bool -> LaTeX +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsType DocName] -> Bool -> LaTeX +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppType unicode p +pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) + + +------------------------------------------------------------------------------- +-- * Types and contexts +------------------------------------------------------------------------------- + + +ppBang :: HsBang -> LaTeX +ppBang HsNoBang = empty +ppBang _ = char '!' -- Unpacked args is an implementation detail, + + +tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +------------------------------------------------------------------------------- +-- * Rendering of HsType +-- +-- Stolen from Html and tweaked for LaTeX generation +------------------------------------------------------------------------------- + + +pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC +pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX +ppLType unicode y = ppType unicode (unLoc y) +ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) + + +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX +ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode + +ppLKind :: Bool -> LHsKind DocName -> LaTeX +ppLKind unicode y = ppKind unicode (unLoc y) + +ppKind :: Bool -> HsKind DocName -> LaTeX +ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Bool -> LaTeX +ppForAll expl tvs cxt unicode + | show_forall = forall_part <+> ppLContext cxt unicode + | otherwise = ppLContext cxt unicode + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX +ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode + + +ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + +ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys +ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode + where + ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op + occName = nameOccName . getName . unLoc $ op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u + + +ppr_tylit :: HsTyLit -> Bool -> LaTeX +ppr_tylit (HsNumTy n) _ = integer n +ppr_tylit (HsStrTy s) _ = text (show s) + -- XXX: Ok in verbatim, but not otherwise + -- XXX: Do something with Unicode parameter? + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX +ppr_fun_ty ctxt_prec ty1 ty2 unicode + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode + p2 = ppr_mono_lty pREC_TOP ty2 unicode + in + maybeParen ctxt_prec pREC_FUN $ + sep [p1, arrow unicode <+> p2] + + +------------------------------------------------------------------------------- +-- * Names +------------------------------------------------------------------------------- + + +ppBinder :: OccName -> LaTeX +ppBinder n + | isInfixName n = parens $ ppOccName n + | otherwise = ppOccName n + +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isInfixName n = ppOccName n + | otherwise = quotes $ ppOccName n + +isInfixName :: OccName -> Bool +isInfixName n = isVarSym n || isConSym n + +ppSymName :: Name -> LaTeX +ppSymName name + | isNameSym name = parens $ ppName name + | otherwise = ppName name + + +ppVerbOccName :: OccName -> LaTeX +ppVerbOccName = text . latexFilter . occNameString + +ppIPName :: HsIPName -> LaTeX +ppIPName ip = text $ unpackFS $ hsIPNameFS ip + +ppOccName :: OccName -> LaTeX +ppOccName = text . occNameString + + +ppVerbDocName :: DocName -> LaTeX +ppVerbDocName = ppVerbOccName . nameOccName . getName + + +ppVerbRdrName :: RdrName -> LaTeX +ppVerbRdrName = ppVerbOccName . rdrNameOcc + + +ppDocName :: DocName -> LaTeX +ppDocName = ppOccName . nameOccName . getName + + +ppLDocName :: Located DocName -> LaTeX +ppLDocName (L _ d) = ppDocName d + + +ppDocBinder :: DocName -> LaTeX +ppDocBinder = ppBinder . nameOccName . getName + +ppDocBinderInfix :: DocName -> LaTeX +ppDocBinderInfix = ppBinderInfix . nameOccName . getName + + +ppName :: Name -> LaTeX +ppName = ppOccName . nameOccName + + +latexFilter :: String -> String +latexFilter = foldr latexMunge "" + + +latexMonoFilter :: String -> String +latexMonoFilter = foldr latexMonoMunge "" + + +latexMunge :: Char -> String -> String +latexMunge '#' s = "{\\char '43}" ++ s +latexMunge '$' s = "{\\char '44}" ++ s +latexMunge '%' s = "{\\char '45}" ++ s +latexMunge '&' s = "{\\char '46}" ++ s +latexMunge '~' s = "{\\char '176}" ++ s +latexMunge '_' s = "{\\char '137}" ++ s +latexMunge '^' s = "{\\char '136}" ++ s +latexMunge '\\' s = "{\\char '134}" ++ s +latexMunge '{' s = "{\\char '173}" ++ s +latexMunge '}' s = "{\\char '175}" ++ s +latexMunge '[' s = "{\\char 91}" ++ s +latexMunge ']' s = "{\\char 93}" ++ s +latexMunge c s = c : s + + +latexMonoMunge :: Char -> String -> String +latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge '\n' s = '\\' : '\\' : s +latexMonoMunge c s = latexMunge c s + + +------------------------------------------------------------------------------- +-- * Doc Markup +------------------------------------------------------------------------------- + + +parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) +parLatexMarkup ppId = Markup { + markupParagraph = \p v -> p v <> text "\\par" $$ text "", + markupEmpty = \_ -> empty, + markupString = \s v -> text (fixString v s), + markupAppend = \l r v -> l v <> r v, + markupIdentifier = markupId ppId, + markupIdentifierUnchecked = markupId (ppVerbOccName . snd), + markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupWarning = \p v -> emph (p v), + markupEmphasis = \p v -> emph (p v), + markupBold = \p v -> bold (p v), + markupMonospaced = \p _ -> tt (p Mono), + markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", + markupPic = \p _ -> markupPic p, + markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", + markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), + markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", + markupHyperlink = \l _ -> markupLink l, + markupAName = \_ _ -> empty, + markupProperty = \p _ -> quote $ verb $ text p, + markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, + markupHeader = \(Header l h) p -> header l (h p) + } + where + header 1 d = text "\\section*" <> braces d + header 2 d = text "\\subsection*" <> braces d + header l d + | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d + header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + + fixString Plain s = latexFilter s + fixString Verb s = s + fixString Mono s = latexMonoFilter s + + markupLink (Hyperlink url mLabel) = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces (text label) + Nothing -> text "\\url" <> braces (text url) + + -- Is there a better way of doing this? Just a space is an aribtrary choice. + markupPic (Picture uri title) = parens (imageText title) + where + imageText Nothing = beg + imageText (Just t) = beg <> text " " <> text t + + beg = text "image: " <> text uri + + markupId ppId_ id v = + case v of + Verb -> theid + Mono -> theid + Plain -> text "\\haddockid" <> braces theid + where theid = ppId_ id + + +latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup = parLatexMarkup ppVerbDocName + + +rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup = parLatexMarkup ppVerbRdrName + + +docToLaTeX :: Doc DocName -> LaTeX +docToLaTeX doc = markup latexMarkup doc Plain + + +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX = fmap docToLaTeX . combineDocumentation + + +rdrDocToLaTeX :: Doc RdrName -> LaTeX +rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain + + +data StringContext = Plain | Verb | Mono + + +latexStripTrailingWhitespace :: Doc a -> Doc a +latexStripTrailingWhitespace (DocString s) + | null s' = DocEmpty + | otherwise = DocString s + where s' = reverse (dropWhile isSpace (reverse s)) +latexStripTrailingWhitespace (DocAppend l r) + | DocEmpty <- r' = latexStripTrailingWhitespace l + | otherwise = DocAppend l r' + where + r' = latexStripTrailingWhitespace r +latexStripTrailingWhitespace (DocParagraph p) = + latexStripTrailingWhitespace p +latexStripTrailingWhitespace other = other + + +------------------------------------------------------------------------------- +-- * LaTeX utils +------------------------------------------------------------------------------- + + +itemizedList :: [LaTeX] -> LaTeX +itemizedList items = + text "\\begin{itemize}" $$ + vcat (map (text "\\item" $$) items) $$ + text "\\end{itemize}" + + +enumeratedList :: [LaTeX] -> LaTeX +enumeratedList items = + text "\\begin{enumerate}" $$ + vcat (map (text "\\item " $$) items) $$ + text "\\end{enumerate}" + + +descriptionList :: [(LaTeX,LaTeX)] -> LaTeX +descriptionList items = + text "\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ + text "\\end{description}" + + +tt :: LaTeX -> LaTeX +tt ltx = text "\\haddocktt" <> braces ltx + + +decltt :: LaTeX -> LaTeX +decltt ltx = text "\\haddockdecltt" <> braces ltx + + +emph :: LaTeX -> LaTeX +emph ltx = text "\\emph" <> braces ltx + +bold :: LaTeX -> LaTeX +bold ltx = text "\\textbf" <> braces ltx + +verb :: LaTeX -> LaTeX +verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" + -- NB. swallow a trailing \n in the verbatim text by appending the + -- \end{verbatim} directly, otherwise we get spurious blank lines at the + -- end of code blocks. + + +quote :: LaTeX -> LaTeX +quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX +dcolon unicode = text (if unicode then "∷" else "::") +arrow unicode = text (if unicode then "→" else "->") +darrow unicode = text (if unicode then "⇒" else "=>") +forallSymbol unicode = text (if unicode then "∀" else "forall") + + +dot :: LaTeX +dot = char '.' + + +parenList :: [LaTeX] -> LaTeX +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [LaTeX] -> LaTeX +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: LaTeX -> LaTeX +ubxparens h = text "(#" <> h <> text "#)" + + +pabrackets :: LaTeX -> LaTeX +pabrackets h = text "[:" <> h <> text ":]" + + +nl :: LaTeX +nl = text "\\\\" + + +keyword :: String -> LaTeX +keyword = text + + +infixr 4 <-> -- combining table cells +(<->) :: LaTeX -> LaTeX -> LaTeX +a <-> b = a <+> char '&' <+> b diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -0,0 +1,690 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +module Haddock.Backends.Xhtml ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents, +) where + + +import Prelude hiding (div) + +import Haddock.Backends.Xhtml.Decl +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Themes +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Version +import Haddock.Utils +import Text.XHtml hiding ( name, title, p, quote ) +import Haddock.GhcUtils + +import Control.Monad ( when, unless ) +#if !MIN_VERSION_base(4,7,0) +import Control.Monad.Instances ( ) -- for Functor Either a +#endif +import Data.Char ( toUpper ) +import Data.Functor ( (<$>) ) +import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) +import Data.Maybe +import System.FilePath hiding ( () ) +import System.Directory +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import qualified Data.Set as Set hiding ( Set ) +import Data.Function +import Data.Ord ( comparing ) + +import DynFlags (Language(..)) +import GHC hiding ( NoLink, moduleInfo ) +import Name +import Module + +-------------------------------------------------------------------------------- +-- * Generating HTML documentation +-------------------------------------------------------------------------------- + + +ppHtml :: String + -> Maybe String -- ^ Package + -> [Interface] + -> FilePath -- ^ Destination directory + -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe + -> Themes -- ^ Themes + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Maybe String -- ^ The contents URL (--use-contents) + -> Maybe String -- ^ The index URL (--use-index) + -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> QualOption -- ^ How to qualify names + -> Bool -- ^ Output pretty html (newlines and indenting) + -> IO () + +ppHtml doctitle maybe_package ifaces odir prologue + themes maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode + qual debug = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + + when (isNothing maybe_contents_url) $ + ppHtmlContents odir doctitle maybe_package + themes maybe_index_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) + False -- we don't want to display the packages in a single-package contents + prologue debug (makeContentsQual qual) + + when (isNothing maybe_index_url) $ + ppHtmlIndex odir doctitle maybe_package + themes maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) debug + + mapM_ (ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + + +copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () +copyHtmlBits odir libdir themes = do + let + libhtmldir = joinPath [libdir, "html"] + copyCssFile f = copyFile f (combine odir (takeFileName f)) + copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) + mapM_ copyCssFile (cssFiles themes) + mapM_ copyLibFile [ jsFile, framesFile ] + + +headHtml :: String -> Maybe String -> Themes -> Html +headHtml docTitle miniPage themes = + header << [ + meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], + thetitle << docTitle, + styleSheet themes, + script ! [src jsFile, thetype "text/javascript"] << noHtml, + script ! [thetype "text/javascript"] + -- NB: Within XHTML, the content of script tags needs to be + -- a " in it! + << primHtml ( + "//\n") + ] + where + setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage + + +srcButton :: SourceURLs -> Maybe Interface -> Maybe Html +srcButton (Just src_base_url, _, _, _) Nothing = + Just (anchor ! [href src_base_url] << "Source") +srcButton (_, Just src_module_url, _, _) (Just iface) = + let url = spliceURL (Just $ ifaceOrigFilename iface) + (Just $ ifaceMod iface) Nothing Nothing src_module_url + in Just (anchor ! [href url] << "Source") +srcButton _ _ = + Nothing + + +wikiButton :: WikiURLs -> Maybe Module -> Maybe Html +wikiButton (Just wiki_base_url, _, _) Nothing = + Just (anchor ! [href wiki_base_url] << "User Comments") + +wikiButton (_, Just wiki_module_url, _) (Just mdl) = + let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url + in Just (anchor ! [href url] << "User Comments") + +wikiButton _ _ = + Nothing + + +contentsButton :: Maybe String -> Maybe Html +contentsButton maybe_contents_url + = Just (anchor ! [href url] << "Contents") + where url = fromMaybe contentsHtmlFile maybe_contents_url + + +indexButton :: Maybe String -> Maybe Html +indexButton maybe_index_url + = Just (anchor ! [href url] << "Index") + where url = fromMaybe indexHtmlFile maybe_index_url + + +bodyHtml :: String -> Maybe Interface + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String + -> Html -> Html +bodyHtml doctitle iface + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url + pageContent = + body << [ + divPackageHeader << [ + unordList (catMaybes [ + srcButton maybe_source_url iface, + wikiButton maybe_wiki_url (ifaceMod <$> iface), + contentsButton maybe_contents_url, + indexButton maybe_index_url]) + ! [theclass "links", identifier "page-menu"], + nonEmptySectionName << doctitle + ], + divContent << pageContent, + divFooter << paragraph << ( + "Produced by " +++ + (anchor ! [href projectUrl] << toHtml projectName) +++ + (" version " ++ projectVersion) + ) + ] + + +moduleInfo :: Interface -> Html +moduleInfo iface = + let + info = ifaceInfo iface + + doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable + doOneEntry (fieldName, field) = + field info >>= \a -> return (th << fieldName <-> td << a) + + entries :: [HtmlTable] + entries = mapMaybe doOneEntry [ + ("Copyright",hmi_copyright), + ("License",hmi_license), + ("Maintainer",hmi_maintainer), + ("Stability",hmi_stability), + ("Portability",hmi_portability), + ("Safe Haskell",hmi_safety), + ("Language", lg) + ] ++ extsForm + where + lg inf = case hmi_language inf of + Nothing -> Nothing + Just Haskell98 -> Just "Haskell98" + Just Haskell2010 -> Just "Haskell2010" + + extsForm + | OptShowExtensions `elem` ifaceOptions iface = + let fs = map (dropOpt . show) (hmi_extensions info) + in case map stringToHtml fs of + [] -> [] + [x] -> extField x -- don't use a list for a single extension + xs -> extField $ unordList xs ! [theclass "extension-list"] + | otherwise = [] + where + extField x = return $ th << "Extensions" <-> td << x + dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x + in + case entries of + [] -> noHtml + _ -> table ! [theclass "info"] << aboves entries + + +-------------------------------------------------------------------------------- +-- * Generate the module contents +-------------------------------------------------------------------------------- + + +ppHtmlContents + :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) + -> Bool + -> Qualification -- ^ How to qualify names + -> IO () +ppHtmlContents odir doctitle _maybe_package + themes maybe_index_url + maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do + let tree = mkModuleTree showPkgs + [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + html = + headHtml doctitle Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + Nothing maybe_index_url << [ + ppPrologue qual doctitle prologue, + ppModuleTree qual tree + ] + createDirectoryIfMissing True odir + writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + + -- XXX: think of a better place for this? + ppHtmlContentsFrame odir doctitle themes ifaces debug + + +ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html +ppPrologue _ _ Nothing = noHtml +ppPrologue qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) + + +ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree qual ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) + + +mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList qual ss p ts = case ts of + [] -> noHtml + _ -> unordList (zipWith (mkNode qual ss) ps ts) + where + ps = [ p ++ '.' : show i | i <- [(1::Int)..]] + + +mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html +mkNode qual ss p (Node s leaf pkg short ts) = + htmlModule <+> shortDescr +++ htmlPkg +++ subtree + where + modAttrs = case (ts, leaf) of + (_:_, False) -> collapseControl p True "module" + (_, _ ) -> [theclass "module"] + + cBtn = case (ts, leaf) of + (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_, _ ) -> noHtml + -- We only need an explicit collapser button when the module name + -- is also a leaf, and so is a link to a module page. Indeed, the + -- spaceHtml is a minor hack and does upset the layout a fraction. + + htmlModule = thespan ! modAttrs << (cBtn +++ + if leaf + then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg)) + (mkModuleName mdl)) + else toHtml s + ) + + mdl = intercalate "." (reverse (s:ss)) + + shortDescr = maybe noHtml (origDocToHtml qual) short + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + + subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + + +-- | Turn a module tree into a flat list of full module names. E.g., +-- @ +-- A +-- +-B +-- +-C +-- @ +-- becomes +-- @["A", "A.B", "A.B.C"]@ +flatModuleTree :: [InstalledInterface] -> [Html] +flatModuleTree ifaces = + map (uncurry ppModule' . head) + . groupBy ((==) `on` fst) + . sortBy (comparing fst) + $ mods + where + mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] + ppModule' txt mdl = + anchor ! [href (moduleHtmlFile mdl), target mainFrameName] + << toHtml txt + + +ppHtmlContentsFrame :: FilePath -> String -> Themes + -> [InstalledInterface] -> Bool -> IO () +ppHtmlContentsFrame odir doctitle themes ifaces debug = do + let mods = flatModuleTree ifaces + html = + headHtml doctitle Nothing themes +++ + miniBody << divModuleList << + (sectionName << "Modules" +++ + ulist << [ li ! [theclass "module"] << m | m <- mods ]) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html) + + +-------------------------------------------------------------------------------- +-- * Generate the index +-------------------------------------------------------------------------------- + + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] + -> Bool + -> IO () +ppHtmlIndex odir doctitle _maybe_package themes + maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + let html = indexPage split_indices Nothing + (if split_indices then [] else index) + + createDirectoryIfMissing True odir + + when split_indices $ do + mapM_ (do_sub_index index) initialChars + -- Let's add a single large index as well for those who don't know exactly what they're looking for: + let mergedhtml = indexPage False Nothing index + writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + + writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + + where + indexPage showLetters ch items = + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + maybe_contents_url Nothing << [ + if showLetters then indexInitialLetterLinks else noHtml, + if null items then noHtml else + divIndex << [sectionName << indexName ch, buildIndex items] + ] + + indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch + merged_name = "All" + + buildIndex items = table << aboves (map indexElt items) + + -- an arbitrary heuristic: + -- too large, and a single-page will be slow to load + -- too small, and we'll have lots of letter-indexes with only one + -- or two members in them, which seems inefficient or + -- unnecessarily hard to use. + split_indices = length index > 150 + + indexInitialLetterLinks = + divAlphabet << + unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + [ [c] | c <- initialChars + , any ((==c) . toUpper . head . fst) index ] ++ + [merged_name]) + + -- todo: what about names/operators that start with Unicode + -- characters? + -- Exports beginning with '_' can be listed near the end, + -- presumably they're not as important... but would be listed + -- with non-split index! + initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" + + do_sub_index this_ix c + = unless (null index_part) $ + writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + where + html = indexPage True (Just c) index_part + index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] + + + index :: [(String, Map GHC.Name [(Module,Bool)])] + index = sortBy cmp (Map.toAscList full_index) + where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2 + + -- for each name (a plain string), we have a number of original HsNames that + -- it can refer to, and for each of those we have a list of modules + -- that export that entity. Each of the modules exports the entity + -- in a visible or invisible way (hence the Bool). + full_index :: Map String (Map GHC.Name [(Module,Bool)]) + full_index = Map.fromListWith (flip (Map.unionWith (++))) + (concatMap getIfaceIndex ifaces) + + getIfaceIndex iface = + [ (getOccString name + , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) + | name <- instExports iface ] + where + mdl = instMod iface + visible = Set.fromList (instVisibleExports iface) + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + td ! [ theclass "src" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) + + doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable + doAnnotatedEntity (j,(nm,entries)) + = td ! [ theclass "alt" ] << + toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> + indexLinks nm entries + + ppAnnot n | not (isValOcc n) = toHtml "Type/Class" + | isDataOcc n = toHtml "Data Constructor" + | otherwise = toHtml "Function" + + indexLinks nm entries = + td ! [ theclass "module" ] << + hsep (punctuate comma + [ if visible then + linkId mdl (Just nm) << toHtml (moduleString mdl) + else + toHtml (moduleString mdl) + | (mdl, visible) <- entries ]) + + +-------------------------------------------------------------------------------- +-- * Generate the HTML page for a module +-------------------------------------------------------------------------------- + + +ppHtmlModule + :: FilePath -> String -> Themes + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> Bool -> QualOption + -> Bool -> Interface -> IO () +ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug iface = do + let + mdl = ifaceMod iface + aliases = ifaceModuleAliases iface + mdl_str = moduleString mdl + real_qual = makeModuleQual qual aliases mdl + html = + headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ + bodyHtml doctitle (Just iface) + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url << [ + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + ] + + createDirectoryIfMissing True odir + writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug + +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes + -> Interface -> Bool -> Qualification -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do + let mdl = ifaceMod iface + html = + headHtml (moduleString mdl) Nothing themes +++ + miniBody << + (divModuleHeader << sectionName << moduleString mdl +++ + miniSynopsis mdl iface unicode qual) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) + + +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual + = ppModuleContents qual exports +++ + description +++ + synopsis +++ + divInterface (maybe_doc_hdr +++ bdy) + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + -- todo: if something has only sub-docs, or fn-args-docs, should + -- it be measured here and thus prevent omitting the synopsis? + has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc (ExportNoDecl _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection qual (ifaceRnDoc iface) + + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = noHtml + | otherwise + = divSynposis $ + paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + + -- if the documentation doesn't begin with a section header, then + -- add one ("Documentation"). + maybe_doc_hdr + = case exports of + [] -> noHtml + ExportGroup {} : _ -> noHtml + _ -> h1 << "Documentation" + + bdy = + foldr (+++) noHtml $ + mapMaybe (processExport False linksInfo unicode qual) exports + + linksInfo = (maybe_source_url, maybe_wiki_url) + + +miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html +miniSynopsis mdl iface unicode qual = + divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + +processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName + -> [Html] +processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = + ((divTopDecl <<).(declElem <<)) <$> case decl0 of + TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of + (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] + (DataDecl{}) -> [keyword "data" <+> b] + (SynDecl{}) -> [keyword "type" <+> b] + (ClassDecl {}) -> [keyword "class" <+> b] + _ -> [] + SigD (TypeSig lnames (L _ _)) -> + map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames + _ -> [] +processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = + [groupTag lvl << docToHtml qual txt] +processForMiniSynopsis _ _ _ _ = [] + + +ppNameMini :: Notation -> Module -> OccName -> Html +ppNameMini notation mdl nm = + anchor ! [ href (moduleNameUrl mdl nm) + , target mainFrameName ] + << ppBinder' notation nm + + +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini mdl decl = + let n = tcdName decl + ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above + in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName + + +ppModuleContents :: Qualification -> [ExportItem DocName] -> Html +ppModuleContents qual exports + | null sections = noHtml + | otherwise = contentsDiv + where + contentsDiv = divTableOfContents << ( + sectionName << "Contents" +++ + unordList sections) + + (sections, _leftovers{-should be []-}) = process 0 exports + + process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process _ [] = ([], []) + process n items@(ExportGroup lev id0 doc : rest) + | lev <= n = ( [], items ) + | otherwise = ( html:secs, rest2 ) + where + html = linkedAnchor (groupId id0) + << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs + (ssecs, rest1) = process lev rest + (secs, rest2) = process n rest1 + process n (_ : rest) = process n rest + + mk_subsections [] = noHtml + mk_subsections ss = unordList ss + +-- we need to assign a unique id to each section heading so we can hyperlink +-- them from the contents: +numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings = go 1 + where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + go _ [] = [] + go n (ExportGroup lev _ doc : es) + = ExportGroup lev (show n) doc : go (n+1) es + go n (other:es) + = other : go n es + + +processExport :: Bool -> LinksInfo -> Bool -> Qualification + -> ExportItem DocName -> Maybe Html +processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport summary _ _ qual (ExportGroup lev id0 doc) + = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc +processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual +processExport summary _ _ qual (ExportNoDecl y []) + = processDeclOneLiner summary $ ppDocName qual Prefix True y +processExport summary _ _ qual (ExportNoDecl y subs) + = processDeclOneLiner summary $ + ppDocName qual Prefix True y + +++ parenList (map (ppDocName qual Prefix True) subs) +processExport summary _ _ qual (ExportDoc doc) + = nothingIf summary $ docSection_ qual doc +processExport summary _ _ _ (ExportModule mdl) + = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl + + +nothingIf :: Bool -> a -> Maybe a +nothingIf True _ = Nothing +nothingIf False a = Just a + + +processDecl :: Bool -> Html -> Maybe Html +processDecl True = Just +processDecl False = Just . divTopDecl + + +processDeclOneLiner :: Bool -> Html -> Maybe Html +processDeclOneLiner True = Just +processDeclOneLiner False = Just . divTopDecl . declElem + +groupHeading :: Int -> String -> Html -> Html +groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] + +groupTag :: Int -> Html -> Html +groupTag lev + | lev == 1 = h1 + | lev == 2 = h2 + | lev == 3 = h3 + | otherwise = h4 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -0,0 +1,884 @@ +{-# LANGUAGE TransformListComp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Decl +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Decl ( + ppDecl, + + ppTyName, ppTyFamHeader, ppTypeApp, + tyvarNames +) where + + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Doc (combineDocumentation) + +import Data.List ( intersperse, sort ) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid ( mempty ) +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC +import GHC.Exts +import Name +import BooleanFormula + +ppDecl :: Bool -> LinksInfo -> LHsDecl DocName + -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] + -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html +ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of + TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual + TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual + TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual + SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ -> noHtml + _ -> error "declaration not supported by ppDecl" + + +ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = + ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + splice unicode qual + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppFunSig summary links loc doc docnames typ fixities splice unicode qual = + ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + splice unicode qual + where + pp_typ = ppType unicode qual typ + +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + Located DocName -> + HsPatSynDetails (LHsType DocName) -> LHsType DocName -> + LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual = + ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) + (unLoc prov) (unLoc req) fixities splice unicode qual + +ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + DocName -> + HsPatSynDetails (HsType DocName) -> HsType DocName -> + HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities + splice unicode qual + | summary = pref1 + | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) + +++ docSection qual doc + where + pref1 = hsep [ toHtml "pattern" + , pp_cxt prov + , pp_head + , dcolon unicode + , pp_cxt req + , ppType unicode qual typ + ] + pp_head = case args of + PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs + InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] + + pp_cxt cxt = ppContext cxt unicode qual + pp_type = ppParendType unicode qual + + occname = nameOccName . getName $ docname + +ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> + Splice -> Unicode -> Qualification -> Html +ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) + splice unicode qual = + ppTypeOrFunSig summary links loc docnames typ doc + ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode + , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames + , dcolon unicode + ) + splice unicode qual + where + occnames = map (nameOccName . getName) docnames + addFixities html + | summary = html + | otherwise = html <+> ppFixities fixities qual + + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (Html, Html, Html) + -> Splice -> Unicode -> Qualification -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual + | summary = pref1 + | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc + | otherwise = topDeclElem links loc splice docnames pref2 +++ + subArguments qual (do_args 0 sep typ) +++ docSection qual doc + where + argDoc n = Map.lookup n argDocs + + do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] + do_args n leader (HsForAllTy _ tvs lctxt ltype) + = case unLoc lctxt of + [] -> do_largs n leader' ltype + _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, []) + : do_largs n (darrow unicode) ltype + where leader' = leader <+> ppForAll tvs unicode qual + do_args n leader (HsFunTy lt r) + = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [(leader <+> ppType unicode qual t, argDoc n, [])] + +ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html +ppForAll tvs unicode qual = + case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of + [] -> noHtml + ts -> forallSymbol unicode <+> hsep ts +++ dot + where ppKTv n k = parens $ + ppTyName (getName n) <+> dcolon unicode <+> ppLKind unicode qual k + +ppFixities :: [(DocName, Fixity)] -> Qualification -> Html +ppFixities [] _ = noHtml +ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge + where + ppFix (ns, p, d) = thespan ! [theclass "fixity"] << + (toHtml d <+> toHtml (show p) <+> ppNames ns) + + ppDir InfixR = "infixr" + ppDir InfixL = "infixl" + ppDir InfixN = "infix" + + ppNames = case fs of + _:[] -> const noHtml -- Don't display names for fixities on single names + _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) + + uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs + , let d' = ppDir d + , then group by Down (p,d') using groupWith ] + + rightEdge = thespan ! [theclass "rightedge"] << noHtml + + +ppTyVars :: LHsTyVarBndrs DocName -> [Html] +ppTyVars tvs = map ppTyName (tyvarNames tvs) + + +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames + + +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> ForeignDecl DocName -> [(DocName, Fixity)] + -> Splice -> Unicode -> Qualification -> Html +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities + splice unicode qual + = ppFunSig summary links loc doc [name] typ fixities splice unicode qual +ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" + + +-- we skip type patterns for now +ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan + -> DocForDecl DocName -> TyClDecl DocName + -> Splice -> Unicode -> Qualification -> Html +ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) + splice unicode qual + = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) + splice unicode qual + where + hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + full = hdr <+> equals <+> ppLType unicode qual ltype + occ = nameOccName . getName $ name + fixs + | summary = noHtml + | otherwise = ppFixities fixities qual +ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" + + +ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html +ppTypeSig summary nms pp_ty unicode = + concatHtml htmlNames <+> dcolon unicode <+> pp_ty + where + htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms + + +ppTyName :: Name -> Html +ppTyName = ppName Prefix + + +-------------------------------------------------------------------------------- +-- * Type families +-------------------------------------------------------------------------------- + + +ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName + -> Unicode -> Qualification -> Html +ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info + , fdKindSig = mkind }) + unicode qual = + (case info of + OpenTypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ClosedTypeFamily _ + -> keyword "type family" + ) <+> + + ppFamDeclBinderWithVars summary d <+> + + (case mkind of + Just kind -> dcolon unicode <+> ppLKind unicode qual kind + Nothing -> noHtml + ) + +ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> + [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> + FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html +ppTyFam summary associated links instances fixities loc doc decl splice unicode qual + + | summary = ppTyFamHeader True associated decl unicode qual + | otherwise = header_ +++ docSection qual doc +++ instancesBit + + where + docname = unLoc $ fdLName decl + + header_ = topDeclElem links loc splice [docname] $ + ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual + + instancesBit + | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl + , not summary + = subEquations qual $ map (ppTyFamEqn . unLoc) eqns + + | otherwise + = ppInstances instances docname unicode qual + + -- Individual equation of a closed type family + ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs + , tfie_pats = HsWB { hswb_cts = ts }} + = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual + <+> equals <+> ppType unicode qual (unLoc rhs) + , Nothing, [] ) + +-------------------------------------------------------------------------------- +-- * Associated Types +-------------------------------------------------------------------------------- + + +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName + -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html +ppAssocType summ links doc (L loc decl) fixities splice unicode qual = + ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual + + +-------------------------------------------------------------------------------- +-- * TyClDecl helpers +-------------------------------------------------------------------------------- + +-- | Print a type family and its variables +ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html +ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = + ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) + +-- | Print a newtype / data binder and its variables +ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppDataBinderWithVars summ decl = + ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and two lists of HsTypes (kinds, types) +ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] + -> Unicode -> Qualification -> Html +ppAppNameTypes n ks ts unicode qual = + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html +ppAppDocNameNames summ n ns = + ppTypeApp n [] ns ppDN ppTyName + where + ppDN notation = ppBinderFixity notation summ . nameOccName . getName + ppBinderFixity Infix = ppBinderInfix + ppBinderFixity _ = ppBinder + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n [] (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 + +ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode + -> Qualification -> Html +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html +ppContextNoArrow [] _ _ = noHtml +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual + + +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html +ppContextNoLocs [] _ _ = noHtml +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual + <+> darrow unicode + + +ppContext :: HsContext DocName -> Unicode -> Qualification -> Html +ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual + + +ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppCtxType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> Unicode -> Qualification -> Html +ppClassHdr summ lctxt n tvs fds unicode qual = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual + + +ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html +ppFds fds unicode qual = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 + ppVars = hsep . map (ppDocName qual Prefix True) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan + -> [(DocName, DocForDecl DocName)] + -> Splice -> Unicode -> Qualification -> Html +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc + subdocs splice unicode qual = + if not (any isVanillaLSig sigs) && null ats + then (if summary then id else topDeclElem links loc splice [nm]) hdr + else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") + +++ shortSubDecls False + ( + [ ppAssocType summary links doc at [] splice unicode qual | at <- ats + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ + + -- ToDo: add associated type defaults + + [ ppFunSig summary links loc doc names typ [] splice unicode qual + | L _ (TypeSig lnames (L _ typ)) <- sigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + ) + where + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual + nm = unLoc lname +ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + + +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] + -> SrcSpan -> Documentation DocName + -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName + -> Splice -> Unicode -> Qualification -> Html +ppClassDecl summary links instances fixities loc d subdocs + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + splice unicode qual + | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual + | otherwise = classheader +++ docSection qual d + +++ minimalBit +++ atBit +++ methodBit +++ instancesBit + where + classheader + | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) + + -- Only the fixity relevant to the class header + fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual + + nm = tcdName decl + + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + + -- ToDo: add assocatied typ defaults + atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual + | at <- ats + , let n = unL . fdLName $ unL at + doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs + subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] + + methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + subfixs = [ f | n <- names + , f@(n',_) <- fixities + , n == n' ] + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + + minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of + -- Miminal complete definition = every shown method + And xs : _ | sort [getName n | Var (L _ n) <- xs] == + sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] + -> noHtml + + -- Minimal complete definition = the only shown method + Var (L _ n) : _ | [getName n] == + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + -> noHtml + + -- Minimal complete definition = nothing + And [] : _ -> subMinimal $ toHtml "Nothing" + + m : _ -> subMinimal $ ppMinimal False m + _ -> noHtml + + ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs + ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs + where wrap | p = parens | otherwise = id + + instancesBit = ppInstances instances nm unicode qual + +ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + +ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html +ppInstances instances baseName unicode qual + = subInstances qual instName (map instDecl instances) + where + instName = getOccString $ getName baseName + instDecl :: DocInstance DocName -> SubDecl + instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) + instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual + <+> ppAppNameTypes n ks ts unicode qual + instHead (n, ks, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ks ts unicode qual + <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + instHead (n, ks, ts, DataInst dd) = keyword "data" + <+> ppAppNameTypes n ks ts unicode qual + <+> ppShortDataDecl False True dd unicode qual + +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +-- TODO: print contexts +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl unicode qual + + | [] <- cons = dataHeader + + | [lcon] <- cons, ResTyH98 <- resTy, + (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual + = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot + + | ResTyH98 <- resTy = dataHeader + +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) + + | otherwise = (dataHeader <+> keyword "where") + +++ shortSubDecls dataInst (map doGADTConstr cons) + + where + dataHeader + | dataInst = noHtml + | otherwise = ppDataHeader summary dataDecl unicode qual + doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual + doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual + + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> + [(DocName, DocForDecl DocName)] -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> + Splice -> Unicode -> Qualification -> Html +ppDataDecl summary links instances fixities subdocs loc doc dataDecl + splice unicode qual + + | summary = ppShortDataDecl summary False dataDecl unicode qual + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit + + where + docname = tcdName dataDecl + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + header_ = topDeclElem links loc splice [docname] $ + ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix + + fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual + + whereBit + | null cons = noHtml + | otherwise = case resTy of + ResTyGADT _ -> keyword "where" + _ -> noHtml + + constrBit = subConstructors qual + [ ppSideBySideConstr subdocs subfixs unicode qual c + | c <- cons + , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities + ] + + instancesBit = ppInstances instances docname unicode qual + + + +ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html +ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot + where + (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual + + +-- returns three pieces: header, body, footer so that header & footer can be +-- incorporated into the declaration +ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) +ppShortConstrParts summary dataInst con unicode qual = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + (header_ unicode qual +++ hsep (ppBinder summary occ + : map (ppLParendType unicode qual) args), noHtml, noHtml) + RecCon fields -> + (header_ unicode qual +++ ppBinder summary occ <+> char '{', + doRecordFields fields, + char '}') + InfixCon arg1 arg2 -> + (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, + ppBinderInfix summary occ, ppLParendType unicode qual arg2], + noHtml, noHtml) + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) + -- display GADT records with the new syntax, + -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) + -- (except each field gets its own line in docs, to match + -- non-GADT records) + RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> + ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', + doRecordFields fields, + char '}' <+> arrow unicode <+> ppLType unicode qual resTy) + InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + + where + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields) + doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ + ppForAllCon forall_ ltvs lcontext unicode qual, + ppLType unicode qual (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall_ tyVars context + occ = nameOccName . getName . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames ltvs + lcontext = con_cxt con + context = unLoc (con_cxt con) + forall_ = con_explicit con + mkFunTy a b = noLoc (HsFunTy a b) + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode + -> Qualification -> Html +ppConstrHdr forall_ tvs ctxt unicode qual + = (if null tvs then noHtml else ppForall) + +++ + (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") + where + ppForall = case forall_ of + Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " + Implicit -> noHtml + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] + -> Unicode -> Qualification -> LConDecl DocName -> SubDecl +ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) + where + decl = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + hsep ((header_ +++ ppBinder False occ) + : map (ppLParendType unicode qual) args) + <+> fixity + + RecCon _ -> header_ +++ ppBinder False occ <+> fixity + + InfixCon arg1 arg2 -> + hsep [header_ +++ ppLParendType unicode qual arg1, + ppBinderInfix False occ, + ppLParendType unicode qual arg2] + <+> fixity + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could also use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> doGADTCon args resTy + cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + fieldPart = case con_details con of + RecCon fields -> [doRecordFields fields] + _ -> [] + + doRecordFields fields = subFields qual + (map (ppSideBySideField subdocs unicode qual) fields) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html + doGADTCon args resTy = ppBinder False occ <+> dcolon unicode + <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, + ppLType unicode qual (foldr mkFunTy resTy args) ] + <+> fixity + + fixity = ppFixities fixities qual + header_ = ppConstrHdr forall_ tyVars context unicode qual + occ = nameOccName . getName . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall_ = con_explicit con + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst + mkFunTy a b = noLoc (HsFunTy a b) + + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification + -> ConDeclField DocName -> SubDecl +ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = + (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype, + mbDoc, + []) + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = lookup name subdocs >>= combineDocumentation . fst + + +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html +ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) + = ppBinder summary (nameOccName . getName $ name) + <+> dcolon unicode <+> ppLType unicode qual ltype + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppDataHeader summary decl@(DataDecl { tcdDataDefn = + HsDataDefn { dd_ND = nd + , dd_ctxt = ctxt + , dd_kindSig = ks } }) + unicode qual + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) + <+> + -- context + ppLContext ctxt unicode qual <+> + -- T a b c ..., or a :+: b + ppDataBinderWithVars summary decl + <+> case ks of + Nothing -> mempty + Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x + +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Types and contexts +-------------------------------------------------------------------------------- + + +ppBang :: HsBang -> Html +ppBang HsNoBang = noHtml +ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, + -- so we just show the strictness annotation + + +tupleParens :: HsTupleSort -> [Html] -> Html +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +-------------------------------------------------------------------------------- +-- * Rendering of HsType +-------------------------------------------------------------------------------- + + +pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC +pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type + -- (as opposed to (ctx1, ctx2) => type) +pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = 3 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 4 :: Int -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> Html -> Html -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification + -> Located (HsType DocName) -> Html +ppLType unicode qual y = ppType unicode qual (unLoc y) +ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) +ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) + + +ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification + -> HsType DocName -> Html +ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual +ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual +ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual + +ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html +ppLKind unicode qual y = ppKind unicode qual (unLoc y) + +ppKind :: Unicode -> Qualification -> HsKind DocName -> Html +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAllCon expl tvs cxt unicode qual + | show_forall = forall_part <+> ppLContext cxt unicode qual + | otherwise = ppLContext cxt unicode qual + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + + +ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual + = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt unicode qual + <+> ppr_mono_lty pREC_TOP ty unicode qual + +-- UnicodeSyntax alternatives +ppr_mono_ty _ (HsTyVar name) True _ + | getOccString (getName name) == "*" = toHtml "★" + | getOccString (getName name) == "(->)" = toHtml "(→)" + +ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q +ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q = + parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q +ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual + = maybeParen ctxt_prec pREC_CTX $ + ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual + where + ppr_op = ppLDocName qual Infix op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode qual + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual + +ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n + +ppr_tylit :: HsTyLit -> Html +ppr_tylit (HsNumTy n) = toHtml (show n) +ppr_tylit (HsStrTy s) = toHtml (show s) + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual + in + maybeParen ctxt_prec pREC_FUN $ + hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,143 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.DocMarkup +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.DocMarkup ( + docToHtml, + rdrDocToHtml, + origDocToHtml, + docToHtmlNoAnchors, + + docElement, docSection, docSection_, +) where + +import Control.Applicative ((<$>)) + +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils +import Haddock.Doc (combineDocumentation) + +import Text.XHtml hiding ( name, p, quote ) +import Data.Maybe (fromMaybe) + +import GHC + +parHtmlMarkup :: Qualification -> Bool + -> (Bool -> a -> Html) -> DocMarkup a Html +parHtmlMarkup qual insertAnchors ppId = Markup { + markupEmpty = noHtml, + markupString = toHtml, + markupParagraph = paragraph, + markupAppend = (+++), + markupIdentifier = thecode . ppId insertAnchors, + markupIdentifierUnchecked = thecode . ppUncheckedLink qual, + markupModule = \m -> let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef (mkModuleName mdl') ref, + markupWarning = thediv ! [theclass "warning"], + markupEmphasis = emphasize, + markupBold = strong, + markupMonospaced = thecode, + markupUnorderedList = unordList, + markupOrderedList = ordList, + markupDefList = defList, + markupCodeBlock = pre, + markupHyperlink = \(Hyperlink url mLabel) + -> if insertAnchors + then anchor ! [href url] + << fromMaybe url mLabel + else toHtml $ fromMaybe url mLabel, + markupAName = \aname -> namedAnchor aname << "", + markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), + markupProperty = pre . toHtml, + markupExample = examplesToHtml, + markupHeader = \(Header l t) -> makeHeader l t + } + where + makeHeader :: Int -> Html -> Html + makeHeader 1 mkup = h1 mkup + makeHeader 2 mkup = h2 mkup + makeHeader 3 mkup = h3 mkup + makeHeader 4 mkup = h4 mkup + makeHeader 5 mkup = h5 mkup + makeHeader 6 mkup = h6 mkup + makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + + + examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] + + exampleToHtml (Example expression result) = htmlExample + where + htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) + htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] + htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + + +-- If the doc is a single paragraph, don't surround it with

(this causes +-- ugly extra whitespace with some browsers). FIXME: Does this still apply? +docToHtml :: Qualification -> Doc DocName -> Html +docToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (ppDocName qual Raw) + +-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element +-- in links. This is used to generate the Contents box elements. +docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html +docToHtmlNoAnchors qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + +origDocToHtml :: Qualification -> Doc Name -> Html +origDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const $ ppName Raw) + + +rdrDocToHtml :: Qualification -> Doc RdrName -> Html +rdrDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const ppRdrName) + + +docElement :: (Html -> Html) -> Html -> Html +docElement el content_ = + if isNoHtml content_ + then el ! [theclass "doc empty"] << spaceHtml + else el ! [theclass "doc"] << content_ + + +docSection :: Qualification -> Documentation DocName -> Html +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation + + +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual + + +cleanup :: Doc a -> Doc a +cleanup = markup fmtUnParagraphLists + where + -- If there is a single paragraph, then surrounding it with

..

+ -- can add too much whitespace in some browsers (eg. IE). However if + -- we have multiple paragraphs, then we want the extra whitespace to + -- separate them. So we catch the single paragraph case and transform it + -- here. We don't do this in code blocks as it eliminates line breaks. + unParagraph :: Doc a -> Doc a + unParagraph (DocParagraph d) = d + unParagraph doc = doc + + fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists = idMarkup { + markupUnorderedList = DocUnorderedList . map unParagraph, + markupOrderedList = DocOrderedList . map unParagraph + } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -0,0 +1,235 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Layout +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Layout ( + miniBody, + + divPackageHeader, divContent, divModuleHeader, divFooter, + divTableOfContents, divDescription, divSynposis, divInterface, + divIndex, divAlphabet, divModuleList, + + sectionName, + nonEmptySectionName, + + shortDeclList, + shortSubDecls, + + divTopDecl, + + SubDecl, + subArguments, + subAssociatedTypes, + subConstructors, + subEquations, + subFields, + subInstances, + subMethods, + subMinimal, + + topDeclElem, declElem, +) where + + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils (makeAnchorId) + +import qualified Data.Map as Map +import Text.XHtml hiding ( name, title, p, quote ) + +import FastString ( unpackFS ) +import GHC + + +-------------------------------------------------------------------------------- +-- * Sections of the document +-------------------------------------------------------------------------------- + + +miniBody :: Html -> Html +miniBody = body ! [identifier "mini"] + + +sectionDiv :: String -> Html -> Html +sectionDiv i = thediv ! [identifier i] + + +sectionName :: Html -> Html +sectionName = paragraph ! [theclass "caption"] + + +-- | Make an element that always has at least something (a non-breaking space). +-- If it would have otherwise been empty, then give it the class ".empty". +nonEmptySectionName :: Html -> Html +nonEmptySectionName c + | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml + | otherwise = paragraph ! [theclass "caption"] $ c + + +divPackageHeader, divContent, divModuleHeader, divFooter, + divTableOfContents, divDescription, divSynposis, divInterface, + divIndex, divAlphabet, divModuleList + :: Html -> Html + +divPackageHeader = sectionDiv "package-header" +divContent = sectionDiv "content" +divModuleHeader = sectionDiv "module-header" +divFooter = sectionDiv "footer" +divTableOfContents = sectionDiv "table-of-contents" +divDescription = sectionDiv "description" +divSynposis = sectionDiv "synopsis" +divInterface = sectionDiv "interface" +divIndex = sectionDiv "index" +divAlphabet = sectionDiv "alphabet" +divModuleList = sectionDiv "module-list" + + +-------------------------------------------------------------------------------- +-- * Declaration containers +-------------------------------------------------------------------------------- + + +shortDeclList :: [Html] -> Html +shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items + + +shortSubDecls :: Bool -> [Html] -> Html +shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items + where i | inst = li ! [theclass "inst"] + | otherwise = li + c | inst = "inst" + | otherwise = "subs" + + +divTopDecl :: Html -> Html +divTopDecl = thediv ! [theclass "top"] + + +type SubDecl = (Html, Maybe (Doc DocName), [Html]) + + +divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html +divSubDecls cssClass captionName = maybe noHtml wrap + where + wrap = (subSection <<) . (subCaption +++) + subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subCaption = paragraph ! [theclass "caption"] << captionName + + +subDlist :: Qualification -> [SubDecl] -> Maybe Html +subDlist _ [] = Nothing +subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv + where + subEntry (decl, mdoc, subs) = + dterm ! [theclass "src"] << decl + +++ + docElement ddef << (fmap (docToHtml qual) mdoc +++ subs) + + clearDiv = thediv ! [ theclass "clear" ] << noHtml + + +subTable :: Qualification -> [SubDecl] -> Maybe Html +subTable _ [] = Nothing +subTable qual decls = Just $ table << aboves (concatMap subRow decls) + where + subRow (decl, mdoc, subs) = + (td ! [theclass "src"] << decl + <-> + docElement td << fmap (docToHtml qual) mdoc) + : map (cell . (td <<)) subs + + +subBlock :: [Html] -> Maybe Html +subBlock [] = Nothing +subBlock hs = Just $ toHtml hs + + +subArguments :: Qualification -> [SubDecl] -> Html +subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual + + +subAssociatedTypes :: [Html] -> Html +subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock + + +subConstructors :: Qualification -> [SubDecl] -> Html +subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual + + +subFields :: Qualification -> [SubDecl] -> Html +subFields qual = divSubDecls "fields" "Fields" . subDlist qual + + +subEquations :: Qualification -> [SubDecl] -> Html +subEquations qual = divSubDecls "equations" "Equations" . subTable qual + + +subInstances :: Qualification -> String -> [SubDecl] -> Html +subInstances qual nm = maybe noHtml wrap . instTable + where + wrap = (subSection <<) . (subCaption +++) + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + subSection = thediv ! [theclass "subs instances"] + subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + id_ = makeAnchorId $ "i:" ++ nm + +subMethods :: [Html] -> Html +subMethods = divSubDecls "methods" "Methods" . subBlock + +subMinimal :: Html -> Html +subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem + + +-- a box for displaying code +declElem :: Html -> Html +declElem = paragraph ! [theclass "src"] + + +-- a box for top level documented names +-- it adds a source and wiki link at the right hand side of the box +topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html +topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = + declElem << (html <+> srcLink <+> wikiLink) + where srcLink = let nameUrl = Map.lookup origPkg sourceMap + lineUrl = Map.lookup origPkg lineMap + mUrl | splice = lineUrl + -- Use the lineUrl as a backup + | otherwise = maybe lineUrl Just nameUrl in + case mUrl of + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just origMod) + (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << "Source" + + wikiLink = + case maybe_wiki_url of + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just mdl) + (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << "Comments" + + -- For source links, we want to point to the original module, + -- because only that will have the source. + -- TODO: do something about type instances. They will point to + -- the module defining the type family, which is wrong. + origMod = nameModule n + origPkg = modulePackageId origMod + + -- Name must be documented, otherwise we wouldn't get here + Documented n mdl = head names + -- FIXME: is it ok to simply take the first name? + + fname = case loc of + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -0,0 +1,171 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Names +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Names ( + ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, + ppBinder, ppBinderInfix, ppBinder', + ppModule, ppModuleRef, ppIPName, linkId, Notation(..) +) where + + +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Data.Map as M +import qualified Data.List as List + +import GHC +import Name +import RdrName +import FastString (unpackFS) + + +-- | Indicator of how to render a 'DocName' into 'Html' +data Notation = Raw -- ^ Render as-is. + | Infix -- ^ Render using infix notation. + | Prefix -- ^ Render using prefix notation. + deriving (Eq, Show) + +ppOccName :: OccName -> Html +ppOccName = toHtml . occNameString + + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + +ppIPName :: HsIPName -> Html +ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS + + +ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html +ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName + + +-- The Bool indicates if it is to be rendered in infix notation +ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName qual notation (L _ d) = ppDocName qual notation True d + +ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html +ppDocName qual notation insertAnchors docName = + case docName of + Documented name mdl -> + linkIdOcc mdl (Just (nameOccName name)) insertAnchors + << ppQualifyName qual notation name mdl + Undocumented name + | isExternalName name || isWiredInName name -> + ppQualifyName qual notation name (nameModule name) + | otherwise -> ppName notation name + +-- | Render a name depending on the selected qualification mode +ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html +ppQualifyName qual notation name mdl = + case qual of + NoQual -> ppName notation name + FullQual -> ppFullQualName notation mdl name + LocalQual localmdl -> + if moduleString mdl == moduleString localmdl + then ppName notation name + else ppFullQualName notation mdl name + RelativeQual localmdl -> + case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + -- local, A.x -> x + Just [] -> ppName notation name + -- sub-module, A.B.x -> B.x + Just ('.':m) -> toHtml $ m ++ '.' : getOccString name + -- some module with same prefix, ABC.x -> ABC.x + Just _ -> ppFullQualName notation mdl name + -- some other module, D.x -> D.x + Nothing -> ppFullQualName notation mdl name + AliasedQual aliases localmdl -> + case (moduleString mdl == moduleString localmdl, + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName notation alias name + _ -> ppName notation name + + +ppFullQualName :: Notation -> Module -> Name -> Html +ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname + where + qname = toHtml $ moduleString mdl ++ '.' : getOccString name + +ppQualName :: Notation -> ModuleName -> Name -> Html +ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname + where + qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name + +ppName :: Notation -> Name -> Html +ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name) + + +ppBinder :: Bool -> OccName -> Html +-- The Bool indicates whether we are generating the summary, in which case +-- the binder will be a link to the full definition. +ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n +ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' Prefix n + +ppBinderInfix :: Bool -> OccName -> Html +ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n +ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' Infix n + +ppBinder' :: Notation -> OccName -> Html +ppBinder' notation n = wrapInfix notation n $ ppOccName n + +wrapInfix :: Notation -> OccName -> Html -> Html +wrapInfix notation n = case notation of + Infix | is_star_kind -> id + | not is_sym -> quote + Prefix | is_star_kind -> id + | is_sym -> parens + _ -> id + where + is_sym = isSymOcc n + is_star_kind = isTcOcc n && occNameString n == "*" + +linkId :: Module -> Maybe Name -> Html -> Html +linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True + + +linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html +linkIdOcc mdl mbName insertAnchors = + if insertAnchors + then anchor ! [href url] + else id + where + url = case mbName of + Nothing -> moduleUrl mdl + Just name -> moduleNameUrl mdl name + + +linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html +linkIdOcc' mdl mbName = anchor ! [href url] + where + url = case mbName of + Nothing -> moduleHtmlFile' mdl + Just name -> moduleNameUrl' mdl name + + +ppModule :: Module -> Html +ppModule mdl = anchor ! [href (moduleUrl mdl)] + << toHtml (moduleString mdl) + + +ppModuleRef :: ModuleName -> String -> Html +ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) + -- NB: The ref parameter already includes the '#'. + -- This function is only called from markupModule expanding a + -- DocModule, which doesn't seem to be ever be used. diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -0,0 +1,209 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Themes +-- Copyright : (c) Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Themes ( + Themes, + getThemes, + + cssFiles, styleSheet + ) + where + +import Haddock.Options + +import Control.Applicative +import Control.Monad (liftM) +import Data.Char (toLower) +import Data.Either (lefts, rights) +import Data.List (nub) +import Data.Maybe (isJust, listToMaybe) + +import System.Directory +import System.FilePath +import Text.XHtml hiding ( name, title, p, quote, () ) +import qualified Text.XHtml as XHtml + + +-------------------------------------------------------------------------------- +-- * CSS Themes +-------------------------------------------------------------------------------- + +data Theme = Theme { + themeName :: String, + themeHref :: String, + themeFiles :: [FilePath] + } + +type Themes = [Theme] + +type PossibleTheme = Either String Theme +type PossibleThemes = Either String Themes + + +-- | Find a theme by name (case insensitive match) +findTheme :: String -> Themes -> Maybe Theme +findTheme s = listToMaybe . filter ((== ls).lower.themeName) + where lower = map toLower + ls = lower s + + +-- | Standard theme used by default +standardTheme :: FilePath -> IO PossibleThemes +standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) + + +-- | Default themes that are part of Haddock; added with --default-themes +-- The first theme in this list is considered the standard theme. +-- Themes are "discovered" by scanning the html sub-dir of the libDir, +-- and looking for directories with the extension .theme or .std-theme. +-- The later is, obviously, the standard theme. +defaultThemes :: FilePath -> IO PossibleThemes +defaultThemes libDir = do + themeDirs <- getDirectoryItems (libDir "html") + themes <- mapM directoryTheme $ discoverThemes themeDirs + return $ sequenceEither themes + where + discoverThemes paths = + filterExt ".std-theme" paths ++ filterExt ".theme" paths + filterExt ext = filter ((== ext).takeExtension) + + +-- | Build a theme from a single .css file +singleFileTheme :: FilePath -> IO PossibleTheme +singleFileTheme path = + if isCssFilePath path + then retRight $ Theme name file [path] + else errMessage "File extension isn't .css" path + where + name = takeBaseName path + file = takeFileName path + + +-- | Build a theme from a directory +directoryTheme :: FilePath -> IO PossibleTheme +directoryTheme path = do + items <- getDirectoryItems path + case filter isCssFilePath items of + [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items + [] -> errMessage "No .css file in theme directory" path + _ -> errMessage "More than one .css file in theme directory" path + + +-- | Check if we have a built in theme +doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool +doesBuiltInExist pts s = fmap (either (const False) test) pts + where test = isJust . findTheme s + + +-- | Find a built in theme +builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme +builtInTheme pts s = either Left fetch <$> pts + where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s + + +-------------------------------------------------------------------------------- +-- * CSS Theme Arguments +-------------------------------------------------------------------------------- + +-- | Process input flags for CSS Theme arguments +getThemes :: FilePath -> [Flag] -> IO PossibleThemes +getThemes libDir flags = + liftM concatEither (mapM themeFlag flags) >>= someTheme + where + themeFlag :: Flag -> IO (Either String Themes) + themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) + themeFlag (Flag_BuiltInThemes) = builtIns + themeFlag _ = retRight [] + + theme :: FilePath -> IO PossibleTheme + theme path = pick path + [(doesFileExist, singleFileTheme), + (doesDirectoryExist, directoryTheme), + (doesBuiltInExist builtIns, builtInTheme builtIns)] + "Theme not found" + + pick :: FilePath + -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String + -> IO PossibleTheme + pick path [] msg = errMessage msg path + pick path ((test,build):opts) msg = do + pass <- test path + if pass then build path else pick path opts msg + + + someTheme :: Either String Themes -> IO (Either String Themes) + someTheme (Right []) = standardTheme libDir + someTheme est = return est + + builtIns = defaultThemes libDir + + +errMessage :: String -> FilePath -> IO (Either String a) +errMessage msg path = return (Left msg') + where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n" + + +retRight :: a -> IO (Either String a) +retRight = return . Right + + +-------------------------------------------------------------------------------- +-- * File Utilities +-------------------------------------------------------------------------------- + + +getDirectoryItems :: FilePath -> IO [FilePath] +getDirectoryItems path = + map (combine path) . filter notDot <$> getDirectoryContents path + where notDot s = s /= "." && s /= ".." + + +isCssFilePath :: FilePath -> Bool +isCssFilePath path = takeExtension path == ".css" + + +-------------------------------------------------------------------------------- +-- * Style Sheet Utilities +-------------------------------------------------------------------------------- + +cssFiles :: Themes -> [String] +cssFiles ts = nub $ concatMap themeFiles ts + + +styleSheet :: Themes -> Html +styleSheet ts = toHtml $ zipWith mkLink rels ts + where + rels = "stylesheet" : repeat "alternate stylesheet" + mkLink aRel t = + thelink + ! [ href (themeHref t), rel aRel, thetype "text/css", + XHtml.title (themeName t) + ] + << noHtml + +-------------------------------------------------------------------------------- +-- * Either Utilities +-------------------------------------------------------------------------------- + +-- These three routines are here because Haddock does not have access to the +-- Control.Monad.Error module which supplies the Functor and Monad instances +-- for Either String. + +sequenceEither :: [Either a b] -> Either a [b] +sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es)) + + +liftEither :: (b -> c) -> Either a b -> Either a c +liftEither f = either Left (Right . f) + + +concatEither :: [Either a [b]] -> Either a [b] +concatEither = liftEither concat . sequenceEither + diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Types ( + SourceURLs, WikiURLs, + LinksInfo, + Splice, + Unicode, +) where + + +import Data.Map +import GHC + + +-- the base, module and entity URLs for the source code and wiki links. +type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath) +type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) + + +-- The URL for source and wiki links +type LinksInfo = (SourceURLs, WikiURLs) + +-- Whether something is a splice or not +type Splice = Bool + +-- Whether unicode syntax is to be used +type Unicode = Bool diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Util +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Utils ( + renderToString, + + namedAnchor, linkedAnchor, + spliceURL, + groupId, + + (<+>), (<=>), char, + keyword, punctuate, + + braces, brackets, pabrackets, parens, parenList, ubxParenList, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + + hsep, vcat, + + collapseSection, collapseToggle, collapseControl, +) where + + +import Haddock.GhcUtils +import Haddock.Utils + +import Data.Maybe + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as XHtml + +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) +import Module ( Module ) +import Name ( getOccString, nameOccName, isValOcc ) + + +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run + where + file = fromMaybe "" maybe_file + mdl = case maybe_mod of + Nothing -> "" + Just m -> moduleString m + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + line = case maybe_loc of + Nothing -> "" + Just span_ -> + case span_ of + RealSrcSpan span__ -> + show $ srcSpanStartLine span__ + UnhelpfulSpan _ -> + error "spliceURL UnhelpfulSpan" + + run "" = "" + run ('%':'M':rest) = mdl ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + run ('%':'L':rest) = line ++ run rest + run ('%':'%':rest) = '%' : run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest + run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest + run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest + run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = + map (\x -> if x == '.' then c else x) mdl ++ run rest + + run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = + map (\x -> if x == '/' then c else x) file ++ run rest + + run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest + + run (c:rest) = c : run rest + + +renderToString :: Bool -> Html -> String +renderToString debug html + | debug = renderHtml html + | otherwise = showHtml html + + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + +-- | Concatenate a series of 'Html' values vertically, with linebreaks in between. +vcat :: [Html] -> Html +vcat [] = noHtml +vcat htmls = foldr1 (\a b -> a+++br+++b) htmls + + +infixr 8 <+> +(<+>) :: Html -> Html -> Html +a <+> b = a +++ sep +++ b + where + sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " + +-- | Join two 'Html' values together with a linebreak in between. +-- Has 'noHtml' as left identity. +infixr 8 <=> +(<=>) :: Html -> Html -> Html +a <=> b = a +++ sep +++ b + where + sep = if isNoHtml a then noHtml else br + + +keyword :: String -> Html +keyword s = thespan ! [theclass "keyword"] << toHtml s + + +equals, comma :: Html +equals = char '=' +comma = char ',' + + +char :: Char -> Html +char c = toHtml [c] + + +quote :: Html -> Html +quote h = char '`' +++ h +++ '`' + + +parens, brackets, pabrackets, braces :: Html -> Html +parens h = char '(' +++ h +++ char ')' +brackets h = char '[' +++ h +++ char ']' +pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +braces h = char '{' +++ h +++ char '}' + + +punctuate :: Html -> [Html] -> [Html] +punctuate _ [] = [] +punctuate h (d0:ds) = go d0 ds + where + go d [] = [d] + go d (e:es) = (d +++ h) : go e es + + +parenList :: [Html] -> Html +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [Html] -> Html +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: Html -> Html +ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon unicode = toHtml (if unicode then "∷" else "::") +arrow unicode = toHtml (if unicode then "→" else "->") +darrow unicode = toHtml (if unicode then "⇒" else "=>") +forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" + + +dot :: Html +dot = toHtml "." + + +-- | Generate a named anchor +namedAnchor :: String -> Html -> Html +namedAnchor n = anchor ! [XHtml.name n] + + +linkedAnchor :: String -> Html -> Html +linkedAnchor n = anchor ! [href ('#':n)] + + +-- | generate an anchor identifier for a group +groupId :: String -> String +groupId g = makeAnchorId ("g:" ++ g) + +-- +-- A section of HTML which is collapsible. +-- + +-- | Attributes for an area that can be collapsed +collapseSection :: String -> Bool -> String -> [HtmlAttr] +collapseSection id_ state classes = [ identifier sid, theclass cs ] + where cs = unwords (words classes ++ [pick state "show" "hide"]) + sid = "section." ++ id_ + +-- | Attributes for an area that toggles a collapsed area +collapseToggle :: String -> [HtmlAttr] +collapseToggle id_ = [ strAttr "onclick" js ] + where js = "toggleSection('" ++ id_ ++ "')"; + +-- | Attributes for an area that toggles a collapsed area, +-- and displays a control. +collapseControl :: String -> Bool -> String -> [HtmlAttr] +collapseControl id_ state classes = + [ identifier cid, theclass cs ] ++ collapseToggle id_ + where cs = unwords (words classes ++ [pick state "collapser" "expander"]) + cid = "control." ++ id_ + + +pick :: Bool -> a -> a -> a +pick True t _ = t +pick False _ f = f diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Convert.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE CPP, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Convert +-- Copyright : (c) Isaac Dupree 2009, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Conversion between TyThing and HsDecl. This functionality may be moved into +-- GHC at some point. +----------------------------------------------------------------------------- +module Haddock.Convert where +-- Some other functions turned out to be useful for converting +-- instance heads, which aren't TyThings, so just export everything. + + +import HsSyn +import TcType ( tcSplitSigmaTy ) +import TypeRep +import Type(isStrLitTy) +import Kind ( splitKindFunTys, synTyConResKind, isKind ) +import Name +import Var +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import FamInstEnv +import BasicTypes ( TupleSort(..) ) +import TysPrim ( alphaTyVars ) +import TysWiredIn ( listTyConName, eqTyCon ) +import PrelNames (ipClassName) +import Bag ( emptyBag ) +import Unique ( getUnique ) +import SrcLoc ( Located, noLoc, unLoc ) +import Data.List( partition ) +import Haddock.Types + + +-- the main function here! yay! +tyThingToLHsDecl :: TyThing -> LHsDecl Name +tyThingToLHsDecl t = noLoc $ case t of + -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. + -- Including built-in functions like seq. + -- foreign-imported functions could be represented with ForD + -- instead of SigD if we wanted... + -- + -- in a future code version we could turn idVarDetails = foreign-call + -- into a ForD instead of a SigD if we wanted. Haddock doesn't + -- need to care. + AnId i -> SigD (synifyIdSig ImplicitizeForAll i) + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ATyCon tc + | Just cl <- tyConClass_maybe tc -- classes are just a little tedious + -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a + extractFamilyDecl (FamDecl d) = noLoc d + extractFamilyDecl _ = + error "tyThingToLHsDecl: impossible associated tycon" + + atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] + atFamDecls = map extractFamilyDecl atTyClDecls in + TyClD $ ClassDecl + { tcdCtxt = synifyCtx (classSCTheta cl) + , tcdLName = synifyName cl + , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdFDs = map (\ (l,r) -> noLoc + (map getName l, map getName r) ) $ + snd $ classTvsFds cl + , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : + map (noLoc . synifyIdSig DeleteTopLevelQuantification) + (classMethods cl) + , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature + -- class associated-types are a subset of TyCon: + , tcdATs = atFamDecls + , tcdATDefs = [] --ignore associated type defaults + , tcdDocs = [] --we don't have any docs at this point + , tcdFVs = placeHolderNames } + | otherwise + -> TyClD (synifyTyCon Nothing tc) + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ACoAxiom ax -> synifyAxiom ax + + -- a data-constructor alone just gets rendered as a function: + AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] + (synifyType ImplicitizeForAll (dataConUserType dc))) + + AConLike (PatSynCon ps) -> +#if MIN_VERSION_ghc(7,8,3) + let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps +#else + let (_, _, (req_theta, prov_theta)) = patSynSig ps +#endif + in SigD $ PatSynSig (synifyName ps) +#if MIN_VERSION_ghc(7,8,3) + (fmap (synifyType WithinType) (patSynTyDetails ps)) + (synifyType WithinType res_ty) +#else + (fmap (synifyType WithinType) (patSynTyDetails ps)) + (synifyType WithinType (patSynType ps)) +#endif + (synifyCtx req_theta) + (synifyCtx prov_theta) + +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name +synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) + = let name = synifyName tc + typats = map (synifyType WithinType) args + hs_rhs = synifyType WithinType rhs + (kvs, tvs) = partition isKindVar tkvs + in TyFamInstEqn { tfie_tycon = name + , tfie_pats = HsWB { hswb_cts = typats + , hswb_kvs = map tyVarName kvs + , hswb_tvs = map tyVarName tvs } + , tfie_rhs = hs_rhs } + +synifyAxiom :: CoAxiom br -> HsDecl Name +synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) + | isOpenSynFamilyTyCon tc + , Just branch <- coAxiomSingleBranch_maybe ax + = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch + , tfid_fvs = placeHolderNames })) + + | Just ax' <- isClosedSynFamilyTyCon_maybe tc + , getUnique ax' == getUnique ax -- without the getUniques, type error + = TyClD (synifyTyCon (Just ax) tc) + + | otherwise + = error "synifyAxiom: closed/open family confusion" + +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name +synifyTyCon coax tc + | isFunTyCon tc || isPrimTyCon tc + = DataDecl { tcdLName = synifyName tc + , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: + let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind) + in HsQTvs { hsq_kvs = [] -- No kind polymorphism + , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + alphaTyVars --a, b, c... which are unfortunately all kind * + } + + , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + -- algebraic data nor newtype: + , dd_ctxt = noLoc [] + , dd_cType = Nothing + , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + -- we have their kind accurately: + , dd_cons = [] -- No constructors + , dd_derivs = Nothing } + , tcdFVs = placeHolderNames } + + | isSynFamilyTyCon tc + = case synTyConRhs_maybe tc of + Just rhs -> + let info = case rhs of + OpenSynFamilyTyCon -> OpenTypeFamily + ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> + ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches) + _ -> error "synifyTyCon: type/data family confusion" + in FamDecl (FamilyDecl { fdInfo = info + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) }) + Nothing -> error "synifyTyCon: impossible open type synonym?" + + | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?) + case algTyConRhs tc of + DataFamilyTyCon -> + FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) + Nothing) --always kind '*' + _ -> error "synifyTyCon: impossible open data type?" + | isSynTyCon tc + = case synTyConRhs_maybe tc of + Just (SynonymTyCon ty) -> + SynDecl { tcdLName = synifyName tc + , tcdTyVars = synifyTyVars (tyConTyVars tc) + , tcdRhs = synifyType WithinType ty + , tcdFVs = placeHolderNames } + _ -> error "synifyTyCon: impossible synTyCon" + | otherwise = + -- (closed) newtype and data + let + alg_nd = if isNewTyCon tc then NewType else DataType + alg_ctx = synifyCtx (tyConStupidTheta tc) + name = case coax of + Just a -> synifyName a -- Data families are named according to their + -- CoAxioms, not their TyCons + _ -> synifyName tc + tyvars = synifyTyVars (tyConTyVars tc) + kindSig = Just (tyConKind tc) + -- The data constructors. + -- + -- Any data-constructors not exported from the module that *defines* the + -- type will not (cannot) be included. + -- + -- Very simple constructors, Haskell98 with no existentials or anything, + -- probably look nicer in non-GADT syntax. In source code, all constructors + -- must be declared with the same (GADT vs. not) syntax, and it probably + -- is less confusing to follow that principle for the documentation as well. + -- + -- There is no sensible infix-representation for GADT-syntax constructor + -- declarations. They cannot be made in source code, but we could end up + -- with some here in the case where some constructors use existentials. + -- That seems like an acceptable compromise (they'll just be documented + -- in prefix position), since, otherwise, the logic (at best) gets much more + -- complicated. (would use dataConIsInfix.) + use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) + cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) + -- "deriving" doesn't affect the signature, no need to specify any. + alg_deriv = Nothing + defn = HsDataDefn { dd_ND = alg_nd + , dd_ctxt = alg_ctx + , dd_cType = Nothing + , dd_kindSig = fmap synifyKindSig kindSig + , dd_cons = cons + , dd_derivs = alg_deriv } + in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn + , tcdFVs = placeHolderNames } + +-- User beware: it is your responsibility to pass True (use_gadt_syntax) +-- for any constructor that would be misrepresented by omitting its +-- result-type. +-- But you might want pass False in simple enough cases, +-- if you think it looks better. +synifyDataCon :: Bool -> DataCon -> LConDecl Name +synifyDataCon use_gadt_syntax dc = noLoc $ + let + -- dataConIsInfix allegedly tells us whether it was declared with + -- infix *syntax*. + use_infix_syntax = dataConIsInfix dc + use_named_field_syntax = not (null field_tys) + name = synifyName dc + -- con_qvars means a different thing depending on gadt-syntax + (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + + qvars = if use_gadt_syntax + then synifyTyVars (univ_tvs ++ ex_tvs) + else synifyTyVars ex_tvs + + -- skip any EqTheta, use 'orig'inal syntax + ctx = synifyCtx theta + + linear_tys = zipWith (\ty bang -> + let tySyn = synifyType WithinType ty + src_bang = case bang of + HsUnpack {} -> HsUserBang (Just True) True + HsStrict -> HsUserBang (Just False) True + _ -> bang + in case src_bang of + HsNoBang -> tySyn + _ -> noLoc $ HsBangTy bang tySyn + -- HsNoBang never appears, it's implied instead. + ) + arg_tys (dataConStrictMarks dc) + field_tys = zipWith (\field synTy -> ConDeclField + (synifyName field) synTy Nothing) + (dataConFieldLabels dc) linear_tys + hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of + (True,True) -> error "synifyDataCon: contradiction!" + (True,False) -> RecCon field_tys + (False,False) -> PrefixCon linear_tys + (False,True) -> case linear_tys of + [a,b] -> InfixCon a b + _ -> error "synifyDataCon: infix with non-2 args?" + hs_res_ty = if use_gadt_syntax + then ResTyGADT (synifyType WithinType res_ty) + else ResTyH98 + -- finally we get synifyDataCon's result! + in ConDecl name Implicit{-we don't know nor care-} + qvars ctx hs_arg_tys hs_res_ty Nothing + False --we don't want any "deprecated GADT syntax" warnings! + + +synifyName :: NamedThing n => n -> Located Name +synifyName = noLoc . getName + + +synifyIdSig :: SynifyTypeState -> Id -> Sig Name +synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) + + +synifyCtx :: [PredType] -> LHsContext Name +synifyCtx = noLoc . map (synifyType WithinType) + + +synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs + , hsq_tvs = map synifyTyVar tvs } + where + (kvs, tvs) = partition isKindVar ktvs + synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv + +--states of what to do with foralls: +data SynifyTypeState + = WithinType + -- ^ normal situation. This is the safe one to use if you don't + -- quite understand what's going on. + | ImplicitizeForAll + -- ^ beginning of a function definition, in which, to make it look + -- less ugly, those rank-1 foralls are made implicit. + | DeleteTopLevelQuantification + -- ^ because in class methods the context is added to the type + -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) + -- which is rather sensible, + -- but we want to restore things to the source-syntax situation where + -- the defining class gets to quantify all its functions for free! + + +synifyType :: SynifyTypeState -> Type -> LHsType Name +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyConApp tc tys) + -- Use non-prefix tuple syntax where possible, because it looks nicer. + | isTupleTyCon tc, tyConArity tc == length tys = + noLoc $ HsTupleTy (case tupleTyConSort tc of + BoxedTuple -> HsBoxedTuple + ConstraintTuple -> HsConstraintTuple + UnboxedTuple -> HsUnboxedTuple) + (map (synifyType WithinType) tys) + -- ditto for lists + | getName tc == listTyConName, [ty] <- tys = + noLoc $ HsListTy (synifyType WithinType ty) + -- ditto for implicit parameter tycons + | tyConName tc == ipClassName + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) + -- and equalities + | tc == eqTyCon + , [ty1, ty2] <- tys + = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + -- Most TyCons: + | otherwise = + foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) + (noLoc $ HsTyVar (getName tc)) + (map (synifyType WithinType) tys) +synifyType _ (AppTy t1 t2) = let + s1 = synifyType WithinType t1 + s2 = synifyType WithinType t2 + in noLoc $ HsAppTy s1 s2 +synifyType _ (FunTy t1 t2) = let + s1 = synifyType WithinType t1 + s2 = synifyType WithinType t2 + in noLoc $ HsFunTy s1 s2 +synifyType s forallty@(ForAllTy _tv _ty) = + let (tvs, ctx, tau) = tcSplitSigmaTy forallty + in case s of + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau + _ -> let + forallPlicitness = case s of + WithinType -> Explicit + ImplicitizeForAll -> Implicit + _ -> error "synifyType: impossible case!!!" + sTvs = synifyTyVars tvs + sCtx = synifyCtx ctx + sTau = synifyType WithinType tau + in noLoc $ + HsForAllTy forallPlicitness sTvs sCtx sTau +synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t + +synifyTyLit :: TyLit -> HsTyLit +synifyTyLit (NumTyLit n) = HsNumTy n +synifyTyLit (StrTyLit s) = HsStrTy s + +synifyKindSig :: Kind -> LHsKind Name +synifyKindSig k = synifyType WithinType k + +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name +synifyInstHead (_, preds, cls, types) = + ( getName cls + , map (unLoc . synifyType WithinType) ks + , map (unLoc . synifyType WithinType) ts + , ClassInst $ map (unLoc . synifyType WithinType) preds + ) + where (ks,ts) = break (not . isKind) types + +-- Convert a family instance, this could be a type family or data family +synifyFamInst :: FamInst -> Bool -> InstHead Name +synifyFamInst fi opaque = + ( fi_fam fi + , map (unLoc . synifyType WithinType) ks + , map (unLoc . synifyType WithinType) ts + , case fi_flavor fi of + SynFamilyInst | opaque -> TypeInst Nothing + SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi + DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c + ) + where (ks,ts) = break (not . isKind) $ fi_tys fi diff --git a/haddock-api/src/Haddock/Doc.hs b/haddock-api/src/Haddock/Doc.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Doc.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haddock.Doc ( module Documentation.Haddock.Doc + , docCodeBlock + , combineDocumentation + ) where + +import Data.Maybe +import Documentation.Haddock.Doc +import Haddock.Types + +combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation (Documentation Nothing Nothing) = Nothing +combineDocumentation (Documentation mDoc mWarning) = + Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc) + +-- Drop trailing whitespace from @..@ code blocks. Otherwise this: +-- +-- -- @ +-- -- foo +-- -- @ +-- +-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML +-- gives an extra vertical space after the code block. The single space +-- on the final line seems to trigger the extra vertical space. +-- +docCodeBlock :: DocH mod id -> DocH mod id +docCodeBlock (DocString s) + = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) +docCodeBlock (DocAppend l r) + = DocAppend l (docCodeBlock r) +docCodeBlock d = d diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.GhcUtils +-- Copyright : (c) David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Utils for dealing with types from the GHC API +----------------------------------------------------------------------------- +module Haddock.GhcUtils where + + +import Data.Version +import Control.Applicative ( (<$>) ) +import Control.Arrow +import Data.Foldable hiding (concatMap) +import Data.Function +import Data.Traversable +import Distribution.Compat.ReadP +import Distribution.Text + +import Exception +import Outputable +import Name +import Packages +import Module +import RdrName (GlobalRdrEnv) +import GhcMonad (withSession) +import HscTypes +import UniqFM +import GHC +import Class + + +moduleString :: Module -> String +moduleString = moduleNameString . moduleName + + +-- return the (name,version) of the package +modulePackageInfo :: Module -> (String, [Char]) +modulePackageInfo modu = case unpackPackageId pkg of + Nothing -> (packageIdString pkg, "") + Just x -> (display $ pkgName x, showVersion (pkgVersion x)) + where pkg = modulePackageId modu + + +-- This was removed from GHC 6.11 +-- XXX we shouldn't be using it, probably + +-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if +-- we could not parse it as such an object. +unpackPackageId :: PackageId -> Maybe PackageIdentifier +unpackPackageId p + = case [ pid | (pid,"") <- readP_to_S parse str ] of + [] -> Nothing + (pid:_) -> Just pid + where str = packageIdString p + + +lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) +lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) mod_name of + Just mod_info -> return (mi_globals (hm_iface mod_info)) + _not_a_home_module -> return Nothing + + +isNameSym :: Name -> Bool +isNameSym = isSymOcc . nameOccName + + +isVarSym :: OccName -> Bool +isVarSym = isLexVarSym . occNameFS + +isConSym :: OccName -> Bool +isConSym = isLexConSym . occNameFS + + +getMainDeclBinder :: HsDecl name -> [name] +getMainDeclBinder (TyClD d) = [tcdName d] +getMainDeclBinder (ValD d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] +getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: InstDecl name -> SrcSpan +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l +getInstLoc (TyFamInstD (TyFamInstDecl + -- Since CoAxioms' Names refer to the whole line for type family instances + -- in particular, we need to dig a bit deeper to pull out the entire + -- equation. This does not happen for data family instances, for some reason. + { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l + +-- Useful when there is a signature with multiple names, e.g. +-- foo, bar :: Types.. +-- but only one of the names is exported and we have to change the +-- type signature to only include the exported names. +filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) + +filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) +filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig +filterSigNames _ orig@(MinimalSig _) = Just orig +filterSigNames p (TypeSig ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (TypeSig filtered ty) +filterSigNames _ _ = Nothing + +ifTrueJust :: Bool -> name -> Maybe name +ifTrueJust True = Just +ifTrueJust False = const Nothing + +sigName :: LSig name -> [name] +sigName (L _ sig) = sigNameNoLoc sig + +sigNameNoLoc :: Sig name -> [name] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] +sigNameNoLoc _ = [] + + +isTyClD :: HsDecl a -> Bool +isTyClD (TyClD _) = True +isTyClD _ = False + + +isClassD :: HsDecl a -> Bool +isClassD (TyClD d) = isClassDecl d +isClassD _ = False + + +isDocD :: HsDecl a -> Bool +isDocD (DocD _) = True +isDocD _ = False + + +isInstD :: HsDecl a -> Bool +isInstD (InstD _) = True +isInstD _ = False + + +isValD :: HsDecl a -> Bool +isValD (ValD _) = True +isValD _ = False + + +declATs :: HsDecl a -> [a] +declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d +declATs _ = [] + + +pretty :: Outputable a => DynFlags -> a -> String +pretty = showPpr + + +trace_ppr :: Outputable a => DynFlags -> a -> b -> b +trace_ppr dflags x y = trace (pretty dflags x) y + + +------------------------------------------------------------------------------- +-- * Located +------------------------------------------------------------------------------- + + +unL :: Located a -> a +unL (L _ x) = x + + +reL :: a -> Located a +reL = L undefined + + +before :: Located a -> Located a -> Bool +before = (<) `on` getLoc + + +instance Foldable (GenLocated l) where + foldMap f (L _ x) = f x + + +instance Traversable (GenLocated l) where + mapM f (L l x) = (return . L l) =<< f x + traverse f (L l x) = L l <$> f x + +------------------------------------------------------------------------------- +-- * NamedThing instances +------------------------------------------------------------------------------- + + +instance NamedThing (TyClDecl Name) where + getName = tcdName + + +instance NamedThing (ConDecl Name) where + getName = unL . con_name + + +------------------------------------------------------------------------------- +-- * Subordinates +------------------------------------------------------------------------------- + + +class Parent a where + children :: a -> [Name] + + +instance Parent (ConDecl Name) where + children con = + case con_details con of + RecCon fields -> map (unL . cd_fld_name) fields + _ -> [] + + +instance Parent (TyClDecl Name) where + children d + | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d + | isClassDecl d = + map (unL . fdLName . unL) (tcdATs d) ++ + [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + | otherwise = [] + + +-- | A parent and its children +family :: (NamedThing a, Parent a) => a -> (Name, [Name]) +family = getName &&& children + + +-- | A mapping from the parent (main-binder) to its children and from each +-- child to its grand-children, recursively. +families :: TyClDecl Name -> [(Name, [Name])] +families d + | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d)) + | isClassDecl d = [family d] + | otherwise = [] + + +-- | A mapping from child to parent +parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] + + +-- | The parents of a subordinate in a declaration +parents :: Name -> HsDecl Name -> [Name] +parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents _ _ = [] + + +------------------------------------------------------------------------------- +-- * Utils that work in monads defined by GHC +------------------------------------------------------------------------------- + + +modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () +modifySessionDynFlags f = do + dflags <- getSessionDynFlags + _ <- setSessionDynFlags (f dflags) + return () + + +-- | A variant of 'gbracket' where the return value from the first computation +-- is not required. +gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c +gbracket_ before_ after thing = gbracket before_ (const after) (const thing) + +-- Extract the minimal complete definition of a Name, if one exists +minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) +minimalDef n = do + mty <- lookupGlobalName n + case mty of + Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c + _ -> return Nothing + +------------------------------------------------------------------------------- +-- * DynFlags +------------------------------------------------------------------------------- + + +setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags +setObjectDir f d = d{ objectDir = Just f} +setHiDir f d = d{ hiDir = Just f} +setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling with -fvia-C. +setOutputDir f = setObjectDir f . setHiDir f . setStubDir f + diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface.hs @@ -0,0 +1,244 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This module typechecks Haskell modules using the GHC API and processes +-- the result to create 'Interface's. The typechecking and the 'Interface' +-- creation is interleaved, so that when a module is processed, the +-- 'Interface's of all previously processed modules are available. The +-- creation of an 'Interface' from a typechecked module is delegated to +-- "Haddock.Interface.Create". +-- +-- When all modules have been typechecked and processed, information about +-- instances are attached to each 'Interface'. This task is delegated to +-- "Haddock.Interface.AttachInstances". Note that this is done as a separate +-- step because GHC can't know about all instances until all modules have been +-- typechecked. +-- +-- As a last step a link environment is built which maps names to the \"best\" +-- places to link to in the documentation, and all 'Interface's are \"renamed\" +-- using this environment. +----------------------------------------------------------------------------- +module Haddock.Interface ( + processModules +) where + + +import Haddock.GhcUtils +import Haddock.InterfaceFile +import Haddock.Interface.Create +import Haddock.Interface.AttachInstances +import Haddock.Interface.Rename +import Haddock.Options hiding (verbosity) +import Haddock.Types +import Haddock.Utils + +import Control.Monad +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Verbosity +import System.Directory +import System.FilePath +import Text.Printf + +import Digraph +import DynFlags hiding (verbosity) +import Exception +import GHC hiding (verbosity) +import HscTypes +import FastString (unpackFS) + +-- | Create 'Interface's and a link environment by typechecking the list of +-- modules using the GHC API and processing the resulting syntax trees. +processModules + :: Verbosity -- ^ Verbosity of logging to 'stdout' + -> [String] -- ^ A list of file or module names sorted by + -- module topology + -> [Flag] -- ^ Command-line flags + -> [InterfaceFile] -- ^ Interface files of package dependencies + -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming + -- environment +processModules verbosity modules flags extIfaces = do + + out verbosity verbose "Creating interfaces..." + let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces + , iface <- ifInstalledIfaces ext ] + interfaces <- createIfaces0 verbosity modules flags instIfaceMap + + let exportedNames = + Set.unions $ map (Set.fromList . ifaceExports) $ + filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces + mods = Set.fromList $ map ifaceMod interfaces + out verbosity verbose "Attaching instances..." + interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap + + out verbosity verbose "Building cross-linking environment..." + -- Combine the link envs of the external packages into one + let extLinks = Map.unions (map ifLinkEnv extIfaces) + homeLinks = buildHomeLinks interfaces -- Build the environment for the home + -- package + links = homeLinks `Map.union` extLinks + + out verbosity verbose "Renaming interfaces..." + let warnings = Flag_NoWarnings `notElem` flags + dflags <- getDynFlags + let (interfaces'', msgs) = + runWriter $ mapM (renameInterface dflags links warnings) interfaces' + liftIO $ mapM_ putStrLn msgs + + return (interfaces'', homeLinks) + + +-------------------------------------------------------------------------------- +-- * Module typechecking and Interface creation +-------------------------------------------------------------------------------- + + +createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +createIfaces0 verbosity modules flags instIfaceMap = + -- Output dir needs to be set before calling depanal since depanal uses it to + -- compute output file names that are stored in the DynFlags of the + -- resulting ModSummaries. + (if useTempDir then withTempOutputDir else id) $ do + modGraph <- depAnalysis + if needsTemplateHaskell modGraph then do + modGraph' <- enableCompilation modGraph + createIfaces verbosity flags instIfaceMap modGraph' + else + createIfaces verbosity flags instIfaceMap modGraph + + where + useTempDir :: Bool + useTempDir = Flag_NoTmpCompDir `notElem` flags + + + withTempOutputDir :: Ghc a -> Ghc a + withTempOutputDir action = do + tmp <- liftIO getTemporaryDirectory + x <- liftIO getProcessID + let dir = tmp ".haddock-" ++ show x + modifySessionDynFlags (setOutputDir dir) + withTempDir dir action + + + depAnalysis :: Ghc ModuleGraph + depAnalysis = do + targets <- mapM (\f -> guessTarget f Nothing) modules + setTargets targets + depanal [] False + + + enableCompilation :: ModuleGraph -> Ghc ModuleGraph + enableCompilation modGraph = do + let enableComp d = let platform = targetPlatform d + in d { hscTarget = defaultObjectTarget platform } + modifySessionDynFlags enableComp + -- We need to update the DynFlags of the ModSummaries as well. + let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } + let modGraph' = map upd modGraph + return modGraph' + + +createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] +createIfaces verbosity flags instIfaceMap mods = do + let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing + out verbosity normal "Haddock coverage:" + (ifaces, _) <- foldM f ([], Map.empty) sortedMods + return (reverse ifaces) + where + f (ifaces, ifaceMap) modSummary = do + x <- processModule verbosity modSummary flags ifaceMap instIfaceMap + return $ case x of + Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) + Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. + + +processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) +processModule verbosity modsum flags modMap instIfaceMap = do + out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." + tm <- loadModule =<< typecheckModule =<< parseModule modsum + if not $ isBootSummary modsum then do + out verbosity verbose "Creating interface..." + (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap + liftIO $ mapM_ putStrLn msg + dflags <- getDynFlags + let (haddockable, haddocked) = ifaceHaddockCoverage interface + percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + modString = moduleString (ifaceMod interface) + coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString + header = case ifaceDoc interface of + Documentation Nothing _ -> False + _ -> True + undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n + , expItemMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface ] + where + formatName :: SrcSpan -> HsDecl Name -> String + formatName loc n = p (getMainDeclBinder n) ++ case loc of + RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" + _ -> "" + + p [] = "" + p (x:_) = let n = pretty dflags x + ms = modString ++ "." + in if ms `isPrefixOf` n + then drop (length ms) n + else n + + out verbosity normal coverageMsg + when (Flag_PrintMissingDocs `elem` flags + && not (null undocumentedExports && header)) $ do + out verbosity normal " Missing documentation for:" + unless header $ out verbosity normal " Module header" + mapM_ (out verbosity normal . (" " ++)) undocumentedExports + interface' <- liftIO $ evaluate interface + return (Just interface') + else + return Nothing + + +-------------------------------------------------------------------------------- +-- * Building of cross-linking environment +-------------------------------------------------------------------------------- + + +-- | Build a mapping which for each original name, points to the "best" +-- place to link to in the documentation. For the definition of +-- "best", we use "the module nearest the bottom of the dependency +-- graph which exports this name", not including hidden modules. When +-- there are multiple choices, we pick a random one. +-- +-- The interfaces are passed in in topologically sorted order, but we start +-- by reversing the list so we can do a foldl. +buildHomeLinks :: [Interface] -> LinkEnv +buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) + where + upd old_env iface + | OptHide `elem` ifaceOptions iface = old_env + | OptNotHome `elem` ifaceOptions iface = + foldl' keep_old old_env exported_names + | otherwise = foldl' keep_new old_env exported_names + where + exported_names = ifaceVisibleExports iface + mdl = ifaceMod iface + keep_old env n = Map.insertWith (\_ old -> old) n mdl env + keep_new env n = Map.insert n mdl env + + +-------------------------------------------------------------------------------- +-- * Utils +-------------------------------------------------------------------------------- + + +withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir dir = gbracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP, MagicHash #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.AttachInstances +-- Copyright : (c) Simon Marlow 2006, +-- David Waern 2006-2009, +-- Isaac Dupree 2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.AttachInstances (attachInstances) where + + +import Haddock.Types +import Haddock.Convert +import Haddock.GhcUtils + +import Control.Arrow +import Data.List +import Data.Ord (comparing) +import Data.Function (on) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Class +import FamInstEnv +import FastString +import GHC +import GhcMonad (withSession) +import Id +import InstEnv +import MonadUtils (liftIO) +import Name +import PrelNames +import TcRnDriver (tcRnGetInfo) +import TcType (tcSplitSigmaTy) +import TyCon +import TypeRep +import TysPrim( funTyCon ) +import Var hiding (varName) +#define FSLIT(x) (mkFastString# (x#)) + +type ExportedNames = Set.Set Name +type Modules = Set.Set Module +type ExportInfo = (ExportedNames, Modules) + +-- Also attaches fixities +attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] +attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces + where + -- TODO: take an IfaceMap as input + ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] + + attach iface = do + newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) + (ifaceExportItems iface) + return $ iface { ifaceExportItems = newItems } + + +attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name) +attachToExportItem expInfo iface ifaceMap instIfaceMap export = + case attachFixities export of + e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do + mb_info <- getAllInfo (tcdName d) + let export' = + e { + expItemInstances = + case mb_info of + Just (_, _, cls_instances, fam_instances) -> + let fam_insts = [ (synifyFamInst i opaque, n) + | i <- sortBy (comparing instFam) fam_instances + , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap + , not $ isNameHidden expInfo (fi_fam i) + , not $ any (isTypeHidden expInfo) (fi_tys i) + , let opaque = isTypeHidden expInfo (fi_rhs i) + ] + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) + | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] + in cls_insts ++ fam_insts + Nothing -> [] + } + return export' + e -> return e + where + attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = + nubBy ((==) `on` fst) $ expItemFixities e ++ + [ (n',f) | n <- getMainDeclBinder d + , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap] + , n' <- n : subs + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + ] } + + attachFixities e = e + + +instLookup :: (InstalledInterface -> Map.Map Name a) -> Name + -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a +instLookup f name iface ifaceMap instIfaceMap = + case Map.lookup name (f $ toInstalledIface iface) of + res@(Just _) -> res + Nothing -> do + let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap + iface' <- Map.lookup (nameModule name) ifaceMaps + Map.lookup name (f iface') + +-- | Like GHC's 'instanceHead' but drops "silent" arguments. +instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) +instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) + where + dfun = is_dfun ispec + (tvs, cls, tys) = instanceHead ispec + (_, theta, _) = tcSplitSigmaTy (idType dfun) + +-- | Drop "silent" arguments. See GHC Note [Silent superclass +-- arguments]. +dropSilentArgs :: DFunId -> ThetaType -> ThetaType +dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta + + +-- | Like GHC's getInfo but doesn't cut things out depending on the +-- interative context, which we don't set sufficiently anyway. +getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) +getAllInfo name = withSession $ \hsc_env -> do + (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name + return r + + +-------------------------------------------------------------------------------- +-- Collecting and sorting instances +-------------------------------------------------------------------------------- + + +-- | Simplified type for sorting types, ignoring qualification (not visible +-- in Haddock output) and unifying special tycons with normal ones. +-- For the benefit of the user (looks nice and predictable) and the +-- tests (which prefer output to be deterministic). +data SimpleType = SimpleType Name [SimpleType] + | SimpleTyLit TyLit + deriving (Eq,Ord) + + +instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) +instHead (_, _, cls, args) + = (map argCount args, className cls, map simplify args) + +argCount :: Type -> Int +argCount (AppTy t _) = argCount t + 1 +argCount (TyConApp _ ts) = length ts +argCount (FunTy _ _ ) = 2 +argCount (ForAllTy _ t) = argCount t +argCount _ = 0 + +simplify :: Type -> SimpleType +simplify (ForAllTy _ t) = simplify t +simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) + where (SimpleType s ts) = simplify t1 +simplify (TyVarTy v) = SimpleType (tyVarName v) [] +simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (LitTy l) = SimpleTyLit l + +-- Used for sorting +instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) +instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } + = (map argCount ts, n, map simplify ts, argCount t, simplify t) + + +funTyConName :: Name +funTyConName = mkWiredInName gHC_PRIM + (mkOccNameFS tcName FSLIT("(->)")) + funTyConKey + (ATyCon funTyCon) -- Relevant TyCon + BuiltInSyntax + +-------------------------------------------------------------------------------- +-- Filtering hidden instances +-------------------------------------------------------------------------------- + +-- | A class or data type is hidden iff +-- +-- * it is defined in one of the modules that are being processed +-- +-- * and it is not exported by any non-hidden module +isNameHidden :: ExportInfo -> Name -> Bool +isNameHidden (names, modules) name = + nameModule name `Set.member` modules && + not (name `Set.member` names) + +-- | We say that an instance is «hidden» iff its class or any (part) +-- of its type(s) is hidden. +isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool +isInstanceHidden expInfo cls tys = + instClassHidden || instTypeHidden + where + instClassHidden :: Bool + instClassHidden = isNameHidden expInfo $ getName cls + + instTypeHidden :: Bool + instTypeHidden = any (isTypeHidden expInfo) tys + +isTypeHidden :: ExportInfo -> Type -> Bool +isTypeHidden expInfo = typeHidden + where + typeHidden :: Type -> Bool + typeHidden t = + case t of + TyVarTy {} -> False + AppTy t1 t2 -> typeHidden t1 || typeHidden t2 + TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args + FunTy t1 t2 -> typeHidden t1 || typeHidden t2 + ForAllTy _ ty -> typeHidden ty + LitTy _ -> False + + nameHidden :: Name -> Bool + nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# OPTIONS_GHC -Wwarn #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Create +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.Create (createInterface) where + +import Documentation.Haddock.Doc (docAppend) +import Haddock.Types +import Haddock.Options +import Haddock.GhcUtils +import Haddock.Utils +import Haddock.Convert +import Haddock.Interface.LexParseRn + +import qualified Data.Map as M +import Data.Map (Map) +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Control.Applicative +import Control.Arrow (second) +import Control.DeepSeq +import Control.Monad +import Data.Function (on) +import qualified Data.Foldable as F + +import qualified Packages +import qualified Module +import qualified SrcLoc +import GHC +import HscTypes +import Name +import Bag +import RdrName +import TcRnTypes +import FastString (concatFS) + + +-- | Use a 'TypecheckedModule' to produce an 'Interface'. +-- To do this, we need access to already processed modules in the topological +-- sort. That's what's in the 'IfaceMap'. +createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface +createInterface tm flags modMap instIfaceMap = do + + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + L _ hsm = parsedSource tm + !safety = modInfoSafe mi + mdl = ms_mod ms + dflags = ms_hspp_opts ms + !instances = modInfoInstances mi + !fam_instances = md_fam_insts md + !exportedNames = modInfoExports mi + + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm + + -- The renamed source should always be available to us, but it's best + -- to be on the safe side. + (group_, mayExports, mayDocHeader) <- + case renamedSource tm of + Nothing -> do + liftErrMsg $ tell [ "Warning: Renamed source is not available." ] + return (emptyRnGroup, Nothing, Nothing) + Just (x, _, y, z) -> return (x, y, z) + + opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl + let opts + | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 + | otherwise = opts0 + + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader + + let declsWithDocs = topDecls group_ + fixMap = mkFixMap group_ + (decls, _) = unzip declsWithDocs + localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances + ++ map getName fam_instances + -- Locations of all TH splices + splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + + maps@(!docMap, !argMap, !subMap, !declMap, _) = + mkMaps dflags gre localInsts declsWithDocs + + let exports0 = fmap (reverse . map unLoc) mayExports + exports + | OptIgnoreExports `elem` opts = Nothing + | otherwise = exports0 + warningMap = mkWarningMap dflags warnings gre exportedNames + + let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) + + exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls + maps fixMap splices exports instIfaceMap dflags + + let !visibleNames = mkVisibleNames maps exportItems opts + + -- Measure haddock documentation coverage. + let prunedExportItems0 = pruneExportItems exportItems + !haddockable = 1 + length exportItems -- module + exports + !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + !coverage = (haddockable, haddocked) + + -- Prune the export list to just those declarations that have + -- documentation, if the 'prune' option is on. + let prunedExportItems' + | OptPrune `elem` opts = prunedExportItems0 + | otherwise = exportItems + !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' + + let !aliases = + mkAliasMap dflags $ tm_renamed_source tm + modWarn = moduleWarning dflags gre warnings + + return $! Interface { + ifaceMod = mdl + , ifaceOrigFilename = msHsFilePath ms + , ifaceInfo = info + , ifaceDoc = Documentation mbDoc modWarn + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = opts + , ifaceDocMap = docMap + , ifaceArgMap = argMap + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = prunedExportItems + , ifaceRnExportItems = [] + , ifaceExports = exportedNames + , ifaceVisibleExports = visibleNames + , ifaceDeclMap = declMap + , ifaceSubMap = subMap + , ifaceFixMap = fixMap + , ifaceModuleAliases = aliases + , ifaceInstances = instances + , ifaceFamInstances = fam_instances + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap + } + +mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap dflags mRenamedSource = + case mRenamedSource of + Nothing -> M.empty + Just (_,impDecls,_,_) -> + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + alias <- ideclAs impDecl + return $ + (lookupModuleDyn dflags + (fmap Module.fsToPackageId $ + ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls + +-- similar to GHC.lookupModule +lookupModuleDyn :: + DynFlags -> Maybe PackageId -> ModuleName -> Module +lookupModuleDyn _ (Just pkgId) mdlName = + Module.mkModule pkgId mdlName +lookupModuleDyn dflags Nothing mdlName = + flip Module.mkModule mdlName $ + case filter snd $ + Packages.lookupModuleInAllPackages dflags mdlName of + (pkgId,_):_ -> Packages.packageConfigId pkgId + [] -> Module.mainPackageId + + +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap dflags warnings gre exps = case warnings of + NoWarnings -> M.empty + WarnAll _ -> M.empty + WarnSome ws -> + let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] + in M.fromList $ map (second $ parseWarning dflags gre) ws' + +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) +moduleWarning _ _ NoWarnings = Nothing +moduleWarning _ _ (WarnSome _) = Nothing +moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w + +parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name +parseWarning dflags gre w = force $ case w of + DeprecatedTxt msg -> format "Deprecated: " (concatFS msg) + WarningTxt msg -> format "Warning: " (concatFS msg) + where + format x xs = DocWarning . DocParagraph . DocAppend (DocString x) + . processDocString dflags gre $ HsDocString xs + + +------------------------------------------------------------------------------- +-- Doc options +-- +-- Haddock options that are embedded in the source file +------------------------------------------------------------------------------- + + +mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] +mkDocOpts mbOpts flags mdl = do + opts <- case mbOpts of + Just opts -> case words $ replace ',' ' ' opts of + [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] + xs -> liftM catMaybes (mapM parseOption xs) + Nothing -> return [] + hm <- if Flag_HideModule (moduleString mdl) `elem` flags + then return $ OptHide : opts + else return opts + if Flag_ShowExtensions (moduleString mdl) `elem` flags + then return $ OptShowExtensions : hm + else return hm + + +parseOption :: String -> ErrMsgM (Maybe DocOption) +parseOption "hide" = return (Just OptHide) +parseOption "prune" = return (Just OptPrune) +parseOption "ignore-exports" = return (Just OptIgnoreExports) +parseOption "not-home" = return (Just OptNotHome) +parseOption "show-extensions" = return (Just OptShowExtensions) +parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing + + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + + +type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) + +-- | Create 'Maps' by looping through the declarations. For each declaration, +-- find its names, its subordinates, and its doc strings. Process doc strings +-- into 'Doc's. +mkMaps :: DynFlags + -> GlobalRdrEnv + -> [Name] + -> [(LHsDecl Name, [HsDocString])] + -> Maps +mkMaps dflags gre instances decls = + let (a, b, c, d) = unzip4 $ map mappings decls + in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) + where + f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name) + f' = M.fromListWith docAppend . concat + + mappings :: (LHsDecl Name, [HsDocString]) + -> ( [(Name, Doc Name)] + , [(Name, Map Int (Doc Name))] + , [(Name, [Name])] + , [(Name, [LHsDecl Name])] + ) + mappings (ldecl, docStrs) = + let L l decl = ldecl + declDoc :: [HsDocString] -> Map Int HsDocString + -> (Maybe (Doc Name), Map Int (Doc Name)) + declDoc strs m = + let doc' = processDocStrings dflags gre strs + m' = M.map (processDocStringParas dflags gre) m + in (doc', m') + (doc, args) = declDoc docStrs (typeDocs decl) + subs :: [(Name, [HsDocString], Map Int HsDocString)] + subs = subordinates instanceMap decl + (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] + am = [ (n, args) | n <- ns ] ++ zip subNs subArgs + sm = [ (n, subNs) | n <- ns ] + cm = [ (n, [ldecl]) | n <- ns ++ subNs ] + in seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + (dm, am, sm, cm) + + instanceMap :: Map SrcSpan Name + instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] + + names :: SrcSpan -> HsDecl Name -> [Name] + names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + where loc = case d of + TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs + _ -> getInstLoc d + names _ decl = getMainDeclBinder decl + +-- Note [2]: +------------ +-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. +-- That should work for normal user-written instances (from looking at GHC +-- sources). We can assume that commented instances are user-written. +-- This lets us relate Names (from ClsInsts) to comments (associated +-- with InstDecls). + + +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + + +-- | Get all subordinate declarations inside a declaration, and their docs. +subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates instMap decl = case decl of + InstD (ClsInstD d) -> do + DataFamInstDecl { dfid_tycon = L l _ + , dfid_defn = def } <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def + + InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + TyClD d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + dataSubs dd = constrs ++ fields + where + cons = map unL $ (dd_cons dd) + constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) + | c <- cons ] + fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map con_details cons + , ConDeclField n _ doc <- flds ] + +-- | Extract function argument docs from inside types. +typeDocs :: HsDecl Name -> Map Int HsDocString +typeDocs d = + let docs = go 0 in + case d of + SigD (TypeSig _ ty) -> docs (unLoc ty) + SigD (PatSynSig _ arg_tys ty req prov) -> + let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] + in F.foldMap (docs . unLoc) allTys + ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) + TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) + _ -> M.empty + where + go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) + go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ (L _ doc)) = M.singleton n doc + go _ _ = M.empty + + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls + where + decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls tcdDocs DocD class_ +#if MIN_VERSION_ghc(7,8,3) + defs = mkDecls (bagToList . tcdMeths) ValD class_ +#else + defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_ +#endif + sigs = mkDecls tcdSigs SigD class_ + ats = mkDecls tcdATs (TyClD . FamDecl) class_ + + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup + +-- | Extract a map of fixity declarations only +mkFixMap :: HsGroup Name -> FixMap +mkFixMap group_ = M.fromList [ (n,f) + | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ] + + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup Name -> [LHsDecl Name] +ungroup group_ = + mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ + mkDecls hs_derivds DerivD group_ ++ + mkDecls hs_defds DefD group_ ++ + mkDecls hs_fords ForD group_ ++ + mkDecls hs_docs DocD group_ ++ + mkDecls hs_instds InstD group_ ++ + mkDecls (typesigs . hs_valds) SigD group_ ++ +#if MIN_VERSION_ghc(7,8,3) + mkDecls (valbinds . hs_valds) ValD group_ +#else + mkDecls (map snd . valbinds . hs_valds) ValD group_ +#endif + where + typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs + typesigs _ = error "expected ValBindsOut" + + valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds _ = error "expected ValBindsOut" + + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] +mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] + + +-- | Sort by source location +sortByLoc :: [Located a] -> [Located a] +sortByLoc = sortBy (comparing getLoc) + + +-------------------------------------------------------------------------------- +-- Filtering of declarations +-- +-- We filter out declarations that we don't intend to handle later. +-------------------------------------------------------------------------------- + + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unL . fst) + where + isHandled (ForD (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (ValD _) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD _) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x + | x@(L loc d, doc) <- decls ] + where + filterClass (TyClD c) = + TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + filterClass _ = error "expected TyClD" + + +-------------------------------------------------------------------------------- +-- Collect docs +-- +-- To be able to attach the right Haddock comment to the right declaration, +-- we sort the declarations by their SrcLoc and "collect" the docs for each +-- declaration. +-------------------------------------------------------------------------------- + + +-- | Collect docs and attach them to the right declarations. +collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] +collectDocs = go Nothing [] + where + go Nothing _ [] = [] + go (Just prev) docs [] = finished prev docs [] + go prev docs (L _ (DocD (DocCommentNext str)) : ds) + | Nothing <- prev = go Nothing (str:docs) ds + | Just decl <- prev = finished decl docs (go Nothing [str] ds) + go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go Nothing docs (d:ds) = go (Just d) docs ds + go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) + + finished decl docs rest = (decl, reverse docs) : rest + + +-- | Build the list of items that will become the documentation, from the +-- export list. At this point, the list of ExportItems is in terms of +-- original names. +-- +-- We create the export items even if the module is hidden, since they +-- might be useful when creating the export items for other modules. +mkExportItems + :: IfaceMap + -> Module -- this module + -> WarningMap + -> GlobalRdrEnv + -> [Name] -- exported names (orig) + -> [LHsDecl Name] + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> Maybe [IE Name] + -> InstIfaceMap + -> DynFlags + -> ErrMsgGhc [ExportItem Name] +mkExportItems + modMap thisMod warnings gre exportedNames decls + maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = + case optExports of + Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls + Just exports -> liftM concat $ mapM lookupExport exports + where + lookupExport (IEVar x) = declWith x + lookupExport (IEThingAbs t) = declWith t + lookupExport (IEThingAll t) = declWith t + lookupExport (IEThingWith t _) = declWith t + lookupExport (IEModuleContents m) = + moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices + lookupExport (IEGroup lev docStr) = return $ + return . ExportGroup lev "" $ processDocString dflags gre docStr + + lookupExport (IEDoc docStr) = return $ + return . ExportDoc $ processDocStringParas dflags gre docStr + + lookupExport (IEDocNamed str) = liftErrMsg $ + findNamedDoc str [ unL d | d <- decls ] >>= return . \case + Nothing -> [] + Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + + declWith :: Name -> ErrMsgGhc [ ExportItem Name ] + declWith t = + case findDecl t of + ([L l (ValD _)], (doc, _)) -> do + -- Top-level binding without type signature + export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + return [export] + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> + let declNames = getMainDeclBinder (unL decl) + in case () of + _ + -- temp hack: we filter out separately exported ATs, since we haven't decided how + -- to handle them yet. We should really give an warning message also, and filter the + -- name out in mkVisibleNames... + | t `elem` declATs (unL decl) -> return [] + + -- We should not show a subordinate by itself if any of its + -- parents is also exported. See note [1]. + | t `notElem` declNames, + Just p <- find isExported (parents t $ unL decl) -> + do liftErrMsg $ tell [ + "Warning: " ++ moduleString thisMod ++ ": " ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ + ". Consider exporting it together with its parent(s)" ++ + " for code clarity." ] + return [] + + -- normal case + | otherwise -> case decl of + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. + L loc (SigD sig) -> + -- fromJust is safe since we already checked in guards + -- that 't' is a name declared in this declaration. + let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig + in return [ mkExportDecl t newDecl docs_ ] + + L loc (TyClD cl@ClassDecl{}) -> do + mdef <- liftGhcToErrMsgGhc $ minimalDef t + let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + return [ mkExportDecl t + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] + + _ -> return [ mkExportDecl t decl docs_ ] + + -- Declaration from another package + ([], _) -> do + mayDecl <- hiDecl dflags t + case mayDecl of + Nothing -> return [ ExportNoDecl t [] ] + Just decl -> + -- We try to get the subs and docs + -- from the installed .haddock file for that package. + case M.lookup (nameModule t) instIfaceMap of + Nothing -> do + liftErrMsg $ tell + ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] + let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] + return [ mkExportDecl t decl (noDocForDecl, subs_) ] + Just iface -> + return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + + _ -> return [] + + + mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name + mkExportDecl name decl (doc, subs) = decl' + where + decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False + mdl = nameModule name + subs' = filter (isExported . fst) subs + sub_names = map fst subs' + fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] + + + isExported = (`elem` exportedNames) + + + findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl n + | m == thisMod, Just ds <- M.lookup n declMap = + (ds, lookupDocs n warnings docMap argMap subMap) + | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + | otherwise = ([], (noDocForDecl, [])) + where + m = nameModule n + + +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl dflags t = do + mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + case mayTyThing of + Nothing -> do + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] + return Nothing + Just x -> return (Just (tyThingToLHsDecl x)) + + +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc splice fixity = do + mayDecl <- hiDecl dflags name + case mayDecl of + Nothing -> return (ExportNoDecl name []) + Just decl -> return (ExportDecl decl doc [] [] fixities splice) + where + fixities = case fixity of + Just f -> [(name, f)] + Nothing -> [] + + +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings docMap argMap subMap = + let lookupArgDoc x = M.findWithDefault M.empty x argMap in + let doc = (lookupDoc n, lookupArgDoc n) in + let subs = M.findWithDefault [] n subMap in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + (doc, subDocs) + where + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) + + +-- | Return all export items produced by an exported module. That is, we're +-- interested in the exports produced by \"module B\" in such a scenario: +-- +-- > module A (module B) where +-- > import B (...) hiding (...) +-- +-- There are three different cases to consider: +-- +-- 1) B is hidden, in which case we return all its exports that are in scope in A. +-- 2) B is visible, but not all its exports are in scope in A, in which case we +-- only return those that are. +-- 3) B is visible and all its exports are in scope, in which case we return +-- a single 'ExportModule' item. +moduleExports :: Module -- ^ Module A + -> ModuleName -- ^ The real name of B, the exported module + -> DynFlags -- ^ The flags used when typechecking A + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment used for A + -> [Name] -- ^ All the exports of A + -> [LHsDecl Name] -- ^ All the declarations in A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> Maps + -> FixMap + -> [SrcSpan] -- ^ Locations of all TH splices + -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices + | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls + | otherwise = + case M.lookup m ifaceMap of + Just iface + | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) + | otherwise -> return [ ExportModule m ] + + Nothing -> -- We have to try to find it in the installed interfaces + -- (external packages). + case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + liftErrMsg $ + tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] + return [] + where + m = mkModule packageId expMod + packageId = modulePackageId thisMod + + +-- Note [1]: +------------ +-- It is unnecessary to document a subordinate by itself at the top level if +-- any of its parents is also documented. Furthermore, if the subordinate is a +-- record field or a class method, documenting it under its parent +-- indicates its special status. +-- +-- A user might expect that it should show up separately, so we issue a +-- warning. It's a fine opportunity to also tell the user she might want to +-- export the subordinate through the parent export item for clarity. +-- +-- The code removes top-level subordinates also when the parent is exported +-- through a 'module' export. I think that is fine. +-- +-- (For more information, see Trac #69) + + +fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] + -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = + liftM catMaybes $ mapM mkExportItem (expandSig decls) + where + -- A type signature can have multiple names, like: + -- foo, bar :: Types.. + -- + -- We go through the list of declarations and expand type signatures, so + -- that every type signature has exactly one name! + expandSig :: [LHsDecl name] -> [LHsDecl name] + expandSig = foldr f [] + where + f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f x xs = x : xs + + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) + mkExportItem (L _ (DocD (DocGroup lev docStr))) = do + return . Just . ExportGroup lev "" $ processDocString dflags gre docStr + mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do + return . Just . ExportDoc $ processDocStringParas dflags gre docStr + mkExportItem (L l (ValD d)) + | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = + -- Top-level binding without type signature. + let (doc, _) = lookupDocs name warnings docMap argMap subMap in + fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) + | otherwise = return Nothing + mkExportItem decl@(L l (InstD d)) + | Just name <- M.lookup (getInstLoc d) instMap = + let (doc, subs) = lookupDocs name warnings docMap argMap subMap in + return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do + mdef <- liftGhcToErrMsgGhc $ minimalDef name + let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name + mkExportItem decl@(L l d) + | name:_ <- getMainDeclBinder d = expDecl decl l name + | otherwise = return Nothing + + fixities name subs = [ (n,f) | n <- name : map fst subs + , Just f <- [M.lookup n fixMap] ] + + expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + where (doc, subs) = lookupDocs name warnings docMap argMap subMap + + +-- | Sometimes the declaration we want to export is not the "main" declaration: +-- it might be an individual record selector or a class method. In these +-- cases we have to extract the required declaration (and somehow cobble +-- together a type signature for it...). +extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name +extractDecl name mdl decl + | name `elem` getMainDeclBinder (unLoc decl) = decl + | otherwise = + case unLoc decl of + TyClD d@ClassDecl {} -> + let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, + isVanillaLSig sig ] -- TODO: document fixity + in case matches of + [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) + L pos sig = extractClassDecl n tyvar_names s0 + in L pos (SigD sig) + _ -> error "internal: extractDecl (ClassDecl)" + TyClD d@DataDecl {} -> + let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) + in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n + , dfid_pats = HsWB { hswb_cts = tys } + , dfid_defn = defn }) -> + SigD <$> extractRecSel name mdl n tys (dd_cons defn) + InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> + let matches = [ d | L _ d <- insts + , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) + , ConDeclField { cd_fld_name = L _ n } <- rec + , n == name + ] + in case matches of + [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) + _ -> error "internal: extractDecl (ClsInstD)" + _ -> error "internal: extractDecl" + where + getTyVars = hsLTyVarLocNames . tyClDeclTyVars + + +toTypeNoLoc :: Located Name -> LHsType Name +toTypeNoLoc = noLoc . HsTyVar . unLoc + + +extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name +extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of + L _ (HsForAllTy expl tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) + where + lctxt = noLoc . ctxt + ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds +extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" + + +extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] + -> LSig Name +extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" + +extractRecSel nm mdl t tvs (L _ con : rest) = + case con_details con of + RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> + L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) + _ -> extractRecSel nm mdl t tvs rest + where + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] + data_ty + | ResTyGADT ty <- con_res con = ty + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + + +-- | Keep export items with docs. +pruneExportItems :: [ExportItem Name] -> [ExportItem Name] +pruneExportItems = filter hasDoc + where + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d + hasDoc _ = True + + +mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, _, instMap) exports opts + | OptHide `elem` opts = [] + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns + where + exportName e@ExportDecl {} = name ++ subs + where subs = map fst (expItemSubDocs e) + name = case unLoc $ expItemDecl e of + InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl + exportName ExportNoDecl {} = [] -- we don't count these as visible, since + -- we don't want links to go to them. + exportName _ = [] + +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs + +-- | Find a stand-alone documentation comment by its name. +findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc name = search + where + search [] = do + tell ["Cannot find documentation for: $" ++ name] + return Nothing + search (DocD (DocCommentNamed name' doc) : rest) + | name == name' = return (Just doc) + | otherwise = search rest + search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -0,0 +1,146 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE BangPatterns #-} + ----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.LexParseRn +-- Copyright : (c) Isaac Dupree 2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.LexParseRn + ( processDocString + , processDocStringParas + , processDocStrings + , processModuleHeader + ) where + +import Control.Applicative +import Data.IntSet (toList) +import Data.List +import Documentation.Haddock.Doc (docConcat) +import DynFlags (ExtensionFlag(..), languageExtensions) +import FastString +import GHC +import Haddock.Interface.ParseModuleHeader +import Haddock.Parser +import Haddock.Types +import Name +import Outputable (showPpr) +import RdrName + +processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name) +processDocStrings dflags gre strs = + case docConcat $ map (processDocStringParas dflags gre) strs of + DocEmpty -> Nothing + x -> Just x + + +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocStringParas = process parseParas + + +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocString = process parseString + +process :: (DynFlags -> String -> Doc RdrName) + -> DynFlags + -> GlobalRdrEnv + -> HsDocString + -> Doc Name +process parse dflags gre (HsDocString fs) = + rename dflags gre $ parse dflags (unpackFS fs) + + +processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString + -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +processModuleHeader dflags gre safety mayStr = do + (hmi, doc) <- + case mayStr of + Nothing -> return failure + Just (L _ (HsDocString fs)) -> do + let str = unpackFS fs + (hmi, doc) = parseModuleHeader dflags str + !descr = rename dflags gre <$> hmi_description hmi + hmi' = hmi { hmi_description = descr } + doc' = rename dflags gre doc + return (hmi', Just doc') + + let flags :: [ExtensionFlag] + -- We remove the flags implied by the language setting and we display the language instead + flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) + return (hmi { hmi_safety = Just $ showPpr dflags safety + , hmi_language = language dflags + , hmi_extensions = flags + } , doc) + where + failure = (emptyHaddockModInfo, Nothing) + + +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename dflags gre = rn + where + rn d = case d of + DocAppend a b -> DocAppend (rn a) (rn b) + DocParagraph doc -> DocParagraph (rn doc) + DocIdentifier x -> do + let choices = dataTcOccs' x + let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + case names of + [] -> + case choices of + [] -> DocMonospaced (DocString (showPpr dflags x)) + [a] -> outOfScope dflags a + a:b:_ | isRdrTc a -> outOfScope dflags a + | otherwise -> outOfScope dflags b + [a] -> DocIdentifier a + a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b + -- If an id can refer to multiple things, we give precedence to type + -- constructors. + + DocWarning doc -> DocWarning (rn doc) + DocEmphasis doc -> DocEmphasis (rn doc) + DocBold doc -> DocBold (rn doc) + DocMonospaced doc -> DocMonospaced (rn doc) + DocUnorderedList docs -> DocUnorderedList (map rn docs) + DocOrderedList docs -> DocOrderedList (map rn docs) + DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] + DocCodeBlock doc -> DocCodeBlock (rn doc) + DocIdentifierUnchecked x -> DocIdentifierUnchecked x + DocModule str -> DocModule str + DocHyperlink l -> DocHyperlink l + DocPic str -> DocPic str + DocAName str -> DocAName str + DocProperty p -> DocProperty p + DocExamples e -> DocExamples e + DocEmpty -> DocEmpty + DocString str -> DocString str + DocHeader (Header l t) -> DocHeader $ Header l (rn t) + +dataTcOccs' :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +-- +-- We use this definition instead of the GHC's to provide proper linking to +-- functions accross modules. See ticket #253 on Haddock Trac. +dataTcOccs' rdr_name + | isDataOcc occ = [rdr_name, rdr_name_tc] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + + +outOfScope :: DynFlags -> RdrName -> Doc a +outOfScope dflags x = + case x of + Unqual occ -> monospaced occ + Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) + Orig _ occ -> monospaced occ + Exact name -> monospaced name -- Shouldn't happen since x is out of scope + where + monospaced a = DocMonospaced (DocString (showPpr dflags a)) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -0,0 +1,150 @@ +{-# OPTIONS_GHC -Wwarn #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.ParseModuleHeader +-- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where + +import Control.Applicative ((<$>)) +import Control.Monad (mplus) +import Data.Char +import DynFlags +import Haddock.Parser +import Haddock.Types +import RdrName + +-- ----------------------------------------------------------------------------- +-- Parsing module headers + +-- NB. The headers must be given in the order Module, Description, +-- Copyright, License, Maintainer, Stability, Portability, except that +-- any or all may be omitted. +parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName) +parseModuleHeader dflags str0 = + let + getKey :: String -> String -> (Maybe String,String) + getKey key str = case parseKey key str of + Nothing -> (Nothing,str) + Just (value,rest) -> (Just value,rest) + + (_moduleOpt,str1) = getKey "Module" str0 + (descriptionOpt,str2) = getKey "Description" str1 + (copyrightOpt,str3) = getKey "Copyright" str2 + (licenseOpt,str4) = getKey "License" str3 + (licenceOpt,str5) = getKey "Licence" str4 + (maintainerOpt,str6) = getKey "Maintainer" str5 + (stabilityOpt,str7) = getKey "Stability" str6 + (portabilityOpt,str8) = getKey "Portability" str7 + + in (HaddockModInfo { + hmi_description = parseString dflags <$> descriptionOpt, + hmi_copyright = copyrightOpt, + hmi_license = licenseOpt `mplus` licenceOpt, + hmi_maintainer = maintainerOpt, + hmi_stability = stabilityOpt, + hmi_portability = portabilityOpt, + hmi_safety = Nothing, + hmi_language = Nothing, -- set in LexParseRn + hmi_extensions = [] -- also set in LexParseRn + }, parseParas dflags str8) + +-- | This function is how we read keys. +-- +-- all fields in the header are optional and have the form +-- +-- [spaces1][field name][spaces] ":" +-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* +-- where each [spaces2] should have [spaces1] as a prefix. +-- +-- Thus for the key "Description", +-- +-- > Description : this is a +-- > rather long +-- > +-- > description +-- > +-- > The module comment starts here +-- +-- the value will be "this is a .. description" and the rest will begin +-- at "The module comment". +parseKey :: String -> String -> Maybe (String,String) +parseKey key toParse0 = + do + let + (spaces0,toParse1) = extractLeadingSpaces toParse0 + + indentation = spaces0 + afterKey0 <- extractPrefix key toParse1 + let + afterKey1 = extractLeadingSpaces afterKey0 + afterColon0 <- case snd afterKey1 of + ':':afterColon -> return afterColon + _ -> Nothing + let + (_,afterColon1) = extractLeadingSpaces afterColon0 + + return (scanKey True indentation afterColon1) + where + scanKey :: Bool -> String -> String -> (String,String) + scanKey _ _ [] = ([],[]) + scanKey isFirst indentation str = + let + (nextLine,rest1) = extractNextLine str + + accept = isFirst || sufficientIndentation || allSpaces + + sufficientIndentation = case extractPrefix indentation nextLine of + Just (c:_) | isSpace c -> True + _ -> False + + allSpaces = case extractLeadingSpaces nextLine of + (_,[]) -> True + _ -> False + in + if accept + then + let + (scanned1,rest2) = scanKey False indentation rest1 + + scanned2 = case scanned1 of + "" -> if allSpaces then "" else nextLine + _ -> nextLine ++ "\n" ++ scanned1 + in + (scanned2,rest2) + else + ([],str) + + extractLeadingSpaces :: String -> (String,String) + extractLeadingSpaces [] = ([],[]) + extractLeadingSpaces (s@(c:cs)) + | isSpace c = + let + (spaces1,cs1) = extractLeadingSpaces cs + in + (c:spaces1,cs1) + | otherwise = ([],s) + + extractNextLine :: String -> (String,String) + extractNextLine [] = ([],[]) + extractNextLine (c:cs) + | c == '\n' = + ([],cs) + | otherwise = + let + (line,rest) = extractNextLine cs + in + (c:line,rest) + + -- comparison is case-insensitive. + extractPrefix :: String -> String -> Maybe String + extractPrefix [] s = Just s + extractPrefix _ [] = Nothing + extractPrefix (c1:cs1) (c2:cs2) + | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 + | otherwise = Nothing diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -0,0 +1,506 @@ +---------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Rename +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.Rename (renameInterface) where + + +import Data.Traversable (traverse) + +import Haddock.GhcUtils +import Haddock.Types + +import Bag (emptyBag) +import GHC hiding (NoLink) +import Name + +import Control.Applicative +import Control.Monad hiding (mapM) +import Data.List +import qualified Data.Map as Map hiding ( Map ) +import Data.Traversable (mapM) +import Prelude hiding (mapM) + + +renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface dflags renamingEnv warnings iface = + + -- first create the local env, where every name exported by this module + -- is mapped to itself, and everything else comes from the global renaming + -- env + let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) + where fn env name = Map.insert name (ifaceMod iface) env + + -- rename names in the exported declarations to point to things that + -- are closer to, or maybe even exported by, the current module. + (renamedExportItems, missingNames1) + = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) + + (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) + + (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) + + (finalModuleDoc, missingNames4) + = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) + + -- combine the missing names and filter out the built-ins, which would + -- otherwise allways be missing. + missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much + (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) + + -- filter out certain built in type constructors using their string + -- representation. TODO: use the Name constants from the GHC API. +-- strings = filter (`notElem` ["()", "[]", "(->)"]) +-- (map pretty missingNames) + strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + + in do + -- report things that we couldn't link to. Only do this for non-hidden + -- modules. + unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ + tell ["Warning: " ++ moduleString (ifaceMod iface) ++ + ": could not find link destinations for:\n"++ + unwords (" " : strings) ] + + return $ iface { ifaceRnDoc = finalModuleDoc, + ifaceRnDocMap = rnDocMap, + ifaceRnArgMap = rnArgMap, + ifaceRnExportItems = renamedExportItems } + + +-------------------------------------------------------------------------------- +-- Monad for renaming +-- +-- The monad does two things for us: it passes around the environment for +-- renaming, and it returns a list of names which couldn't be found in +-- the environment. +-------------------------------------------------------------------------------- + + +newtype RnM a = + RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function + -> (a,[Name]) + } + +instance Monad RnM where + (>>=) = thenRn + return = returnRn + +instance Functor RnM where + fmap f x = do a <- x; return (f a) + +instance Applicative RnM where + pure = return + (<*>) = ap + +returnRn :: a -> RnM a +returnRn a = RnM (const (a,[])) +thenRn :: RnM a -> (a -> RnM b) -> RnM b +m `thenRn` k = RnM (\lkp -> case unRn m lkp of + (a,out1) -> case unRn (k a) lkp of + (b,out2) -> (b,out1++out2)) + +getLookupRn :: RnM (Name -> (Bool, DocName)) +getLookupRn = RnM (\lkp -> (lkp,[])) + +outRn :: Name -> RnM () +outRn name = RnM (const ((),[name])) + +lookupRn :: Name -> RnM DocName +lookupRn name = do + lkp <- getLookupRn + case lkp name of + (False,maps_to) -> do outRn name; return maps_to + (True, maps_to) -> return maps_to + + +runRnFM :: LinkEnv -> RnM a -> (a,[Name]) +runRnFM env rn = unRn rn lkp + where + lkp n = case Map.lookup n env of + Nothing -> (False, Undocumented n) + Just mdl -> (True, Documented n mdl) + + +-------------------------------------------------------------------------------- +-- Renaming +-------------------------------------------------------------------------------- + + +rename :: Name -> RnM DocName +rename = lookupRn + + +renameL :: Located Name -> RnM (Located DocName) +renameL = mapM rename + + +renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] +renameExportItems = mapM renameExportItem + + +renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) +renameDocForDecl (doc, fnArgsDoc) = + (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc + + +renameDocumentation :: Documentation Name -> RnM (Documentation DocName) +renameDocumentation (Documentation mDoc mWarning) = + Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning + + +renameLDocHsSyn :: LHsDocString -> RnM LHsDocString +renameLDocHsSyn = return + + +renameDoc :: Doc Name -> RnM (Doc DocName) +renameDoc = traverse rename + + +renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) +renameFnArgsDoc = mapM renameDoc + + +renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType = mapM renameType + +renameLKind :: LHsKind Name -> RnM (LHsKind DocName) +renameLKind = renameLType + +renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind = traverse renameLKind + +renameType :: HsType Name -> RnM (HsType DocName) +renameType t = case t of + HsForAllTy expl tyvars lcontext ltype -> do + tyvars' <- renameLTyVarBndrs tyvars + lcontext' <- renameLContext lcontext + ltype' <- renameLType ltype + return (HsForAllTy expl tyvars' lcontext' ltype') + + HsTyVar n -> return . HsTyVar =<< rename n + HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + + HsAppTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsAppTy a' b') + + HsFunTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsFunTy a' b') + + HsListTy ty -> return . HsListTy =<< renameLType ty + HsPArrTy ty -> return . HsPArrTy =<< renameLType ty + HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) + HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) + + HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts + + HsOpTy a (w, L loc op) b -> do + op' <- rename op + a' <- renameLType a + b' <- renameLType b + return (HsOpTy a' (w, L loc op') b') + + HsParTy ty -> return . HsParTy =<< renameLType ty + + HsKindSig ty k -> do + ty' <- renameLType ty + k' <- renameLKind k + return (HsKindSig ty' k') + + HsDocTy ty doc -> do + ty' <- renameLType ty + doc' <- renameLDocHsSyn doc + return (HsDocTy ty' doc') + + HsTyLit x -> return (HsTyLit x) + + HsWrapTy a b -> HsWrapTy a <$> renameType b + HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a + HsCoreTy a -> pure (HsCoreTy a) + HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b + HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a + HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + +renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) +renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c + +renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) + = do { tvs' <- mapM renameLTyVarBndr tvs + ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + -- This is rather bogus, but I'm not sure what else to do + +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) +renameLTyVarBndr (L loc (UserTyVar n)) + = do { n' <- rename n + ; return (L loc (UserTyVar n')) } +renameLTyVarBndr (L loc (KindedTyVar n kind)) + = do { n' <- rename n + ; kind' <- renameLKind kind + ; return (L loc (KindedTyVar n' kind')) } + +renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) +renameLContext (L loc context) = do + context' <- mapM renameLType context + return (L loc context') + + +renameInstHead :: InstHead Name -> RnM (InstHead DocName) +renameInstHead (className, k, types, rest) = do + className' <- rename className + k' <- mapM renameType k + types' <- mapM renameType types + rest' <- case rest of + ClassInst cs -> ClassInst <$> mapM renameType cs + TypeInst ts -> TypeInst <$> traverse renameType ts + DataInst dd -> DataInst <$> renameTyClD dd + return (className', k', types', rest') + + +renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) +renameLDecl (L loc d) = return . L loc =<< renameDecl d + + +renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl decl = case decl of + TyClD d -> do + d' <- renameTyClD d + return (TyClD d') + SigD s -> do + s' <- renameSig s + return (SigD s') + ForD d -> do + d' <- renameForD d + return (ForD d') + InstD d -> do + d' <- renameInstD d + return (InstD d') + _ -> error "renameDecl" + +renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) +renameLThing fn (L loc x) = return . L loc =<< fn x + +renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) +renameTyClD d = case d of + ForeignType lname b -> do + lname' <- renameL lname + return (ForeignType lname' b) + +-- TyFamily flav lname ltyvars kind tckind -> do + FamDecl { tcdFam = decl } -> do + decl' <- renameFamilyDecl decl + return (FamDecl { tcdFam = decl' }) + + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do + lname' <- renameL lname + tyvars' <- renameLTyVarBndrs tyvars + rhs' <- renameLType rhs + return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs }) + + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do + lname' <- renameL lname + tyvars' <- renameLTyVarBndrs tyvars + defn' <- renameDataDefn defn + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs }) + + ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do + lcontext' <- renameLContext lcontext + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + lfundeps' <- mapM renameLFunDep lfundeps + lsigs' <- mapM renameLSig lsigs + ats' <- mapM (renameLThing renameFamilyDecl) ats + at_defs' <- mapM (mapM renameTyFamInstD) at_defs + -- we don't need the default methods or the already collected doc entities + return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' + , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + + where + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname + , fdTyVars = ltyvars, fdKindSig = tckind }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + tckind' <- renameMaybeLKind tckind + return (FamilyDecl { fdInfo = info', fdLName = lname' + , fdTyVars = ltyvars', fdKindSig = tckind' }) + +renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) +renameFamilyInfo DataFamily = return DataFamily +renameFamilyInfo OpenTypeFamily = return OpenTypeFamily +renameFamilyInfo (ClosedTypeFamily eqns) + = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns + ; return $ ClosedTypeFamily eqns' } + +renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) +renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType + , dd_kindSig = k, dd_cons = cons }) = do + lcontext' <- renameLContext lcontext + k' <- renameMaybeLKind k + cons' <- mapM (mapM renameCon) cons + -- I don't think we need the derivings, so we return Nothing + return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) + +renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + lcontext' <- renameLContext lcontext + details' <- renameDetails details + restype' <- renameResType restype + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_res = restype', con_doc = mbldoc' }) + where + renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields + renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') + + renameResType (ResTyH98) = return ResTyH98 + renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + + +renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) +renameConDeclFieldField (ConDeclField name t doc) = do + name' <- renameL name + t' <- renameLType t + doc' <- mapM renameLDocHsSyn doc + return (ConDeclField name' t' doc') + + +renameSig :: Sig Name -> RnM (Sig DocName) +renameSig sig = case sig of + TypeSig lnames ltype -> do + lnames' <- mapM renameL lnames + ltype' <- renameLType ltype + return (TypeSig lnames' ltype') + PatSynSig lname args ltype lreq lprov -> do + lname' <- renameL lname + args' <- case args of + PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs + InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright + ltype' <- renameLType ltype + lreq' <- renameLContext lreq + lprov' <- renameLContext lprov + return $ PatSynSig lname' args' ltype' lreq' lprov' + FixSig (FixitySig lname fixity) -> do + lname' <- renameL lname + return $ FixSig (FixitySig lname' fixity) + MinimalSig s -> MinimalSig <$> traverse renameL s + -- we have filtered out all other kinds of signatures in Interface.Create + _ -> error "expected TypeSig" + + +renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) +renameForD (ForeignImport lname ltype co x) = do + lname' <- renameL lname + ltype' <- renameLType ltype + return (ForeignImport lname' ltype' co x) +renameForD (ForeignExport lname ltype co x) = do + lname' <- renameL lname + ltype' <- renameLType ltype + return (ForeignExport lname' ltype' co x) + + +renameInstD :: InstDecl Name -> RnM (InstDecl DocName) +renameInstD (ClsInstD { cid_inst = d }) = do + d' <- renameClsInstD d + return (ClsInstD { cid_inst = d' }) +renameInstD (TyFamInstD { tfid_inst = d }) = do + d' <- renameTyFamInstD d + return (TyFamInstD { tfid_inst = d' }) +renameInstD (DataFamInstD { dfid_inst = d }) = do + d' <- renameDataFamInstD d + return (DataFamInstD { dfid_inst = d' }) + +renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) +renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do + ltype' <- renameLType ltype + lATs' <- mapM (mapM renameTyFamInstD) lATs + lADTs' <- mapM (mapM renameDataFamInstD) lADTs + return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) + + +renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) +renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) + = do { eqn' <- renameLThing renameTyFamInstEqn eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' + , tfid_fvs = placeHolderNames }) } + +renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName) +renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; rhs' <- renameLType rhs + ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' } + , tfie_rhs = rhs' }) } + +renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) +renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; defn' <- renameDataDefn defn + ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' } + , dfid_defn = defn', dfid_fvs = placeHolderNames }) } + +renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) +renameExportItem item = case item of + ExportModule mdl -> return (ExportModule mdl) + ExportGroup lev id_ doc -> do + doc' <- renameDoc doc + return (ExportGroup lev id_ doc') + ExportDecl decl doc subs instances fixities splice -> do + decl' <- renameLDecl decl + doc' <- renameDocForDecl doc + subs' <- mapM renameSub subs + instances' <- forM instances $ \(inst, idoc) -> do + inst' <- renameInstHead inst + idoc' <- mapM renameDoc idoc + return (inst', idoc') + fixities' <- forM fixities $ \(name, fixity) -> do + name' <- lookupRn name + return (name', fixity) + return (ExportDecl decl' doc' subs' instances' fixities' splice) + ExportNoDecl x subs -> do + x' <- lookupRn x + subs' <- mapM lookupRn subs + return (ExportNoDecl x' subs') + ExportDoc doc -> do + doc' <- renameDoc doc + return (ExportDoc doc') + + +renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) +renameSub (n,doc) = do + n' <- rename n + doc' <- renameDocForDecl doc + return (n', doc') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -0,0 +1,636 @@ +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.InterfaceFile +-- Copyright : (c) David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Reading and writing the .haddock interface file +----------------------------------------------------------------------------- +module Haddock.InterfaceFile ( + InterfaceFile(..), ifPackageId, + readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, + writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility +) where + + +import Haddock.Types +import Haddock.Utils hiding (out) + +import Control.Monad +import Data.Array +import Data.Functor ((<$>)) +import Data.IORef +import Data.List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Word + +import BinIface (getSymtabName, getDictFastString) +import Binary +import FastMutInt +import FastString +import GHC hiding (NoLink) +import GhcMonad (withSession) +import HscTypes +import IfaceEnv +import Name +import UniqFM +import UniqSupply +import Unique + + +data InterfaceFile = InterfaceFile { + ifLinkEnv :: LinkEnv, + ifInstalledIfaces :: [InstalledInterface] +} + + +ifPackageId :: InterfaceFile -> PackageId +ifPackageId if_ = + case ifInstalledIfaces if_ of + [] -> error "empty InterfaceFile" + iface:_ -> modulePackageId $ instMod iface + + +binaryInterfaceMagic :: Word32 +binaryInterfaceMagic = 0xD0Cface + + +-- IMPORTANT: Since datatypes in the GHC API might change between major +-- versions, and because we store GHC datatypes in our interface files, we need +-- to make sure we version our interface files accordingly. +-- +-- If you change the interface file format or adapt Haddock to work with a new +-- major version of GHC (so that the format changes indirectly) *you* need to +-- follow these steps: +-- +-- (1) increase `binaryInterfaceVersion` +-- +-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] +-- +binaryInterfaceVersion :: Word16 +#if __GLASGOW_HASKELL__ == 708 +binaryInterfaceVersion = 25 + +binaryInterfaceVersionCompatibility :: [Word16] +binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] +#else +#error Unsupported GHC version +#endif + + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + + +writeInterfaceFile :: FilePath -> InterfaceFile -> IO () +writeInterfaceFile filename iface = do + bh0 <- openBinMem initBinMemSize + put_ bh0 binaryInterfaceMagic + put_ bh0 binaryInterfaceVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some intial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = BinSymbolTable { + bin_symtab_next = symtab_next, + bin_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = BinDictionary { + bin_dict_next = dict_next_ref, + bin_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) + put_ bh iface + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the fornt of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + writeBinMem bh filename + return () + + +type NameCacheAccessor m = (m NameCache, NameCache -> m ()) + + +nameCacheFromGhc :: NameCacheAccessor Ghc +nameCacheFromGhc = ( read_from_session , write_to_session ) + where + read_from_session = do + ref <- withSession (return . hsc_NC) + liftIO $ readIORef ref + write_to_session nc' = do + ref <- withSession (return . hsc_NC) + liftIO $ writeIORef ref nc' + + +freshNameCache :: NameCacheAccessor IO +freshNameCache = ( create_fresh_nc , \_ -> return () ) + where + create_fresh_nc = do + u <- mkSplitUniqSupply 'a' -- ?? + return (initNameCache u []) + + +-- | Read a Haddock (@.haddock@) interface file. Return either an +-- 'InterfaceFile' or an error message. +-- +-- This function can be called in two ways. Within a GHC session it will +-- update the use and update the session's name cache. Outside a GHC session +-- a new empty name cache is used. The function is therefore generic in the +-- monad being used. The exact monad is whichever monad the first +-- argument, the getter and setter of the name cache, requires. +-- +readInterfaceFile :: forall m. + MonadIO m + => NameCacheAccessor m + -> FilePath + -> m (Either String InterfaceFile) +readInterfaceFile (get_name_cache, set_name_cache) filename = do + bh0 <- liftIO $ readBinMem filename + + magic <- liftIO $ get bh0 + version <- liftIO $ get bh0 + + case () of + _ | magic /= binaryInterfaceMagic -> return . Left $ + "Magic number mismatch: couldn't load interface file: " ++ filename + | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + "Interface file is of wrong version: " ++ filename + | otherwise -> with_name_cache $ \update_nc -> do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- update_nc (get_symbol_table bh1) + return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) + (getDictFastString dict) + + -- load the actual data + iface <- liftIO $ get bh1 + return (Right iface) + where + with_name_cache :: forall a. + ((forall n b. MonadIO n + => (NameCache -> n (NameCache, b)) + -> n b) + -> m a) + -> m a + with_name_cache act = do + nc_var <- get_name_cache >>= (liftIO . newIORef) + x <- act $ \f -> do + nc <- liftIO $ readIORef nc_var + (nc', x) <- f nc + liftIO $ writeIORef nc_var nc' + return x + liftIO (readIORef nc_var) >>= set_name_cache + return x + + get_dictionary bin_handle = liftIO $ do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 theNC = liftIO $ do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + (nc', symtab) <- getSymbolTable bh1 theNC + seekBin bh1 data_p' + return (nc', symtab) + + +------------------------------------------------------------------------------- +-- * Symbol table +------------------------------------------------------------------------------- + + +putName :: BinSymbolTable -> BinHandle -> Name -> IO () +putName BinSymbolTable{ + bin_symtab_map = symtab_map_ref, + bin_symtab_next = symtab_next } bh name + = do + symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + + +data BinSymbolTable = BinSymbolTable { + bin_symtab_next :: !FastMutInt, -- The next index to use + bin_symtab_map :: !(IORef (UniqFM (Int,Name))) + -- indexed by Name + } + + +putFastString :: BinDictionary -> BinHandle -> FastString -> IO () +putFastString BinDictionary { bin_dict_next = j_r, + bin_dict_map = out_r} bh f + = do + out <- readIORef out_r + let unique = getUnique f + case lookupUFM out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out unique (j, f) + + +data BinDictionary = BinDictionary { + bin_dict_next :: !FastMutInt, -- The next index to use + bin_dict_map :: !(IORef (UniqFM (Int,FastString))) + -- indexed by FastString + } + + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = elems (array (0,next_off-1) (eltsUFM symtab)) + mapM_ (\n -> serialiseName bh n symtab) names + + +getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) +getSymbolTable bh namecache = do + sz <- get bh + od_names <- replicateM sz (get bh) + let arr = listArray (0,sz-1) names + (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names + return (namecache', arr) + + +type OnDiskName = (PackageId, ModuleName, OccName) + + +fromOnDiskName + :: Array Int Name + -> NameCache + -> OnDiskName + -> (NameCache, Name) +fromOnDiskName _ nc (pid, mod_name, occ) = + let + modu = mkModule pid mod_name + cache = nsNames nc + in + case lookupOrigNameCache cache modu occ of + Just name -> (nc, name) + Nothing -> + let + us = nsUniqs nc + u = uniqFromSupply us + name = mkExternalName u modu occ noSrcSpan + new_cache = extendNameCache cache modu occ name + in + case splitUniqSupply us of { (us',_) -> + ( nc{ nsUniqs = us', nsNames = new_cache }, name ) + } + + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName bh name _ = do + let modu = nameModule name + put_ bh (modulePackageId modu, moduleName modu, nameOccName name) + + +------------------------------------------------------------------------------- +-- * GhcBinary instances +------------------------------------------------------------------------------- + + +instance (Ord k, Binary k, Binary v) => Binary (Map k v) where + put_ bh m = put_ bh (Map.toList m) + get bh = fmap (Map.fromList) (get bh) + + +instance Binary InterfaceFile where + put_ bh (InterfaceFile env ifaces) = do + put_ bh env + put_ bh ifaces + + get bh = do + env <- get bh + ifaces <- get bh + return (InterfaceFile env ifaces) + + +instance Binary InstalledInterface where + put_ bh (InstalledInterface modu info docMap argMap + exps visExps opts subMap fixMap) = do + put_ bh modu + put_ bh info + put_ bh docMap + put_ bh argMap + put_ bh exps + put_ bh visExps + put_ bh opts + put_ bh subMap + put_ bh fixMap + + get bh = do + modu <- get bh + info <- get bh + docMap <- get bh + argMap <- get bh + exps <- get bh + visExps <- get bh + opts <- get bh + subMap <- get bh + fixMap <- get bh + + return (InstalledInterface modu info docMap argMap + exps visExps opts subMap fixMap) + + +instance Binary DocOption where + put_ bh OptHide = do + putByte bh 0 + put_ bh OptPrune = do + putByte bh 1 + put_ bh OptIgnoreExports = do + putByte bh 2 + put_ bh OptNotHome = do + putByte bh 3 + put_ bh OptShowExtensions = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do + return OptHide + 1 -> do + return OptPrune + 2 -> do + return OptIgnoreExports + 3 -> do + return OptNotHome + 4 -> do + return OptShowExtensions + _ -> fail "invalid binary data found" + + +instance Binary Example where + put_ bh (Example expression result) = do + put_ bh expression + put_ bh result + get bh = do + expression <- get bh + result <- get bh + return (Example expression result) + +instance Binary Hyperlink where + put_ bh (Hyperlink url label) = do + put_ bh url + put_ bh label + get bh = do + url <- get bh + label <- get bh + return (Hyperlink url label) + +instance Binary Picture where + put_ bh (Picture uri title) = do + put_ bh uri + put_ bh title + get bh = do + uri <- get bh + title <- get bh + return (Picture uri title) + +instance Binary a => Binary (Header a) where + put_ bh (Header l t) = do + put_ bh l + put_ bh t + get bh = do + l <- get bh + t <- get bh + return (Header l t) + +{-* Generated by DrIFT : Look, but Don't Touch. *-} +instance (Binary mod, Binary id) => Binary (DocH mod id) where + put_ bh DocEmpty = do + putByte bh 0 + put_ bh (DocAppend aa ab) = do + putByte bh 1 + put_ bh aa + put_ bh ab + put_ bh (DocString ac) = do + putByte bh 2 + put_ bh ac + put_ bh (DocParagraph ad) = do + putByte bh 3 + put_ bh ad + put_ bh (DocIdentifier ae) = do + putByte bh 4 + put_ bh ae + put_ bh (DocModule af) = do + putByte bh 5 + put_ bh af + put_ bh (DocEmphasis ag) = do + putByte bh 6 + put_ bh ag + put_ bh (DocMonospaced ah) = do + putByte bh 7 + put_ bh ah + put_ bh (DocUnorderedList ai) = do + putByte bh 8 + put_ bh ai + put_ bh (DocOrderedList aj) = do + putByte bh 9 + put_ bh aj + put_ bh (DocDefList ak) = do + putByte bh 10 + put_ bh ak + put_ bh (DocCodeBlock al) = do + putByte bh 11 + put_ bh al + put_ bh (DocHyperlink am) = do + putByte bh 12 + put_ bh am + put_ bh (DocPic x) = do + putByte bh 13 + put_ bh x + put_ bh (DocAName an) = do + putByte bh 14 + put_ bh an + put_ bh (DocExamples ao) = do + putByte bh 15 + put_ bh ao + put_ bh (DocIdentifierUnchecked x) = do + putByte bh 16 + put_ bh x + put_ bh (DocWarning ag) = do + putByte bh 17 + put_ bh ag + put_ bh (DocProperty x) = do + putByte bh 18 + put_ bh x + put_ bh (DocBold x) = do + putByte bh 19 + put_ bh x + put_ bh (DocHeader aa) = do + putByte bh 20 + put_ bh aa + + get bh = do + h <- getByte bh + case h of + 0 -> do + return DocEmpty + 1 -> do + aa <- get bh + ab <- get bh + return (DocAppend aa ab) + 2 -> do + ac <- get bh + return (DocString ac) + 3 -> do + ad <- get bh + return (DocParagraph ad) + 4 -> do + ae <- get bh + return (DocIdentifier ae) + 5 -> do + af <- get bh + return (DocModule af) + 6 -> do + ag <- get bh + return (DocEmphasis ag) + 7 -> do + ah <- get bh + return (DocMonospaced ah) + 8 -> do + ai <- get bh + return (DocUnorderedList ai) + 9 -> do + aj <- get bh + return (DocOrderedList aj) + 10 -> do + ak <- get bh + return (DocDefList ak) + 11 -> do + al <- get bh + return (DocCodeBlock al) + 12 -> do + am <- get bh + return (DocHyperlink am) + 13 -> do + x <- get bh + return (DocPic x) + 14 -> do + an <- get bh + return (DocAName an) + 15 -> do + ao <- get bh + return (DocExamples ao) + 16 -> do + x <- get bh + return (DocIdentifierUnchecked x) + 17 -> do + ag <- get bh + return (DocWarning ag) + 18 -> do + x <- get bh + return (DocProperty x) + 19 -> do + x <- get bh + return (DocBold x) + 20 -> do + aa <- get bh + return (DocHeader aa) + _ -> error "invalid binary data found in the interface file" + + +instance Binary name => Binary (HaddockModInfo name) where + put_ bh hmi = do + put_ bh (hmi_description hmi) + put_ bh (hmi_copyright hmi) + put_ bh (hmi_license hmi) + put_ bh (hmi_maintainer hmi) + put_ bh (hmi_stability hmi) + put_ bh (hmi_portability hmi) + put_ bh (hmi_safety hmi) + put_ bh (fromEnum <$> hmi_language hmi) + put_ bh (map fromEnum $ hmi_extensions hmi) + + get bh = do + descr <- get bh + copyr <- get bh + licen <- get bh + maint <- get bh + stabi <- get bh + porta <- get bh + safet <- get bh + langu <- fmap toEnum <$> get bh + exten <- map toEnum <$> get bh + return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten) + +instance Binary DocName where + put_ bh (Documented name modu) = do + putByte bh 0 + put_ bh name + put_ bh modu + put_ bh (Undocumented name) = do + putByte bh 1 + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + modu <- get bh + return (Documented name modu) + 1 -> do + name <- get bh + return (Undocumented name) + _ -> error "get DocName: Bad h" diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.ModuleTree +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where + + +import Haddock.Types ( Doc ) + +import GHC ( Name ) +import Module ( Module, moduleNameString, moduleName, modulePackageId, + packageIdString ) + + +data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] + + +mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] +mkModuleTree showPkgs mods = + foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] + where + modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) + | otherwise = Nothing + fn (mod_,pkg,short) = addToTrees mod_ pkg short + + +addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ ts = ts +addToTrees ss pkg short [] = mkSubTree ss pkg short +addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) pkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts + where + this_pkg = if null ss then pkg else node_pkg + this_short = if null ss then short else node_short + + +mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] +mkSubTree [] _ _ = [] +mkSubTree [s] pkg short = [Node s True pkg short []] +mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] + + +splitModule :: Module -> [String] +splitModule mdl = split (moduleNameString (moduleName mdl)) + where split mod0 = case break (== '.') mod0 of + (s1, '.':s2) -> s1 : split s2 + (s1, _) -> [s1] diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Options.hs @@ -0,0 +1,287 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Options +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Definition of the command line interface of Haddock. +----------------------------------------------------------------------------- +module Haddock.Options ( + parseHaddockOpts, + Flag(..), + getUsage, + optTitle, + outputDir, + optContentsUrl, + optIndexUrl, + optCssFile, + sourceUrls, + wikiUrls, + optDumpInterfaceFile, + optLaTeXStyle, + qualification, + verbosity, + ghcFlags, + readIfaceArgs +) where + + +import Distribution.Verbosity +import Haddock.Utils +import Haddock.Types +import System.Console.GetOpt +import qualified Data.Char as Char + + +data Flag + = Flag_BuiltInThemes + | Flag_CSS String +-- | Flag_DocBook + | Flag_ReadInterface String + | Flag_DumpInterface String + | Flag_Heading String + | Flag_Html + | Flag_Hoogle + | Flag_Lib String + | Flag_OutputDir FilePath + | Flag_Prologue FilePath + | Flag_SourceBaseURL String + | Flag_SourceModuleURL String + | Flag_SourceEntityURL String + | Flag_SourceLEntityURL String + | Flag_WikiBaseURL String + | Flag_WikiModuleURL String + | Flag_WikiEntityURL String + | Flag_LaTeX + | Flag_LaTeXStyle String + | Flag_Help + | Flag_Verbosity String + | Flag_Version + | Flag_CompatibleInterfaceVersions + | Flag_InterfaceVersion + | Flag_UseContents String + | Flag_GenContents + | Flag_UseIndex String + | Flag_GenIndex + | Flag_IgnoreAllExports + | Flag_HideModule String + | Flag_ShowExtensions String + | Flag_OptGhc String + | Flag_GhcLibDir String + | Flag_GhcVersion + | Flag_PrintGhcPath + | Flag_PrintGhcLibDir + | Flag_NoWarnings + | Flag_UseUnicode + | Flag_NoTmpCompDir + | Flag_Qualification String + | Flag_PrettyHtml + | Flag_PrintMissingDocs + deriving (Eq) + + +options :: Bool -> [OptDescr Flag] +options backwardsCompat = + [ + Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR") + "path to a GHC lib dir, to override the default path", + Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") + "directory in which to put the output files", + Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") + "location of Haddock's auxiliary files", + Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") + "read an interface from FILE", + Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") + "write the resulting interface to FILE", +-- Option ['S'] ["docbook"] (NoArg Flag_DocBook) +-- "output in DocBook XML", + Option ['h'] ["html"] (NoArg Flag_Html) + "output in HTML (XHTML 1.0)", + Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", + Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", + Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", + Option [] ["hoogle"] (NoArg Flag_Hoogle) + "output for Hoogle", + Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") + "URL for a source code link on the contents\nand index pages", + Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) + (ReqArg Flag_SourceModuleURL "URL") + "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)", + Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL") + "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", + Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL") + "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", + Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") + "URL for a comments link on the contents\nand index pages", + Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") + "URL for a comments link for each module\n(using the %{MODULE} var)", + Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") + "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", + Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH") + "the CSS file or theme directory to use for HTML output", + Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes) + "include all the built-in haddock themes", + Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE") + "file containing prologue text", + Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") + "page heading", + Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL") + "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'", + Option ['?'] ["help"] (NoArg Flag_Help) + "display this help and exit", + Option ['V'] ["version"] (NoArg Flag_Version) + "output version information and exit", + Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions) + "output compatible interface file versions and exit", + Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) + "output interface file version and exit", + Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") + "set verbosity level", + Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") + "use a separately-generated HTML contents page", + Option [] ["gen-contents"] (NoArg Flag_GenContents) + "generate an HTML contents from specified\ninterfaces", + Option [] ["use-index"] (ReqArg Flag_UseIndex "URL") + "use a separately-generated HTML index", + Option [] ["gen-index"] (NoArg Flag_GenIndex) + "generate an HTML index from specified\ninterfaces", + Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) + "behave as if all modules have the\nignore-exports atribute", + Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") + "behave as if MODULE has the hide attribute", + Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE") + "behave as if MODULE has the show-extensions attribute", + Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") + "option to be forwarded to GHC", + Option [] ["ghc-version"] (NoArg Flag_GhcVersion) + "output GHC version in numeric format", + Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath) + "output path to GHC binary", + Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) + "output GHC lib dir", + Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", + Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir) + "do not re-direct compilation output to a temporary directory", + Option [] ["pretty-html"] (NoArg Flag_PrettyHtml) + "generate html with newlines and indenting (for use with --html)", + Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs) + "print information about any undocumented entities" + ] + + +getUsage :: IO String +getUsage = do + prog <- getProgramName + return $ usageInfo (usageHeader prog) (options False) + where + usageHeader :: String -> String + usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" + + +parseHaddockOpts :: [String] -> IO ([Flag], [String]) +parseHaddockOpts params = + case getOpt Permute (options True) params of + (flags, args, []) -> return (flags, args) + (_, _, errors) -> do + usage <- getUsage + throwE (concat errors ++ usage) + + +optTitle :: [Flag] -> Maybe String +optTitle flags = + case [str | Flag_Heading str <- flags] of + [] -> Nothing + (t:_) -> Just t + + +outputDir :: [Flag] -> FilePath +outputDir flags = + case [ path | Flag_OutputDir path <- flags ] of + [] -> "." + paths -> last paths + + +optContentsUrl :: [Flag] -> Maybe String +optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ] + + +optIndexUrl :: [Flag] -> Maybe String +optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] + + +optCssFile :: [Flag] -> Maybe FilePath +optCssFile flags = optLast [ str | Flag_CSS str <- flags ] + + +sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) +sourceUrls flags = + (optLast [str | Flag_SourceBaseURL str <- flags] + ,optLast [str | Flag_SourceModuleURL str <- flags] + ,optLast [str | Flag_SourceEntityURL str <- flags] + ,optLast [str | Flag_SourceLEntityURL str <- flags]) + + +wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String) +wikiUrls flags = + (optLast [str | Flag_WikiBaseURL str <- flags] + ,optLast [str | Flag_WikiModuleURL str <- flags] + ,optLast [str | Flag_WikiEntityURL str <- flags]) + + +optDumpInterfaceFile :: [Flag] -> Maybe FilePath +optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] + + +optLaTeXStyle :: [Flag] -> Maybe String +optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] + + +qualification :: [Flag] -> Either String QualOption +qualification flags = + case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of + [] -> Right OptNoQual + ["none"] -> Right OptNoQual + ["full"] -> Right OptFullQual + ["local"] -> Right OptLocalQual + ["relative"] -> Right OptRelativeQual + ["aliased"] -> Right OptAliasedQual + [arg] -> Left $ "unknown qualification type " ++ show arg + _:_ -> Left "qualification option given multiple times" + + +verbosity :: [Flag] -> Verbosity +verbosity flags = + case [ str | Flag_Verbosity str <- flags ] of + [] -> normal + x:_ -> case parseVerbosity x of + Left e -> throwE e + Right v -> v + + +ghcFlags :: [Flag] -> [String] +ghcFlags flags = [ option | Flag_OptGhc option <- flags ] + + +readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] +readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] + where + parseIfaceOption :: String -> (DocPaths, FilePath) + parseIfaceOption str = + case break (==',') str of + (fpath, ',':rest) -> + case break (==',') rest of + (src, ',':file) -> ((fpath, Just src), file) + (file, _) -> ((fpath, Nothing), file) + (file, _) -> (("", Nothing), file) + + +-- | Like 'listToMaybe' but returns the last element instead of the first. +optLast :: [a] -> Maybe a +optLast [] = Nothing +optLast xs = Just (last xs) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Parser.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving + , FlexibleInstances, UndecidableInstances + , IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +-- | +-- Module : Haddock.Parser +-- Copyright : (c) Mateusz Kowalczyk 2013, +-- Simon Hengel 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable + +module Haddock.Parser ( parseParas + , parseString + , parseIdent + ) where + +import qualified Documentation.Haddock.Parser as P +import DynFlags (DynFlags) +import FastString (mkFastString) +import Documentation.Haddock.Types +import Lexer (mkPState, unP, ParseResult(POk)) +import Parser (parseIdentifier) +import RdrName (RdrName) +import SrcLoc (mkRealSrcLoc, unLoc) +import StringBuffer (stringToStringBuffer) + +parseParas :: DynFlags -> String -> DocH mod RdrName +parseParas d = P.overIdentifier (parseIdent d) . P.parseParas + +parseString :: DynFlags -> String -> DocH mod RdrName +parseString d = P.overIdentifier (parseIdent d) . P.parseString + +parseIdent :: DynFlags -> String -> Maybe RdrName +parseIdent dflags str0 = + let buffer = stringToStringBuffer str0 + realSrcLc = mkRealSrcLoc (mkFastString "") 0 0 + pstate = mkPState dflags buffer realSrcLc + in case unP parseIdentifier pstate of + POk _ name -> Just (unLoc name) + _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Types.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskellorg +-- Stability : experimental +-- Portability : portable +-- +-- Types that are commonly used through-out Haddock. Some of the most +-- important types are defined here, like 'Interface' and 'DocName'. +----------------------------------------------------------------------------- +module Haddock.Types ( + module Haddock.Types + , HsDocString, LHsDocString + , Fixity(..) + , module Documentation.Haddock.Types + ) where + +import Control.Exception +import Control.Arrow hiding ((<+>)) +import Control.DeepSeq +import Data.Typeable +import Data.Map (Map) +import qualified Data.Map as Map +import Documentation.Haddock.Types +import BasicTypes (Fixity(..)) +import GHC hiding (NoLink) +import DynFlags (ExtensionFlag, Language) +import OccName +import Outputable +import Control.Applicative (Applicative(..)) +import Control.Monad (ap) + +----------------------------------------------------------------------------- +-- * Convenient synonyms +----------------------------------------------------------------------------- + + +type IfaceMap = Map Module Interface +type InstIfaceMap = Map Module InstalledInterface -- TODO: rename +type DocMap a = Map Name (Doc a) +type ArgMap a = Map Name (Map Int (Doc a)) +type SubMap = Map Name [Name] +type DeclMap = Map Name [LHsDecl Name] +type InstMap = Map SrcSpan Name +type FixMap = Map Name Fixity +type SrcMap = Map PackageId FilePath +type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources + + +----------------------------------------------------------------------------- +-- * Interface +----------------------------------------------------------------------------- + + +-- | 'Interface' holds all information used to render a single Haddock page. +-- It represents the /interface/ of a module. The core business of Haddock +-- lies in creating this structure. Note that the record contains some fields +-- that are only used to create the final record, and that are not used by the +-- backends. +data Interface = Interface + { + -- | The module behind this interface. + ifaceMod :: !Module + + -- | Original file name of the module. + , ifaceOrigFilename :: !FilePath + + -- | Textual information about the module. + , ifaceInfo :: !(HaddockModInfo Name) + + -- | Documentation header. + , ifaceDoc :: !(Documentation Name) + + -- | Documentation header with cross-reference information. + , ifaceRnDoc :: !(Documentation DocName) + + -- | Haddock options for this module (prune, ignore-exports, etc). + , ifaceOptions :: ![DocOption] + + -- | Declarations originating from the module. Excludes declarations without + -- names (instances and stand-alone documentation comments). Includes + -- names of subordinate declarations mapped to their parent declarations. + , ifaceDeclMap :: !(Map Name [LHsDecl Name]) + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , ifaceDocMap :: !(DocMap Name) + , ifaceArgMap :: !(ArgMap Name) + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , ifaceRnDocMap :: !(DocMap DocName) + , ifaceRnArgMap :: !(ArgMap DocName) + + , ifaceSubMap :: !(Map Name [Name]) + , ifaceFixMap :: !(Map Name Fixity) + + , ifaceExportItems :: ![ExportItem Name] + , ifaceRnExportItems :: ![ExportItem DocName] + + -- | All names exported by the module. + , ifaceExports :: ![Name] + + -- | All \"visible\" names exported by the module. + -- A visible name is a name that will show up in the documentation of the + -- module. + , ifaceVisibleExports :: ![Name] + + -- | Aliases of module imports as in @import A.B.C as C@. + , ifaceModuleAliases :: !AliasMap + + -- | Instances exported by the module. + , ifaceInstances :: ![ClsInst] + , ifaceFamInstances :: ![FamInst] + + -- | The number of haddockable and haddocked items in the module, as a + -- tuple. Haddockable items are the exports and the module itself. + , ifaceHaddockCoverage :: !(Int, Int) + + -- | Warnings for things defined in this module. + , ifaceWarningMap :: !WarningMap + } + +type WarningMap = DocMap Name + + +-- | A subset of the fields of 'Interface' that we store in the interface +-- files. +data InstalledInterface = InstalledInterface + { + -- | The module represented by this interface. + instMod :: Module + + -- | Textual information about the module. + , instInfo :: HaddockModInfo Name + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , instDocMap :: DocMap Name + + , instArgMap :: ArgMap Name + + -- | All names exported by this module. + , instExports :: [Name] + + -- | All \"visible\" names exported by the module. + -- A visible name is a name that will show up in the documentation of the + -- module. + , instVisibleExports :: [Name] + + -- | Haddock options for this module (prune, ignore-exports, etc). + , instOptions :: [DocOption] + + , instSubMap :: Map Name [Name] + , instFixMap :: Map Name Fixity + } + + +-- | Convert an 'Interface' to an 'InstalledInterface' +toInstalledIface :: Interface -> InstalledInterface +toInstalledIface interface = InstalledInterface + { instMod = ifaceMod interface + , instInfo = ifaceInfo interface + , instDocMap = ifaceDocMap interface + , instArgMap = ifaceArgMap interface + , instExports = ifaceExports interface + , instVisibleExports = ifaceVisibleExports interface + , instOptions = ifaceOptions interface + , instSubMap = ifaceSubMap interface + , instFixMap = ifaceFixMap interface + } + + +----------------------------------------------------------------------------- +-- * Export items & declarations +----------------------------------------------------------------------------- + + +data ExportItem name + + -- | An exported declaration. + = ExportDecl + { + -- | A declaration. + expItemDecl :: !(LHsDecl name) + + -- | Maybe a doc comment, and possibly docs for arguments (if this + -- decl is a function or type-synonym). + , expItemMbDoc :: !(DocForDecl name) + + -- | Subordinate names, possibly with documentation. + , expItemSubDocs :: ![(name, DocForDecl name)] + + -- | Instances relevant to this declaration, possibly with + -- documentation. + , expItemInstances :: ![DocInstance name] + + -- | Fixity decls relevant to this declaration (including subordinates). + , expItemFixities :: ![(name, Fixity)] + + -- | Whether the ExportItem is from a TH splice or not, for generating + -- the appropriate type of Source link. + , expItemSpliced :: !Bool + } + + -- | An exported entity for which we have no documentation (perhaps because it + -- resides in another package). + | ExportNoDecl + { expItemName :: !name + + -- | Subordinate names. + , expItemSubs :: ![name] + } + + -- | A section heading. + | ExportGroup + { + -- | Section level (1, 2, 3, ...). + expItemSectionLevel :: !Int + + -- | Section id (for hyperlinks). + , expItemSectionId :: !String + + -- | Section heading text. + , expItemSectionText :: !(Doc name) + } + + -- | Some documentation. + | ExportDoc !(Doc name) + + -- | A cross-reference to another module. + | ExportModule !Module + +data Documentation name = Documentation + { documentationDoc :: Maybe (Doc name) + , documentationWarning :: !(Maybe (Doc name)) + } deriving Functor + + +-- | Arguments and result are indexed by Int, zero-based from the left, +-- because that's the easiest to use when recursing over types. +type FnArgsDoc name = Map Int (Doc name) +type DocForDecl name = (Documentation name, FnArgsDoc name) + + +noDocForDecl :: DocForDecl name +noDocForDecl = (Documentation Nothing Nothing, Map.empty) + + +unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name +unrenameDocForDecl (doc, fnArgsDoc) = + (fmap getName doc, (fmap . fmap) getName fnArgsDoc) + + +----------------------------------------------------------------------------- +-- * Cross-referencing +----------------------------------------------------------------------------- + + +-- | Type of environment used to cross-reference identifiers in the syntax. +type LinkEnv = Map Name Module + + +-- | Extends 'Name' with cross-reference information. +data DocName + = Documented Name Module + -- ^ This thing is part of the (existing or resulting) + -- documentation. The 'Module' is the preferred place + -- in the documentation to refer to. + | Undocumented Name + -- ^ This thing is not part of the (existing or resulting) + -- documentation, as far as Haddock knows. + deriving Eq + + +instance NamedThing DocName where + getName (Documented name _) = name + getName (Undocumented name) = name + + +----------------------------------------------------------------------------- +-- * Instances +----------------------------------------------------------------------------- + +-- | The three types of instances +data InstType name + = ClassInst [HsType name] -- ^ Context + | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) + | DataInst (TyClDecl name) -- ^ Data constructors + +instance OutputableBndr a => Outputable (InstType a) where + ppr (ClassInst a) = text "ClassInst" <+> ppr a + ppr (TypeInst a) = text "TypeInst" <+> ppr a + ppr (DataInst a) = text "DataInst" <+> ppr a + +-- | An instance head that may have documentation. +type DocInstance name = (InstHead name, Maybe (Doc name)) + +-- | The head of an instance. Consists of a class name, a list of kind +-- parameters, a list of type parameters and an instance type +type InstHead name = (name, [HsType name], [HsType name], InstType name) + +----------------------------------------------------------------------------- +-- * Documentation comments +----------------------------------------------------------------------------- + + +type LDoc id = Located (Doc id) + +type Doc id = DocH (ModuleName, OccName) id + +instance (NFData a, NFData mod) + => NFData (DocH mod a) where + rnf doc = case doc of + DocEmpty -> () + DocAppend a b -> a `deepseq` b `deepseq` () + DocString a -> a `deepseq` () + DocParagraph a -> a `deepseq` () + DocIdentifier a -> a `deepseq` () + DocIdentifierUnchecked a -> a `deepseq` () + DocModule a -> a `deepseq` () + DocWarning a -> a `deepseq` () + DocEmphasis a -> a `deepseq` () + DocBold a -> a `deepseq` () + DocMonospaced a -> a `deepseq` () + DocUnorderedList a -> a `deepseq` () + DocOrderedList a -> a `deepseq` () + DocDefList a -> a `deepseq` () + DocCodeBlock a -> a `deepseq` () + DocHyperlink a -> a `deepseq` () + DocPic a -> a `deepseq` () + DocAName a -> a `deepseq` () + DocProperty a -> a `deepseq` () + DocExamples a -> a `deepseq` () + DocHeader a -> a `deepseq` () + + +instance NFData Name +instance NFData OccName +instance NFData ModuleName + +instance NFData id => NFData (Header id) where + rnf (Header a b) = a `deepseq` b `deepseq` () + +instance NFData Hyperlink where + rnf (Hyperlink a b) = a `deepseq` b `deepseq` () + +instance NFData Picture where + rnf (Picture a b) = a `deepseq` b `deepseq` () + +instance NFData Example where + rnf (Example a b) = a `deepseq` b `deepseq` () + + +exampleToString :: Example -> String +exampleToString (Example expression result) = + ">>> " ++ expression ++ "\n" ++ unlines result + + +data DocMarkup id a = Markup + { markupEmpty :: a + , markupString :: String -> a + , markupParagraph :: a -> a + , markupAppend :: a -> a -> a + , markupIdentifier :: id -> a + , markupIdentifierUnchecked :: (ModuleName, OccName) -> a + , markupModule :: String -> a + , markupWarning :: a -> a + , markupEmphasis :: a -> a + , markupBold :: a -> a + , markupMonospaced :: a -> a + , markupUnorderedList :: [a] -> a + , markupOrderedList :: [a] -> a + , markupDefList :: [(a,a)] -> a + , markupCodeBlock :: a -> a + , markupHyperlink :: Hyperlink -> a + , markupAName :: String -> a + , markupPic :: Picture -> a + , markupProperty :: String -> a + , markupExample :: [Example] -> a + , markupHeader :: Header a -> a + } + + +data HaddockModInfo name = HaddockModInfo + { hmi_description :: Maybe (Doc name) + , hmi_copyright :: Maybe String + , hmi_license :: Maybe String + , hmi_maintainer :: Maybe String + , hmi_stability :: Maybe String + , hmi_portability :: Maybe String + , hmi_safety :: Maybe String + , hmi_language :: Maybe Language + , hmi_extensions :: [ExtensionFlag] + } + + +emptyHaddockModInfo :: HaddockModInfo a +emptyHaddockModInfo = HaddockModInfo + { hmi_description = Nothing + , hmi_copyright = Nothing + , hmi_license = Nothing + , hmi_maintainer = Nothing + , hmi_stability = Nothing + , hmi_portability = Nothing + , hmi_safety = Nothing + , hmi_language = Nothing + , hmi_extensions = [] + } + + +----------------------------------------------------------------------------- +-- * Options +----------------------------------------------------------------------------- + + +{-! for DocOption derive: Binary !-} +-- | Source-level options for controlling the documentation. +data DocOption + = OptHide -- ^ This module should not appear in the docs. + | OptPrune + | OptIgnoreExports -- ^ Pretend everything is exported. + | OptNotHome -- ^ Not the best place to get docs for things + -- exported by this module. + | OptShowExtensions -- ^ Render enabled extensions for this module. + deriving (Eq, Show) + + +-- | Option controlling how to qualify names +data QualOption + = OptNoQual -- ^ Never qualify any names. + | OptFullQual -- ^ Qualify all names fully. + | OptLocalQual -- ^ Qualify all imported names fully. + | OptRelativeQual -- ^ Like local, but strip module prefix + -- from modules in the same hierarchy. + | OptAliasedQual -- ^ Uses aliases of module names + -- as suggested by module import renamings. + -- However, we are unfortunately not able + -- to maintain the original qualifications. + -- Image a re-export of a whole module, + -- how could the re-exported identifiers be qualified? + +type AliasMap = Map Module ModuleName + +data Qualification + = NoQual + | FullQual + | LocalQual Module + | RelativeQual Module + | AliasedQual AliasMap Module + -- ^ @Module@ contains the current module. + -- This way we can distinguish imported and local identifiers. + +makeContentsQual :: QualOption -> Qualification +makeContentsQual qual = + case qual of + OptNoQual -> NoQual + _ -> FullQual + +makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification +makeModuleQual qual aliases mdl = + case qual of + OptLocalQual -> LocalQual mdl + OptRelativeQual -> RelativeQual mdl + OptAliasedQual -> AliasedQual aliases mdl + OptFullQual -> FullQual + OptNoQual -> NoQual + + +----------------------------------------------------------------------------- +-- * Error handling +----------------------------------------------------------------------------- + + +-- A monad which collects error messages, locally defined to avoid a dep on mtl + + +type ErrMsg = String +newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } + + +instance Functor ErrMsgM where + fmap f (Writer (a, msgs)) = Writer (f a, msgs) + +instance Applicative ErrMsgM where + pure = return + (<*>) = ap + +instance Monad ErrMsgM where + return a = Writer (a, []) + m >>= k = Writer $ let + (a, w) = runWriter m + (b, w') = runWriter (k a) + in (b, w ++ w') + + +tell :: [ErrMsg] -> ErrMsgM () +tell w = Writer ((), w) + + +-- Exceptions + + +-- | Haddock's own exception type. +data HaddockException = HaddockException String deriving Typeable + + +instance Show HaddockException where + show (HaddockException str) = str + + +throwE :: String -> a +instance Exception HaddockException +throwE str = throw (HaddockException str) + + +-- In "Haddock.Interface.Create", we need to gather +-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, +-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the +-- transformed monad to be MonadIO. +newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } +--instance MonadIO ErrMsgGhc where +-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO +--er, implementing GhcMonad involves annoying ExceptionMonad and +--WarnLogMonad classes, so don't bother. +liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a +liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) +liftErrMsg :: ErrMsgM a -> ErrMsgGhc a +liftErrMsg = WriterGhc . return . runWriter +-- for now, use (liftErrMsg . tell) for this +--tell :: [ErrMsg] -> ErrMsgGhc () +--tell msgs = WriterGhc $ return ( (), msgs ) + + +instance Functor ErrMsgGhc where + fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) + +instance Applicative ErrMsgGhc where + pure = return + (<*>) = ap + +instance Monad ErrMsgGhc where + return a = WriterGhc (return (a, [])) + m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> + fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Utils.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Utils +-- Copyright : (c) The University of Glasgow 2001-2002, +-- Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Utils ( + + -- * Misc utilities + restrictTo, emptyHsQTvs, + toDescription, toInstalledDescription, + + -- * Filename utilities + moduleHtmlFile, moduleHtmlFile', + contentsHtmlFile, indexHtmlFile, + frameIndexHtmlFile, + moduleIndexFrameName, mainFrameName, synopsisFrameName, + subIndexHtmlFile, + jsFile, framesFile, + + -- * Anchor and URL utilities + moduleNameUrl, moduleNameUrl', moduleUrl, + nameAnchorId, + makeAnchorId, + + -- * Miscellaneous utilities + getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + + -- * HTML cross reference mapping + html_xrefs_ref, html_xrefs_ref', + + -- * Doc markup + markup, + idMarkup, + + -- * List utilities + replace, + spanWith, + + -- * MTL stuff + MonadIO(..), + + -- * Logging + parseVerbosity, + out, + + -- * System tools + getProcessID + ) where + + +import Haddock.Types +import Haddock.GhcUtils + +import GHC +import Name + +import Control.Monad ( liftM ) +import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) +import Numeric ( showIntAtBase ) +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Data.IORef ( IORef, newIORef, readIORef ) +import Data.List ( isSuffixOf ) +import Data.Maybe ( mapMaybe ) +import System.Environment ( getProgName ) +import System.Exit +import System.IO ( hPutStr, stderr ) +import System.IO.Unsafe ( unsafePerformIO ) +import qualified System.FilePath.Posix as HtmlPath +import Distribution.Verbosity +import Distribution.ReadE + +#ifndef mingw32_HOST_OS +import qualified System.Posix.Internals +#endif + +import MonadUtils ( MonadIO(..) ) + + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + + +parseVerbosity :: String -> Either String Verbosity +parseVerbosity = runReadE flagToVerbosity + + +-- | Print a message to stdout, if it is not too verbose +out :: MonadIO m + => Verbosity -- ^ program verbosity + -> Verbosity -- ^ message verbosity + -> String -> m () +out progVerbosity msgVerbosity msg + | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg + | otherwise = return () + + +-------------------------------------------------------------------------------- +-- * Some Utilities +-------------------------------------------------------------------------------- + + +-- | Extract a module's short description. +toDescription :: Interface -> Maybe (Doc Name) +toDescription = hmi_description . ifaceInfo + + +-- | Extract a module's short description. +toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) +toInstalledDescription = hmi_description . instInfo + + +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- + + +restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name +restrictTo names (L loc decl) = L loc $ case decl of + TyClD d | isDataDecl d -> + TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD d | isClassDecl d -> + TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + tcdATs = restrictATs names (tcdATs d) }) + _ -> decl + +restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name +restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) + | DataType <- new_or_data + = defn { dd_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { dd_ND = DataType, dd_cons = [] } + [con] -> defn { dd_cons = [con] } + _ -> error "Should not happen" + +restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] +restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] + where + keep d | unLoc (con_name d) `elem` names = + case con_details d of + PrefixCon _ -> Just d + RecCon fields + | all field_avail fields -> Just d + | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) + -- if we have *all* the field names available, then + -- keep the record declaration. Otherwise degrade to + -- a constructor declaration. This isn't quite right, but + -- it's the best we can do. + InfixCon _ _ -> Just d + where + field_avail (ConDeclField n _ _) = unLoc n `elem` names + field_types flds = [ t | ConDeclField _ t _ <- flds ] + + keep _ = Nothing + + +restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) + + +restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] +restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] + +emptyHsQTvs :: LHsTyVarBndrs Name +-- This function is here, rather than in HsTypes, because it *renamed*, but +-- does not necessarily have all the rigt kind variables. It is used +-- in Haddock just for printing, so it doesn't matter +emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } + + +-------------------------------------------------------------------------------- +-- * Filename mangling functions stolen from s main/DriverUtil.lhs. +-------------------------------------------------------------------------------- + + +baseName :: ModuleName -> FilePath +baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString + + +moduleHtmlFile :: Module -> FilePath +moduleHtmlFile mdl = + case Map.lookup mdl html_xrefs of + Nothing -> baseName mdl' ++ ".html" + Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"] + where + mdl' = moduleName mdl + + +moduleHtmlFile' :: ModuleName -> FilePath +moduleHtmlFile' mdl = + case Map.lookup mdl html_xrefs' of + Nothing -> baseName mdl ++ ".html" + Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] + + +contentsHtmlFile, indexHtmlFile :: String +contentsHtmlFile = "index.html" +indexHtmlFile = "doc-index.html" + + +-- | The name of the module index file to be displayed inside a frame. +-- Modules are display in full, but without indentation. Clicking opens in +-- the main window. +frameIndexHtmlFile :: String +frameIndexHtmlFile = "index-frames.html" + + +moduleIndexFrameName, mainFrameName, synopsisFrameName :: String +moduleIndexFrameName = "modules" +mainFrameName = "main" +synopsisFrameName = "synopsis" + + +subIndexHtmlFile :: String -> String +subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" + where b | all isAlpha ls = ls + | otherwise = concatMap (show . ord) ls + + +------------------------------------------------------------------------------- +-- * Anchor and URL utilities +-- +-- NB: Anchor IDs, used as the destination of a link within a document must +-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's +-- various needs and compatibility constraints, means these IDs have to match: +-- [A-Za-z][A-Za-z0-9:_.-]* +-- Such IDs do not need to be escaped in any way when used as the fragment part +-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it +-- isn't clear if such fragment identifiers should, or should not be unescaped +-- before being matched with IDs in the target document. +------------------------------------------------------------------------------- + + +moduleUrl :: Module -> String +moduleUrl = moduleHtmlFile + + +moduleNameUrl :: Module -> OccName -> String +moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n + + +moduleNameUrl' :: ModuleName -> OccName -> String +moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n + + +nameAnchorId :: OccName -> String +nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) + where prefix | isValOcc name = 'v' + | otherwise = 't' + + +-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is +-- identity preserving. +makeAnchorId :: String -> String +makeAnchorId [] = [] +makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r + where + escape p c | p c = [c] + | otherwise = '-' : show (ord c) ++ "-" + isLegal ':' = True + isLegal '_' = True + isLegal '.' = True + isLegal c = isAscii c && isAlphaNum c + -- NB: '-' is legal in IDs, but we use it as the escape char + + +------------------------------------------------------------------------------- +-- * Files we need to copy from our $libdir +------------------------------------------------------------------------------- + + +jsFile, framesFile :: String +jsFile = "haddock-util.js" +framesFile = "frames.html" + + +------------------------------------------------------------------------------- +-- * Misc. +------------------------------------------------------------------------------- + + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + + +bye :: String -> IO a +bye s = putStr s >> exitSuccess + + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + + +dieMsg :: String -> IO a +dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + + +noDieMsg :: String -> IO () +noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) + + +mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] +mapSnd _ [] = [] +mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs + + +mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) +mapMaybeM _ Nothing = return Nothing +mapMaybeM f (Just a) = liftM Just (f a) + + +escapeStr :: String -> String +escapeStr = escapeURIString isUnreserved + + +-- Following few functions are copy'n'pasted from Network.URI module +-- to avoid depending on the network lib, since doing so gives a +-- circular build dependency between haddock and network +-- (at least if you want to build network with haddock docs) +escapeURIChar :: (Char -> Bool) -> Char -> String +escapeURIChar p c + | p c = [c] + | otherwise = '%' : myShowHex (ord c) "" + where + myShowHex :: Int -> ShowS + myShowHex n r = case showIntAtBase 16 toChrHex n r of + [] -> "00" + [a] -> ['0',a] + cs -> cs + toChrHex d + | d < 10 = chr (ord '0' + fromIntegral d) + | otherwise = chr (ord 'A' + fromIntegral (d - 10)) + + +escapeURIString :: (Char -> Bool) -> String -> String +escapeURIString = concatMap . escapeURIChar + + +isUnreserved :: Char -> Bool +isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") + + +isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool +isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') +isDigitChar c = c >= '0' && c <= '9' +isAlphaNumChar c = isAlphaChar c || isDigitChar c + + +----------------------------------------------------------------------------- +-- * HTML cross references +-- +-- For each module, we need to know where its HTML documentation lives +-- so that we can point hyperlinks to it. It is extremely +-- inconvenient to plumb this information to all the places that need +-- it (basically every function in HaddockHtml), and furthermore the +-- mapping is constant for any single run of Haddock. So for the time +-- being I'm going to use a write-once global variable. +----------------------------------------------------------------------------- + + +{-# NOINLINE html_xrefs_ref #-} +html_xrefs_ref :: IORef (Map Module FilePath) +html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) + + +{-# NOINLINE html_xrefs_ref' #-} +html_xrefs_ref' :: IORef (Map ModuleName FilePath) +html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map")) + + +{-# NOINLINE html_xrefs #-} +html_xrefs :: Map Module FilePath +html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) + + +{-# NOINLINE html_xrefs' #-} +html_xrefs' :: Map ModuleName FilePath +html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref') + + +----------------------------------------------------------------------------- +-- * List utils +----------------------------------------------------------------------------- + + +replace :: Eq a => a -> a -> [a] -> [a] +replace a b = map (\x -> if x == a then b else x) + + +spanWith :: (a -> Maybe b) -> [a] -> ([b],[a]) +spanWith _ [] = ([],[]) +spanWith p xs@(a:as) + | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) + | otherwise = ([],xs) + + +----------------------------------------------------------------------------- +-- * Put here temporarily +----------------------------------------------------------------------------- + + +markup :: DocMarkup id a -> Doc id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink l) = markupHyperlink m l +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) + + +markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) +markupPair m (a,b) = (markup m a, markup m b) + + +-- | The identity markup +idMarkup :: DocMarkup a (Doc a) +idMarkup = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupIdentifierUnchecked = DocIdentifierUnchecked, + markupModule = DocModule, + markupWarning = DocWarning, + markupEmphasis = DocEmphasis, + markupBold = DocBold, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupHyperlink = DocHyperlink, + markupAName = DocAName, + markupPic = DocPic, + markupProperty = DocProperty, + markupExample = DocExamples, + markupHeader = DocHeader + } + + +----------------------------------------------------------------------------- +-- * System tools +----------------------------------------------------------------------------- + + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows +#else +getProcessID :: IO Int +getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid +#endif diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs new file mode 100644 --- /dev/null +++ b/haddock-api/src/Haddock/Version.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Version +-- Copyright : (c) Simon Marlow 2003 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Version ( + projectName, projectVersion, projectUrl +) where + +#ifdef IN_GHC_TREE +import Paths_haddock ( version ) +#else +import Paths_haddock_api ( version ) +#endif +import Data.Version ( showVersion ) + +projectName :: String +projectName = "Haddock" + +projectUrl :: String +projectUrl = "http://www.haskell.org/haddock/" + +projectVersion :: String +projectVersion = showVersion version diff --git a/haddock-api/src/haddock.sh b/haddock-api/src/haddock.sh new file mode 100644 --- /dev/null +++ b/haddock-api/src/haddock.sh @@ -0,0 +1,7 @@ +# Mini-driver for Haddock + +# needs the following variables: +# HADDOCKLIB +# HADDOCKBIN + +$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"} diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Doc.hs @@ -0,0 +1,58 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Documentation.Haddock.Doc (docParagraph, docAppend, docConcat) where + +import Documentation.Haddock.Types +import Data.Char (isSpace) + +docConcat :: [DocH mod id] -> DocH mod id +docConcat = foldr docAppend DocEmpty + +docAppend :: DocH mod id -> DocH mod id -> DocH mod id +docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2) +docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d +docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2) +docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d +docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2) +docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) = DocAppend (DocUnorderedList (ds1++ds2)) d +docAppend DocEmpty d = d +docAppend d DocEmpty = d +docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2) +docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2)) +docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d +docAppend d1 d2 = DocAppend d1 d2 + +-- again to make parsing easier - we spot a paragraph whose only item +-- is a DocMonospaced and make it into a DocCodeBlock +docParagraph :: DocH mod id -> DocH mod id +docParagraph (DocMonospaced p) + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocString s1) (DocMonospaced p)) + | all isSpace s1 + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocString s1) + (DocAppend (DocMonospaced p) (DocString s2))) + | all isSpace s1 && all isSpace s2 + = DocCodeBlock (docCodeBlock p) +docParagraph (DocAppend (DocMonospaced p) (DocString s2)) + | all isSpace s2 + = DocCodeBlock (docCodeBlock p) +docParagraph p + = DocParagraph p + + +-- Drop trailing whitespace from @..@ code blocks. Otherwise this: +-- +-- -- @ +-- -- foo +-- -- @ +-- +-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML +-- gives an extra vertical space after the code block. The single space +-- on the final line seems to trigger the extra vertical space. +-- +docCodeBlock :: DocH mod id -> DocH mod id +docCodeBlock (DocString s) + = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) +docCodeBlock (DocAppend l r) + = DocAppend l (docCodeBlock r) +docCodeBlock d = d diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE IncoherentInstances #-} +-- | +-- Module : Documentation.Haddock.Parser +-- Copyright : (c) Mateusz Kowalczyk 2013-2014, +-- Simon Hengel 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Parser used for Haddock comments. For external users of this +-- library, the most commonly used combination of functions is going +-- to be +-- +-- @'toRegular' . 'parseParas'@ +module Documentation.Haddock.Parser ( parseString, parseParas + , overIdentifier, toRegular, Identifier + ) where + +import Control.Applicative +import Control.Arrow (first) +import Control.Monad (void, mfilter) +import Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine) +import qualified Data.ByteString.Char8 as BS +import Data.Char (chr, isAsciiUpper) +import Data.List (stripPrefix, intercalate, unfoldr) +import Data.Maybe (fromMaybe) +import Data.Monoid +import Documentation.Haddock.Doc +import Documentation.Haddock.Parser.Util +import Documentation.Haddock.Types +import Documentation.Haddock.Utf8 +import Prelude hiding (takeWhile) + +-- $setup +-- >>> :set -XOverloadedStrings + +-- | Identifier string surrounded with opening and closing quotes/backticks. +type Identifier = (Char, String, Char) + +-- | Drops the quotes/backticks around all identifiers, as if they +-- were valid but still 'String's. +toRegular :: DocH mod Identifier -> DocH mod String +toRegular = fmap (\(_, x, _) -> x) + +-- | Maps over 'DocIdentifier's over 'String' with potentially failing +-- conversion using user-supplied function. If the conversion fails, +-- the identifier is deemed to not be valid and is treated as a +-- regular string. +overIdentifier :: (String -> Maybe a) + -> DocH mod Identifier + -> DocH mod a +overIdentifier f d = g d + where + g (DocIdentifier (o, x, e)) = case f x of + Nothing -> DocString $ o : x ++ [e] + Just x' -> DocIdentifier x' + g DocEmpty = DocEmpty + g (DocAppend x x') = DocAppend (g x) (g x') + g (DocString x) = DocString x + g (DocParagraph x) = DocParagraph $ g x + g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x + g (DocModule x) = DocModule x + g (DocWarning x) = DocWarning $ g x + g (DocEmphasis x) = DocEmphasis $ g x + g (DocMonospaced x) = DocMonospaced $ g x + g (DocBold x) = DocBold $ g x + g (DocUnorderedList x) = DocUnorderedList $ fmap g x + g (DocOrderedList x) = DocOrderedList $ fmap g x + g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x + g (DocCodeBlock x) = DocCodeBlock $ g x + g (DocHyperlink x) = DocHyperlink x + g (DocPic x) = DocPic x + g (DocAName x) = DocAName x + g (DocProperty x) = DocProperty x + g (DocExamples x) = DocExamples x + g (DocHeader (Header l x)) = DocHeader . Header l $ g x + +parse :: Parser a -> BS.ByteString -> a +parse p = either err id . parseOnly (p <* endOfInput) + where + err = error . ("Haddock.Parser.parse: " ++) + +-- | Main entry point to the parser. Appends the newline character +-- to the input string. +parseParas :: String -- ^ String to parse + -> DocH mod Identifier +parseParas = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") + where + p :: Parser (DocH mod Identifier) + p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n") + +-- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which +-- drops leading whitespace and encodes the string to UTF8 first. +parseString :: String -> DocH mod Identifier +parseString = parseStringBS . encodeUtf8 . dropWhile isSpace + +parseStringBS :: BS.ByteString -> DocH mod Identifier +parseStringBS = parse p + where + p :: Parser (DocH mod Identifier) + p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName + <|> picture <|> hyperlink <|> bold + <|> emphasis <|> encodedChar <|> string' + <|> skipSpecialChar) + +-- | Parses and processes +-- +-- +-- >>> parseOnly encodedChar "A" +-- Right (DocString "A") +encodedChar :: Parser (DocH mod a) +encodedChar = "&#" *> c <* ";" + where + c = DocString . return . chr <$> num + num = hex <|> decimal + hex = ("x" <|> "X") *> hexadecimal + +-- | List of characters that we use to delimit any special markup. +-- Once we have checked for any of these and tried to parse the +-- relevant markup, we can assume they are used as regular text. +specialChar :: [Char] +specialChar = "_/<@\"&'`# " + +-- | Plain, regular parser for text. Called as one of the last parsers +-- to ensure that we have already given a chance to more meaningful parsers +-- before capturing their characers. +string' :: Parser (DocH mod a) +string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (`notElem` specialChar) + where + unescape "" = "" + unescape ('\\':x:xs) = x : unescape xs + unescape (x:xs) = x : unescape xs + +-- | Skips a single special character and treats it as a plain string. +-- This is done to skip over any special characters belonging to other +-- elements but which were not deemed meaningful at their positions. +skipSpecialChar :: Parser (DocH mod a) +skipSpecialChar = DocString . return <$> satisfy (`elem` specialChar) + +-- | Emphasis parser. +-- +-- >>> parseOnly emphasis "/Hello world/" +-- Right (DocEmphasis (DocString "Hello world")) +emphasis :: Parser (DocH mod Identifier) +emphasis = DocEmphasis . parseStringBS <$> + mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/") + +-- | Bold parser. +-- +-- >>> parseOnly bold "__Hello world__" +-- Right (DocBold (DocString "Hello world")) +bold :: Parser (DocH mod Identifier) +bold = DocBold . parseStringBS <$> disallowNewline ("__" *> takeUntil "__") + +disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString +disallowNewline = mfilter ('\n' `BS.notElem`) + +-- | Like `takeWhile`, but unconditionally take escaped characters. +takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString +takeWhile_ p = scan False p_ + where + p_ escaped c + | escaped = Just False + | not $ p c = Nothing + | otherwise = Just (c == '\\') + +-- | Like `takeWhile1`, but unconditionally take escaped characters. +takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString +takeWhile1_ = mfilter (not . BS.null) . takeWhile_ + +-- | Text anchors to allow for jumping around the generated documentation. +-- +-- >>> parseOnly anchor "#Hello world#" +-- Right (DocAName "Hello world") +anchor :: Parser (DocH mod a) +anchor = DocAName . decodeUtf8 <$> + disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") + +-- | Monospaced strings. +-- +-- >>> parseOnly monospace "@cruel@" +-- Right (DocMonospaced (DocString "cruel")) +monospace :: Parser (DocH mod Identifier) +monospace = DocMonospaced . parseStringBS <$> ("@" *> takeWhile1_ (/= '@') <* "@") + +moduleName :: Parser (DocH mod a) +moduleName = DocModule <$> (char '"' *> modid <* char '"') + where + modid = intercalate "." <$> conid `sepBy1` "." + conid = (:) + <$> satisfy isAsciiUpper + -- NOTE: According to Haskell 2010 we should actually only + -- accept {small | large | digit | ' } here. But as we can't + -- match on unicode characters, this is currently not possible. + -- Note that we allow ‘#’ to suport anchors. + <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!|@/;,^?\"\n")) + +-- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify +-- a title for the picture. +-- +-- >>> parseOnly picture "<>" +-- Right (DocPic (Picture {pictureUri = "hello.png", pictureTitle = Nothing})) +-- >>> parseOnly picture "<>" +-- Right (DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"})) +picture :: Parser (DocH mod a) +picture = DocPic . makeLabeled Picture . decodeUtf8 + <$> disallowNewline ("<<" *> takeUntil ">>") + +-- | Paragraph parser, called by 'parseParas'. +paragraph :: Parser (DocH mod Identifier) +paragraph = examples <|> skipSpace *> (list <|> birdtracks <|> codeblock + <|> property <|> header + <|> textParagraph) + +-- | Headers inside the comment denoted with @=@ signs, up to 6 levels +-- deep. +-- +-- >>> parseOnly header "= Hello" +-- Right (DocHeader (Header {headerLevel = 1, headerTitle = DocString "Hello"})) +-- >>> parseOnly header "== World" +-- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"})) +header :: Parser (DocH mod Identifier) +header = do + let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1] + pser = foldl1 (<|>) psers + delim <- decodeUtf8 <$> pser + line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString + rest <- paragraph <|> return DocEmpty + return $ DocHeader (Header (length delim) line) `docAppend` rest + +textParagraph :: Parser (DocH mod Identifier) +textParagraph = docParagraph . parseString . intercalate "\n" <$> many1 nonEmptyLine + +-- | List parser, called by 'paragraph'. +list :: Parser (DocH mod Identifier) +list = DocUnorderedList <$> unorderedList + <|> DocOrderedList <$> orderedList + <|> DocDefList <$> definitionList + +-- | Parses unordered (bullet) lists. +unorderedList :: Parser [DocH mod Identifier] +unorderedList = ("*" <|> "-") *> innerList unorderedList + +-- | Parses ordered lists (numbered or dashed). +orderedList :: Parser [DocH mod Identifier] +orderedList = (paren <|> dot) *> innerList orderedList + where + dot = (decimal :: Parser Int) <* "." + paren = "(" *> decimal <* ")" + +-- | Generic function collecting any further lines belonging to the +-- list entry and recursively collecting any further lists in the +-- same paragraph. Usually used as +-- +-- > someListFunction = listBeginning *> innerList someListFunction +innerList :: Parser [DocH mod Identifier] -> Parser [DocH mod Identifier] +innerList item = do + c <- takeLine + (cs, items) <- more item + let contents = docParagraph . parseString . dropNLs . unlines $ c : cs + return $ case items of + Left p -> [contents `docAppend` p] + Right i -> contents : i + +-- | Parses definition lists. +definitionList :: Parser [(DocH mod Identifier, DocH mod Identifier)] +definitionList = do + label <- "[" *> (parseStringBS <$> takeWhile1 (`notElem` "]\n")) <* "]" + c <- takeLine + (cs, items) <- more definitionList + let contents = parseString . dropNLs . unlines $ c : cs + return $ case items of + Left p -> [(label, contents `docAppend` p)] + Right i -> (label, contents) : i + +-- | Drops all trailing newlines. +dropNLs :: String -> String +dropNLs = reverse . dropWhile (== '\n') . reverse + +-- | Main worker for 'innerList' and 'definitionList'. +-- We need the 'Either' here to be able to tell in the respective functions +-- whether we're dealing with the next list or a nested paragraph. +more :: Monoid a => Parser a + -> Parser ([String], Either (DocH mod Identifier) a) +more item = innerParagraphs <|> moreListItems item + <|> moreContent item <|> pure ([], Right mempty) + +-- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs. +innerParagraphs :: Parser ([String], Either (DocH mod Identifier) a) +innerParagraphs = (,) [] . Left <$> ("\n" *> indentedParagraphs) + +-- | Attempts to fetch the next list if possibly. Used by 'innerList' and +-- 'definitionList' to recursively grab lists that aren't separated by a whole +-- paragraph. +moreListItems :: Parser a + -> Parser ([String], Either (DocH mod Identifier) a) +moreListItems item = (,) [] . Right <$> (skipSpace *> item) + +-- | Helper for 'innerList' and 'definitionList' which simply takes +-- a line of text and attempts to parse more list content with 'more'. +moreContent :: Monoid a => Parser a + -> Parser ([String], Either (DocH mod Identifier) a) +moreContent item = first . (:) <$> nonEmptyLine <*> more item + +-- | Runs the 'parseParas' parser on an indented paragraph. +-- The indentation is 4 spaces. +indentedParagraphs :: Parser (DocH mod Identifier) +indentedParagraphs = parseParas . concat <$> dropFrontOfPara " " + +-- | Grab as many fully indented paragraphs as we can. +dropFrontOfPara :: Parser BS.ByteString -> Parser [String] +dropFrontOfPara sp = do + currentParagraph <- some (sp *> takeNonEmptyLine) + followingParagraphs <- + skipHorizontalSpace *> nextPar -- we have more paragraphs to take + <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline + <|> endOfInput *> return [] -- nothing more to take at all + return (currentParagraph ++ followingParagraphs) + where + nextPar = (++) <$> nlList <*> dropFrontOfPara sp + nlList = "\n" *> return ["\n"] + +nonSpace :: BS.ByteString -> Parser BS.ByteString +nonSpace xs + | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line" + | otherwise = return xs + +-- | Takes a non-empty, not fully whitespace line. +-- +-- Doesn't discard the trailing newline. +takeNonEmptyLine :: Parser String +takeNonEmptyLine = do + (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n" + +-- | Blocks of text of the form: +-- +-- >> foo +-- >> bar +-- >> baz +-- +birdtracks :: Parser (DocH mod a) +birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line + where + line = skipHorizontalSpace *> ">" *> takeLine + +stripSpace :: [String] -> [String] +stripSpace = fromMaybe <*> mapM strip' + where + strip' (' ':xs') = Just xs' + strip' "" = Just "" + strip' _ = Nothing + +-- | Parses examples. Examples are a paragraph level entitity (separated by an empty line). +-- Consecutive examples are accepted. +examples :: Parser (DocH mod a) +examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go) + where + go :: Parser [Example] + go = do + prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>" + expr <- takeLine + (rs, es) <- resultAndMoreExamples + return (makeExample prefix expr rs : es) + where + resultAndMoreExamples :: Parser ([String], [Example]) + resultAndMoreExamples = moreExamples <|> result <|> pure ([], []) + where + moreExamples :: Parser ([String], [Example]) + moreExamples = (,) [] <$> go + + result :: Parser ([String], [Example]) + result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples + + makeExample :: String -> String -> [String] -> Example + makeExample prefix expression res = + Example (strip expression) result + where + result = map (substituteBlankLine . tryStripPrefix) res + + tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs) + + substituteBlankLine "" = "" + substituteBlankLine xs = xs + +nonEmptyLine :: Parser String +nonEmptyLine = mfilter (any (not . isSpace)) takeLine + +takeLine :: Parser String +takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine + +endOfLine :: Parser () +endOfLine = void "\n" <|> endOfInput + +-- | Property parser. +-- +-- >>> parseOnly property "prop> hello world" +-- Right (DocProperty "hello world") +property :: Parser (DocH mod a) +property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n')) + +-- | +-- Paragraph level codeblock. Anything between the two delimiting \@ is parsed +-- for markup. +codeblock :: Parser (DocH mod Identifier) +codeblock = + DocCodeBlock . parseStringBS . dropSpaces + <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") + where + dropSpaces xs = + let rs = decodeUtf8 xs + in case splitByNl rs of + [] -> xs + ys -> case last ys of + ' ':_ -> case mapM dropSpace ys of + Nothing -> xs + Just zs -> encodeUtf8 $ intercalate "\n" zs + _ -> xs + + -- This is necessary because ‘lines’ swallows up a trailing newline + -- and we lose information about whether the last line belongs to @ or to + -- text which we need to decide whether we actually want to be dropping + -- anything at all. + splitByNl = unfoldr (\x -> case x of + '\n':s -> Just (span (/= '\n') s) + _ -> Nothing) + . ('\n' :) + + dropSpace "" = Just "" + dropSpace (' ':xs) = Just xs + dropSpace _ = Nothing + + block' = scan False p + where + p isNewline c + | isNewline && c == '@' = Nothing + | isNewline && isSpace c = Just isNewline + | otherwise = Just $ c == '\n' + +-- | Parses links that were specifically marked as such. +hyperlink :: Parser (DocH mod a) +hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8 + <$> disallowNewline ("<" *> takeUntil ">") + <|> autoUrl + +-- | Looks for URL-like things to automatically hyperlink even if they +-- weren't marked as links. +autoUrl :: Parser (DocH mod a) +autoUrl = mkLink <$> url + where + url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace) + mkLink :: BS.ByteString -> DocH mod a + mkLink s = case unsnoc s of + Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x] + _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing) + +-- | Parses strings between identifier delimiters. Consumes all input that it +-- deems to be valid in an identifier. Note that it simply blindly consumes +-- characters and does no actual validation itself. +parseValid :: Parser String +parseValid = do + vs' <- many' $ utf8String "⋆" <|> return <$> idChar + let vs = concat vs' + c <- peekChar + case c of + Just '`' -> return vs + Just '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> parseValid) + <|> return vs + _ -> fail "outofvalid" + where + idChar = satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:^") + <|> digit <|> letter_ascii + +-- | Parses UTF8 strings from ByteString streams. +utf8String :: String -> Parser String +utf8String x = decodeUtf8 <$> string (encodeUtf8 x) + +-- | Parses identifiers with help of 'parseValid'. Asks GHC for 'String' from the +-- string it deems valid. +identifier :: Parser (DocH mod Identifier) +identifier = do + o <- idDelim + vid <- parseValid + e <- idDelim + return $ DocIdentifier (o, vid, e) + where + idDelim = char '\'' <|> char '`' diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Documentation.Haddock.Parser.Util +-- Copyright : (c) Mateusz Kowalczyk 2013-2014, +-- Simon Hengel 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Various utility functions used by the parser. +module Documentation.Haddock.Parser.Util ( + unsnoc +, strip +, takeUntil +, makeLabeled +, takeHorizontalSpace +, skipHorizontalSpace +) where + +import Control.Applicative +import Control.Monad (mfilter) +import Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Prelude hiding (takeWhile) + +#if MIN_VERSION_bytestring(0,10,2) +import Data.ByteString.Char8 (unsnoc) +#else +unsnoc :: ByteString -> Maybe (ByteString, Char) +unsnoc bs + | BS.null bs = Nothing + | otherwise = Just (BS.init bs, BS.last bs) +#endif + +-- | Remove all leading and trailing whitespace +strip :: String -> String +strip = (\f -> f . f) $ dropWhile isSpace . reverse + +skipHorizontalSpace :: Parser () +skipHorizontalSpace = skipWhile (`elem` " \t\f\v\r") + +takeHorizontalSpace :: Parser BS.ByteString +takeHorizontalSpace = takeWhile (`elem` " \t\f\v\r") + +makeLabeled :: (String -> Maybe String -> a) -> String -> a +makeLabeled f input = case break isSpace $ removeEscapes $ strip input of + (uri, "") -> f uri Nothing + (uri, label) -> f uri (Just $ dropWhile isSpace label) + where + -- As we don't parse these any further, we don't do any processing to the + -- string so we at least remove escape character here. Perhaps we should + -- actually be parsing the label at the very least? + removeEscapes "" = "" + removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs + removeEscapes ('\\':xs) = removeEscapes xs + removeEscapes (x:xs) = x : removeEscapes xs + +takeUntil :: ByteString -> Parser ByteString +takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome + where + end = BS.unpack end_ + + p :: (Bool, String) -> Char -> Maybe (Bool, String) + p acc c = case acc of + (True, _) -> Just (False, end) + (_, []) -> Nothing + (_, x:xs) | x == c -> Just (False, xs) + _ -> Just (c == '\\', end) + + dropEnd = BS.reverse . BS.drop (length end) . BS.reverse + requireEnd = mfilter (BS.isSuffixOf end_) + + gotSome xs + | BS.null xs = fail "didn't get any content" + | otherwise = return xs diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable, StandaloneDeriving #-} + +-- | +-- Module : Documentation.Haddock.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskellorg +-- Stability : experimental +-- Portability : portable +-- +-- Exposes documentation data types used for (some) of Haddock. +module Documentation.Haddock.Types where + +import Data.Foldable +import Data.Traversable + +instance Foldable Header where + foldMap f (Header _ a) = f a + +instance Traversable Header where + traverse f (Header l a) = Header l `fmap` f a + + +deriving instance Show a => Show (Header a) +deriving instance (Show a, Show b) => Show (DocH a b) +deriving instance Eq a => Eq (Header a) +deriving instance (Eq a, Eq b) => Eq (DocH a b) + +data Hyperlink = Hyperlink + { hyperlinkUrl :: String + , hyperlinkLabel :: Maybe String + } deriving (Eq, Show) + + +data Picture = Picture + { pictureUri :: String + , pictureTitle :: Maybe String + } deriving (Eq, Show) + +data Header id = Header + { headerLevel :: Int + , headerTitle :: id + } deriving Functor + +data Example = Example + { exampleExpression :: String + , exampleResult :: [String] + } deriving (Eq, Show) + +data DocH mod id + = DocEmpty + | DocAppend (DocH mod id) (DocH mod id) + | DocString String + | DocParagraph (DocH mod id) + | DocIdentifier id + | DocIdentifierUnchecked mod + | DocModule String + | DocWarning (DocH mod id) + | DocEmphasis (DocH mod id) + | DocMonospaced (DocH mod id) + | DocBold (DocH mod id) + | DocUnorderedList [DocH mod id] + | DocOrderedList [DocH mod id] + | DocDefList [(DocH mod id, DocH mod id)] + | DocCodeBlock (DocH mod id) + | DocHyperlink Hyperlink + | DocPic Picture + | DocAName String + | DocProperty String + | DocExamples [Example] + | DocHeader (Header (DocH mod id)) + deriving (Functor, Foldable, Traversable) diff --git a/haddock-library/src/Documentation/Haddock/Utf8.hs b/haddock-library/src/Documentation/Haddock/Utf8.hs new file mode 100644 --- /dev/null +++ b/haddock-library/src/Documentation/Haddock/Utf8.hs @@ -0,0 +1,74 @@ +module Documentation.Haddock.Utf8 (encodeUtf8, decodeUtf8) where +import Data.Bits ((.|.), (.&.), shiftL, shiftR) +import qualified Data.ByteString as BS +import Data.Char (chr, ord) +import Data.Word (Word8) + +-- | Helper that encodes and packs a 'String' into a 'BS.ByteString' +encodeUtf8 :: String -> BS.ByteString +encodeUtf8 = BS.pack . encode + +-- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String' +decodeUtf8 :: BS.ByteString -> String +decodeUtf8 = decode . BS.unpack + +-- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding +-- | Character to use when 'encode' or 'decode' fail for a byte. +replacementCharacter :: Char +replacementCharacter = '\xfffd' + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +encode :: String -> [Word8] +encode = concatMap (map fromIntegral . go . ord) + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + +-- | Decode a UTF8 string packed into a list of Word8 values, directly to String +decode :: [Word8] -> String +decode [ ] = "" +decode (c:cs) + | c < 0x80 = chr (fromEnum c) : decode cs + | c < 0xc0 = replacementCharacter : decode cs + | c < 0xe0 = multi1 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacementCharacter : decode cs + where + multi1 = case cs of + c1 : ds | c1 .&. 0xc0 == 0x80 -> + let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) + in if d >= 0x000080 then toEnum d : decode ds + else replacementCharacter : decode ds + _ -> replacementCharacter : decode cs + + multi_byte :: Int -> Word8 -> Int -> String + multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) + where + aux 0 rs acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs + | otherwise = replacementCharacter : decode rs + + aux n (r:rs) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs + $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) + + aux _ rs _ = replacementCharacter : decode rs diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec.hs @@ -0,0 +1,23 @@ +-- | +-- Module : Data.Attoparsec +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient combinator parsing for +-- 'Data.ByteString.ByteString' strings, loosely based on the Parsec +-- library. +-- +-- This module is deprecated. Use "Data.Attoparsec.ByteString" +-- instead. + +module Data.Attoparsec + {-# DEPRECATED "This module will be removed in the next major release." #-} + ( + module Data.Attoparsec.ByteString + ) where + +import Data.Attoparsec.ByteString diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString.hs @@ -0,0 +1,223 @@ +-- | +-- Module : Data.Attoparsec.ByteString +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient combinator parsing for 'B.ByteString' strings, +-- loosely based on the Parsec library. + +module Data.Attoparsec.ByteString + ( + -- * Differences from Parsec + -- $parsec + + -- * Incremental input + -- $incremental + + -- * Performance considerations + -- $performance + + -- * Parser types + I.Parser + , Result + , T.IResult(..) + , I.compareResults + + -- * Running parsers + , parse + , feed + , I.parseOnly + , parseWith + , parseTest + + -- ** Result conversion + , maybeResult + , eitherResult + + -- * Parsing individual bytes + , I.word8 + , I.anyWord8 + , I.notWord8 + , I.satisfy + , I.satisfyWith + , I.skip + + -- ** Lookahead + , I.peekWord8 + , I.peekWord8' + + -- ** Byte classes + , I.inClass + , I.notInClass + + -- * Efficient string handling + , I.string + , I.skipWhile + , I.take + , I.scan + , I.takeWhile + , I.takeWhile1 + , I.takeTill + + -- ** Consume all remaining input + , I.takeByteString + , I.takeLazyByteString + + -- * Combinators + , try + , () + , choice + , count + , option + , many' + , many1 + , many1' + , manyTill + , manyTill' + , sepBy + , sepBy' + , sepBy1 + , sepBy1' + , skipMany + , skipMany1 + , eitherP + , I.match + -- * State observation and manipulation functions + , I.endOfInput + , I.atEnd + ) where + +import Data.Attoparsec.Combinator +import qualified Data.Attoparsec.ByteString.Internal as I +import qualified Data.Attoparsec.Internal as I +import qualified Data.ByteString as B +import Data.Attoparsec.ByteString.Internal (Result, parse) +import qualified Data.Attoparsec.Internal.Types as T + +-- $parsec +-- +-- Compared to Parsec 3, attoparsec makes several tradeoffs. It is +-- not intended for, or ideal for, all possible uses. +-- +-- * While attoparsec can consume input incrementally, Parsec cannot. +-- Incremental input is a huge deal for efficient and secure network +-- and system programming, since it gives much more control to users +-- of the library over matters such as resource usage and the I/O +-- model to use. +-- +-- * Much of the performance advantage of attoparsec is gained via +-- high-performance parsers such as 'I.takeWhile' and 'I.string'. +-- If you use complicated combinators that return lists of bytes or +-- characters, there is less performance difference between the two +-- libraries. +-- +-- * Unlike Parsec 3, attoparsec does not support being used as a +-- monad transformer. +-- +-- * attoparsec is specialised to deal only with strict 'B.ByteString' +-- input. Efficiency concerns rule out both lists and lazy +-- bytestrings. The usual use for lazy bytestrings would be to +-- allow consumption of very large input without a large footprint. +-- For this need, attoparsec's incremental input provides an +-- excellent substitute, with much more control over when input +-- takes place. If you must use lazy bytestrings, see the +-- "Data.Attoparsec.ByteString.Lazy" module, which feeds lazy chunks +-- to a regular parser. +-- +-- * Parsec parsers can produce more helpful error messages than +-- attoparsec parsers. This is a matter of focus: attoparsec avoids +-- the extra book-keeping in favour of higher performance. + +-- $incremental +-- +-- attoparsec supports incremental input, meaning that you can feed it +-- a bytestring that represents only part of the expected total amount +-- of data to parse. If your parser reaches the end of a fragment of +-- input and could consume more input, it will suspend parsing and +-- return a 'T.Partial' continuation. +-- +-- Supplying the 'T.Partial' continuation with a bytestring will +-- resume parsing at the point where it was suspended, with the +-- bytestring you supplied used as new input at the end of the +-- existing input. You must be prepared for the result of the resumed +-- parse to be another 'T.Partial' continuation. +-- +-- To indicate that you have no more input, supply the 'T.Partial' +-- continuation with an empty bytestring. +-- +-- Remember that some parsing combinators will not return a result +-- until they reach the end of input. They may thus cause 'T.Partial' +-- results to be returned. +-- +-- If you do not need support for incremental input, consider using +-- the 'I.parseOnly' function to run your parser. It will never +-- prompt for more input. +-- +-- /Note/: incremental input does /not/ imply that attoparsec will +-- release portions of its internal state for garbage collection as it +-- proceeds. Its internal representation is equivalent to a single +-- 'ByteString': if you feed incremental input to a parser, it will +-- require memory proportional to the amount of input you supply. +-- (This is necessary to support arbitrary backtracking.) + +-- $performance +-- +-- If you write an attoparsec-based parser carefully, it can be +-- realistic to expect it to perform similarly to a hand-rolled C +-- parser (measuring megabytes parsed per second). +-- +-- To actually achieve high performance, there are a few guidelines +-- that it is useful to follow. +-- +-- Use the 'B.ByteString'-oriented parsers whenever possible, +-- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'. There is +-- about a factor of 100 difference in performance between the two +-- kinds of parser. +-- +-- For very simple byte-testing predicates, write them by hand instead +-- of using 'I.inClass' or 'I.notInClass'. For instance, both of +-- these predicates test for an end-of-line byte, but the first is +-- much faster than the second: +-- +-- >endOfLine_fast w = w == 13 || w == 10 +-- >endOfLine_slow = inClass "\r\n" +-- +-- Make active use of benchmarking and profiling tools to measure, +-- find the problems with, and improve the performance of your parser. + +-- | Run a parser and print its result to standard output. +parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO () +parseTest p s = print (parse p s) + +-- | Run a parser with an initial input string, and a monadic action +-- that can supply more input if needed. +parseWith :: Monad m => + (m B.ByteString) + -- ^ An action that will be executed to provide the parser + -- with more input, if necessary. The action must return an + -- 'B.empty' string when there is no more input available. + -> I.Parser a + -> B.ByteString + -- ^ Initial input for the parser. + -> m (Result a) +parseWith refill p s = step $ parse p s + where step (T.Partial k) = (step . k) =<< refill + step r = return r +{-# INLINE parseWith #-} + +-- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result +-- is treated as failure. +maybeResult :: Result r -> Maybe r +maybeResult (T.Done _ r) = Just r +maybeResult _ = Nothing + +-- | Convert a 'Result' value to an 'Either' value. A 'T.Partial' +-- result is treated as failure. +eitherResult :: Result r -> Either String r +eitherResult (T.Done _ r) = Right r +eitherResult (T.Fail _ _ msg) = Left msg +eitherResult _ = Left "Result: incomplete input" diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Buffer.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Buffer.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Buffer.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Data.Attoparsec.ByteString.Buffer +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- An "immutable" buffer that supports cheap appends. +-- +-- A Buffer is divided into an immutable read-only zone, followed by a +-- mutable area that we've preallocated, but not yet written to. +-- +-- We overallocate at the end of a Buffer so that we can cheaply +-- append. Since a user of an existing Buffer cannot see past the end +-- of its immutable zone into the data that will change during an +-- append, this is safe. +-- +-- Once we run out of space at the end of a Buffer, we do the usual +-- doubling of the buffer size. +-- +-- The fact of having a mutable buffer really helps with performance, +-- but it does have a consequence: if someone misuses the Partial API +-- that attoparsec uses by calling the same continuation repeatedly +-- (which never makes sense in practice), they could overwrite data. +-- +-- Since the API *looks* pure, it should *act* pure, too, so we use +-- two generation counters (one mutable, one immutable) to track the +-- number of appends to a mutable buffer. If the counters ever get out +-- of sync, someone is appending twice to a mutable buffer, so we +-- duplicate the entire buffer in order to preserve the immutability +-- of its older self. +-- +-- While we could go a step further and gain protection against API +-- abuse on a multicore system, by use of an atomic increment +-- instruction to bump the mutable generation counter, that would be +-- very expensive, and feels like it would also be in the realm of the +-- ridiculous. Clients should never call a continuation more than +-- once; we lack a linear type system that could enforce this; and +-- there's only so far we should go to accommodate broken uses. + +module Data.Attoparsec.ByteString.Buffer + ( + Buffer + , buffer + , unbuffer + , pappend + , length + , unsafeIndex + , substring + , unsafeDrop + ) where + +import Control.Exception (assert) +import Data.ByteString.Internal (ByteString(..), memcpy, nullForeignPtr) +import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO) +import Data.List (foldl1') +import Data.Monoid (Monoid(..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (castPtr, plusPtr) +import Foreign.Storable (peek, peekByteOff, poke, sizeOf) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import Prelude hiding (length) + +data Buffer = Buf { + _fp :: {-# UNPACK #-} !(ForeignPtr Word8) + , _off :: {-# UNPACK #-} !Int + , _len :: {-# UNPACK #-} !Int + , _cap :: {-# UNPACK #-} !Int + , _gen :: {-# UNPACK #-} !Int + } + +instance Show Buffer where + showsPrec p = showsPrec p . unbuffer + +-- | The initial 'Buffer' has no mutable zone, so we can avoid all +-- copies in the (hopefully) common case of no further input being fed +-- to us. +buffer :: ByteString -> Buffer +buffer (PS fp off len) = Buf fp off len len 0 + +unbuffer :: Buffer -> ByteString +unbuffer (Buf fp off len _ _) = PS fp off len + +instance Monoid Buffer where + mempty = Buf nullForeignPtr 0 0 0 0 + + mappend (Buf _ _ _ 0 _) b = b + mappend a (Buf _ _ _ 0 _) = a + mappend buf (Buf fp off len _ _) = append buf fp off len + + mconcat [] = mempty + mconcat xs = foldl1' mappend xs + +pappend :: Buffer -> ByteString -> Buffer +pappend (Buf _ _ _ 0 _) (PS fp off len) = Buf fp off len 0 0 +pappend buf (PS fp off len) = append buf fp off len + +append :: Buffer -> ForeignPtr a -> Int -> Int -> Buffer +append (Buf fp0 off0 len0 cap0 gen0) !fp1 !off1 !len1 = + inlinePerformIO . withForeignPtr fp0 $ \ptr0 -> + withForeignPtr fp1 $ \ptr1 -> do + let genSize = sizeOf (0::Int) + newlen = len0 + len1 + gen <- if gen0 == 0 + then return 0 + else peek (castPtr ptr0) + if gen == gen0 && newlen <= cap0 + then do + let newgen = gen + 1 + poke (castPtr ptr0) newgen + memcpy (ptr0 `plusPtr` (off0+len0)) + (ptr1 `plusPtr` off1) + (fromIntegral len1) + return (Buf fp0 off0 newlen cap0 newgen) + else do + let newcap = newlen * 2 + fp <- mallocPlainForeignPtrBytes (newcap + genSize) + withForeignPtr fp $ \ptr_ -> do + let ptr = ptr_ `plusPtr` genSize + newgen = 1 + poke (castPtr ptr_) newgen + memcpy ptr (ptr0 `plusPtr` off0) (fromIntegral len0) + memcpy (ptr `plusPtr` len0) (ptr1 `plusPtr` off1) + (fromIntegral len1) + return (Buf fp genSize newlen newcap newgen) + +length :: Buffer -> Int +length (Buf _ _ len _ _) = len +{-# INLINE length #-} + +unsafeIndex :: Buffer -> Int -> Word8 +unsafeIndex (Buf fp off len _ _) i = assert (i >= 0 && i < len) . + inlinePerformIO . withForeignPtr fp $ flip peekByteOff (off+i) +{-# INLINE unsafeIndex #-} + +substring :: Int -> Int -> Buffer -> ByteString +substring s l (Buf fp off len _ _) = + assert (s >= 0 && s <= len) . + assert (l >= 0 && l <= len-s) $ + PS fp (off+s) l +{-# INLINE substring #-} + +unsafeDrop :: Int -> Buffer -> ByteString +unsafeDrop s (Buf fp off len _ _) = + assert (s >= 0 && s <= len) $ + PS fp (off+s) (len-s) +{-# INLINE unsafeDrop #-} diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Char8.hs @@ -0,0 +1,469 @@ +{-# LANGUAGE BangPatterns, FlexibleInstances, TypeFamilies, + TypeSynonymInstances, GADTs #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-warnings-deprecations #-} + +-- | +-- Module : Data.Attoparsec.ByteString.Char8 +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient, character-oriented combinator parsing for +-- 'B.ByteString' strings, loosely based on the Parsec library. + +module Data.Attoparsec.ByteString.Char8 + ( + -- * Character encodings + -- $encodings + + -- * Parser types + Parser + , A.Result + , A.IResult(..) + , I.compareResults + + -- * Running parsers + , A.parse + , A.feed + , A.parseOnly + , A.parseWith + , A.parseTest + + -- ** Result conversion + , A.maybeResult + , A.eitherResult + + -- * Parsing individual characters + , char + , char8 + , anyChar + , notChar + , satisfy + + -- ** Lookahead + , peekChar + , peekChar' + + -- ** Special character parsers + , digit + , letter_iso8859_15 + , letter_ascii + , space + + -- ** Fast predicates + , isDigit + , isDigit_w8 + , isAlpha_iso8859_15 + , isAlpha_ascii + , isSpace + , isSpace_w8 + + -- *** Character classes + , inClass + , notInClass + + -- * Efficient string handling + , I.string + , stringCI + , skipSpace + , skipWhile + , I.take + , scan + , takeWhile + , takeWhile1 + , takeTill + + -- ** String combinators + -- $specalt + , (.*>) + , (<*.) + + -- ** Consume all remaining input + , I.takeByteString + , I.takeLazyByteString + + -- * Text parsing + , I.endOfLine + , isEndOfLine + , isHorizontalSpace + + -- * Numeric parsers + , decimal + , hexadecimal + , signed + , Number(..) + + -- * Combinators + , try + , () + , choice + , count + , option + , many' + , many1 + , many1' + , manyTill + , manyTill' + , sepBy + , sepBy' + , sepBy1 + , sepBy1' + , skipMany + , skipMany1 + , eitherP + , I.match + -- * State observation and manipulation functions + , I.endOfInput + , I.atEnd + ) where + +import Control.Applicative ((*>), (<*), (<$>), (<|>)) +import Data.Attoparsec.ByteString.FastSet (charClass, memberChar) +import Data.Attoparsec.ByteString.Internal (Parser) +import Data.Attoparsec.Combinator +import Data.Attoparsec.Number (Number(..)) +import Data.Bits (Bits, (.|.), shiftL) +import Data.ByteString.Internal (c2w, w2c) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.String (IsString(..)) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Prelude hiding (takeWhile) +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Internal as I +import qualified Data.Attoparsec.Internal as I +import qualified Data.ByteString as B8 +import qualified Data.ByteString.Char8 as B + +instance (a ~ B.ByteString) => IsString (Parser a) where + fromString = I.string . B.pack + +-- $encodings +-- +-- This module is intended for parsing text that is +-- represented using an 8-bit character set, e.g. ASCII or +-- ISO-8859-15. It /does not/ make any attempt to deal with character +-- encodings, multibyte characters, or wide characters. In +-- particular, all attempts to use characters above code point U+00FF +-- will give wrong answers. +-- +-- Code points below U+0100 are simply translated to and from their +-- numeric values, so e.g. the code point U+00A4 becomes the byte +-- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic +-- currency sign in ISO-8859-1). Haskell 'Char' values above U+00FF +-- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@. + +-- ASCII-specific but fast, oh yes. +toLower :: Word8 -> Word8 +toLower w | w >= 65 && w <= 90 = w + 32 + | otherwise = w + +-- | Satisfy a literal string, ignoring case. +stringCI :: B.ByteString -> Parser B.ByteString +stringCI = I.stringTransform (B8.map toLower) +{-# INLINE stringCI #-} + +-- | Consume input as long as the predicate returns 'True', and return +-- the consumed input. +-- +-- This parser requires the predicate to succeed on at least one byte +-- of input: it will fail if the predicate never returns 'True' or if +-- there is no input left. +takeWhile1 :: (Char -> Bool) -> Parser B.ByteString +takeWhile1 p = I.takeWhile1 (p . w2c) +{-# INLINE takeWhile1 #-} + +-- | The parser @satisfy p@ succeeds for any byte for which the +-- predicate @p@ returns 'True'. Returns the byte that is actually +-- parsed. +-- +-- >digit = satisfy isDigit +-- > where isDigit c = c >= '0' && c <= '9' +satisfy :: (Char -> Bool) -> Parser Char +satisfy = I.satisfyWith w2c +{-# INLINE satisfy #-} + +-- | Match a letter, in the ISO-8859-15 encoding. +letter_iso8859_15 :: Parser Char +letter_iso8859_15 = satisfy isAlpha_iso8859_15 "letter_iso8859_15" +{-# INLINE letter_iso8859_15 #-} + +-- | Match a letter, in the ASCII encoding. +letter_ascii :: Parser Char +letter_ascii = satisfy isAlpha_ascii "letter_ascii" +{-# INLINE letter_ascii #-} + +-- | A fast alphabetic predicate for the ISO-8859-15 encoding +-- +-- /Note/: For all character encodings other than ISO-8859-15, and +-- almost all Unicode code points above U+00A3, this predicate gives +-- /wrong answers/. +isAlpha_iso8859_15 :: Char -> Bool +isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || + (c >= '\166' && moby c) + where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247" + {-# NOINLINE moby #-} +{-# INLINE isAlpha_iso8859_15 #-} + +-- | A fast alphabetic predicate for the ASCII encoding +-- +-- /Note/: For all character encodings other than ASCII, and +-- almost all Unicode code points above U+007F, this predicate gives +-- /wrong answers/. +isAlpha_ascii :: Char -> Bool +isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') +{-# INLINE isAlpha_ascii #-} + +-- | Parse a single digit. +digit :: Parser Char +digit = satisfy isDigit "digit" +{-# INLINE digit #-} + +-- | A fast digit predicate. +isDigit :: Char -> Bool +isDigit c = c >= '0' && c <= '9' +{-# INLINE isDigit #-} + +-- | A fast digit predicate. +isDigit_w8 :: Word8 -> Bool +isDigit_w8 w = w >= 48 && w <= 57 +{-# INLINE isDigit_w8 #-} + +-- | Match any character. +anyChar :: Parser Char +anyChar = satisfy $ const True +{-# INLINE anyChar #-} + +-- | Match any character, to perform lookahead. Returns 'Nothing' if +-- end of input has been reached. Does not consume any input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'many', because such parsers loop until a +-- failure occurs. Careless use will thus result in an infinite loop. +peekChar :: Parser (Maybe Char) +peekChar = (fmap w2c) `fmap` I.peekWord8 +{-# INLINE peekChar #-} + +-- | Match any character, to perform lookahead. Does not consume any +-- input, but will fail if end of input has been reached. +peekChar' :: Parser Char +peekChar' = w2c `fmap` I.peekWord8' +{-# INLINE peekChar' #-} + +-- | Fast predicate for matching ASCII space characters. +-- +-- /Note/: This predicate only gives correct answers for the ASCII +-- encoding. For instance, it does not recognise U+00A0 (non-breaking +-- space) as a space character, even though it is a valid ISO-8859-15 +-- byte. For a Unicode-aware and only slightly slower predicate, +-- use 'Data.Char.isSpace' +isSpace :: Char -> Bool +isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') +{-# INLINE isSpace #-} + +-- | Fast 'Word8' predicate for matching ASCII space characters. +isSpace_w8 :: Word8 -> Bool +isSpace_w8 w = (w == 32) || (9 <= w && w <= 13) +{-# INLINE isSpace_w8 #-} + + +-- | Parse a space character. +-- +-- /Note/: This parser only gives correct answers for the ASCII +-- encoding. For instance, it does not recognise U+00A0 (non-breaking +-- space) as a space character, even though it is a valid ISO-8859-15 +-- byte. +space :: Parser Char +space = satisfy isSpace "space" +{-# INLINE space #-} + +-- | Match a specific character. +char :: Char -> Parser Char +char c = satisfy (== c) [c] +{-# INLINE char #-} + +-- | Match a specific character, but return its 'Word8' value. +char8 :: Char -> Parser Word8 +char8 c = I.satisfy (== c2w c) [c] +{-# INLINE char8 #-} + +-- | Match any character except the given one. +notChar :: Char -> Parser Char +notChar c = satisfy (/= c) "not " ++ [c] +{-# INLINE notChar #-} + +-- | Match any character in a set. +-- +-- >vowel = inClass "aeiou" +-- +-- Range notation is supported. +-- +-- >halfAlphabet = inClass "a-nA-N" +-- +-- To add a literal \'-\' to a set, place it at the beginning or end +-- of the string. +inClass :: String -> Char -> Bool +inClass s = (`memberChar` mySet) + where mySet = charClass s +{-# INLINE inClass #-} + +-- | Match any character not in a set. +notInClass :: String -> Char -> Bool +notInClass s = not . inClass s +{-# INLINE notInClass #-} + +-- | Consume input as long as the predicate returns 'True', and return +-- the consumed input. +-- +-- This parser does not fail. It will return an empty string if the +-- predicate returns 'False' on the first byte of input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'many', because such parsers loop until a +-- failure occurs. Careless use will thus result in an infinite loop. +takeWhile :: (Char -> Bool) -> Parser B.ByteString +takeWhile p = I.takeWhile (p . w2c) +{-# INLINE takeWhile #-} + +-- | A stateful scanner. The predicate consumes and transforms a +-- state argument, and each transformed state is passed to successive +-- invocations of the predicate on each byte of the input until one +-- returns 'Nothing' or the input ends. +-- +-- This parser does not fail. It will return an empty string if the +-- predicate returns 'Nothing' on the first byte of input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'many', because such parsers loop until a +-- failure occurs. Careless use will thus result in an infinite loop. +scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString +scan s0 p = I.scan s0 (\s -> p s . w2c) +{-# INLINE scan #-} + +-- | Consume input as long as the predicate returns 'False' +-- (i.e. until it returns 'True'), and return the consumed input. +-- +-- This parser does not fail. It will return an empty string if the +-- predicate returns 'True' on the first byte of input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'many', because such parsers loop until a +-- failure occurs. Careless use will thus result in an infinite loop. +takeTill :: (Char -> Bool) -> Parser B.ByteString +takeTill p = I.takeTill (p . w2c) +{-# INLINE takeTill #-} + +-- | Skip past input for as long as the predicate returns 'True'. +skipWhile :: (Char -> Bool) -> Parser () +skipWhile p = I.skipWhile (p . w2c) +{-# INLINE skipWhile #-} + +-- | Skip over white space. +skipSpace :: Parser () +skipSpace = I.skipWhile isSpace_w8 +{-# INLINE skipSpace #-} + +-- $specalt +-- +-- If you enable the @OverloadedStrings@ language extension, you can +-- use the '*>' and '<*' combinators to simplify the common task of +-- matching a statically known string, then immediately parsing +-- something else. +-- +-- Instead of writing something like this: +-- +-- @ +--'I.string' \"foo\" '*>' wibble +-- @ +-- +-- Using @OverloadedStrings@, you can omit the explicit use of +-- 'I.string', and write a more compact version: +-- +-- @ +-- \"foo\" '*>' wibble +-- @ +-- +-- (Note: the '.*>' and '<*.' combinators that were originally +-- provided for this purpose are obsolete and unnecessary, and will be +-- removed in the next major version.) + +-- | /Obsolete/. A type-specialized version of '*>' for +-- 'B.ByteString'. Use '*>' instead. +(.*>) :: B.ByteString -> Parser a -> Parser a +s .*> f = I.string s *> f +{-# DEPRECATED (.*>) "This is no longer necessary, and will be removed. Use '*>' instead." #-} + +-- | /Obsolete/. A type-specialized version of '<*' for +-- 'B.ByteString'. Use '<*' instead. +(<*.) :: Parser a -> B.ByteString -> Parser a +f <*. s = f <* I.string s +{-# DEPRECATED (<*.) "This is no longer necessary, and will be removed. Use '<*' instead." #-} + +-- | A predicate that matches either a carriage return @\'\\r\'@ or +-- newline @\'\\n\'@ character. +isEndOfLine :: Word8 -> Bool +isEndOfLine w = w == 13 || w == 10 +{-# INLINE isEndOfLine #-} + +-- | A predicate that matches either a space @\' \'@ or horizontal tab +-- @\'\\t\'@ character. +isHorizontalSpace :: Word8 -> Bool +isHorizontalSpace w = w == 32 || w == 9 +{-# INLINE isHorizontalSpace #-} + +-- | Parse and decode an unsigned hexadecimal number. The hex digits +-- @\'a\'@ through @\'f\'@ may be upper or lower case. +-- +-- This parser does not accept a leading @\"0x\"@ string. +hexadecimal :: (Integral a, Bits a) => Parser a +hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit + where + isHexDigit w = (w >= 48 && w <= 57) || + (w >= 97 && w <= 102) || + (w >= 65 && w <= 70) + step a w | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48) + | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87) + | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55) +{-# SPECIALISE hexadecimal :: Parser Int #-} +{-# SPECIALISE hexadecimal :: Parser Int8 #-} +{-# SPECIALISE hexadecimal :: Parser Int16 #-} +{-# SPECIALISE hexadecimal :: Parser Int32 #-} +{-# SPECIALISE hexadecimal :: Parser Int64 #-} +{-# SPECIALISE hexadecimal :: Parser Integer #-} +{-# SPECIALISE hexadecimal :: Parser Word #-} +{-# SPECIALISE hexadecimal :: Parser Word8 #-} +{-# SPECIALISE hexadecimal :: Parser Word16 #-} +{-# SPECIALISE hexadecimal :: Parser Word32 #-} +{-# SPECIALISE hexadecimal :: Parser Word64 #-} + +-- | Parse and decode an unsigned decimal number. +decimal :: Integral a => Parser a +decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig + where isDig w = w >= 48 && w <= 57 + step a w = a * 10 + fromIntegral (w - 48) +{-# SPECIALISE decimal :: Parser Int #-} +{-# SPECIALISE decimal :: Parser Int8 #-} +{-# SPECIALISE decimal :: Parser Int16 #-} +{-# SPECIALISE decimal :: Parser Int32 #-} +{-# SPECIALISE decimal :: Parser Int64 #-} +{-# SPECIALISE decimal :: Parser Integer #-} +{-# SPECIALISE decimal :: Parser Word #-} +{-# SPECIALISE decimal :: Parser Word8 #-} +{-# SPECIALISE decimal :: Parser Word16 #-} +{-# SPECIALISE decimal :: Parser Word32 #-} +{-# SPECIALISE decimal :: Parser Word64 #-} + +-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign +-- character. +signed :: Num a => Parser a -> Parser a +{-# SPECIALISE signed :: Parser Int -> Parser Int #-} +{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-} +{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-} +{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-} +{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-} +{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-} +signed p = (negate <$> (char8 '-' *> p)) + <|> (char8 '+' *> p) + <|> p diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/FastSet.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/FastSet.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/FastSet.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Attoparsec.ByteString.FastSet +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Fast set membership tests for 'Word8' and 8-bit 'Char' values. The +-- set representation is unboxed for efficiency. For small sets, we +-- test for membership using a binary search. For larger sets, we use +-- a lookup table. +-- +----------------------------------------------------------------------------- +module Data.Attoparsec.ByteString.FastSet + ( + -- * Data type + FastSet + -- * Construction + , fromList + , set + -- * Lookup + , memberChar + , memberWord8 + -- * Debugging + , fromSet + -- * Handy interface + , charClass + ) where + +import Data.Bits ((.&.), (.|.)) +import Foreign.Storable (peekByteOff, pokeByteOff) +import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#) +import GHC.Word (Word8(W8#)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Internal as I +import qualified Data.ByteString.Unsafe as U + +data FastSet = Sorted { fromSet :: !B.ByteString } + | Table { fromSet :: !B.ByteString } + deriving (Eq, Ord) + +instance Show FastSet where + show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s) + show (Table _) = "FastSet Table" + +-- | The lower bound on the size of a lookup table. We choose this to +-- balance table density against performance. +tableCutoff :: Int +tableCutoff = 8 + +-- | Create a set. +set :: B.ByteString -> FastSet +set s | B.length s < tableCutoff = Sorted . B.sort $ s + | otherwise = Table . mkTable $ s + +fromList :: [Word8] -> FastSet +fromList = set . B.pack + +data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8 + +shiftR :: Int -> Int -> Int +shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) + +shiftL :: Word8 -> Int -> Word8 +shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#)) + +index :: Int -> I +index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7)) +{-# INLINE index #-} + +-- | Check the set for membership. +memberWord8 :: Word8 -> FastSet -> Bool +memberWord8 w (Table t) = + let I byte bit = index (fromIntegral w) + in U.unsafeIndex t byte .&. bit /= 0 +memberWord8 w (Sorted s) = search 0 (B.length s - 1) + where search lo hi + | hi < lo = False + | otherwise = + let mid = (lo + hi) `quot` 2 + in case compare w (U.unsafeIndex s mid) of + GT -> search (mid + 1) hi + LT -> search lo (mid - 1) + _ -> True + +-- | Check the set for membership. Only works with 8-bit characters: +-- characters above code point 255 will give wrong answers. +memberChar :: Char -> FastSet -> Bool +memberChar c = memberWord8 (I.c2w c) +{-# INLINE memberChar #-} + +mkTable :: B.ByteString -> B.ByteString +mkTable s = I.unsafeCreate 32 $ \t -> do + _ <- I.memset t 0 32 + U.unsafeUseAsCStringLen s $ \(p, l) -> + let loop n | n == l = return () + | otherwise = do + c <- peekByteOff p n :: IO Word8 + let I byte bit = index (fromIntegral c) + prev <- peekByteOff t byte :: IO Word8 + pokeByteOff t byte (prev .|. bit) + loop (n + 1) + in loop 0 + +charClass :: String -> FastSet +charClass = set . B8.pack . go + where go (a:'-':b:xs) = [a..b] ++ go xs + go (x:xs) = x : go xs + go _ = "" diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Internal.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Internal.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/ByteString/Internal.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings, RecordWildCards #-} +-- | +-- Module : Data.Attoparsec.ByteString.Internal +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient parser combinators for 'ByteString' strings, +-- loosely based on the Parsec library. + +module Data.Attoparsec.ByteString.Internal + ( + -- * Parser types + Parser + , Result + + -- * Running parsers + , parse + , parseOnly + + -- * Combinators + , module Data.Attoparsec.Combinator + + -- * Parsing individual bytes + , satisfy + , satisfyWith + , anyWord8 + , skip + , word8 + , notWord8 + + -- ** Lookahead + , peekWord8 + , peekWord8' + + -- ** Byte classes + , inClass + , notInClass + + -- * Parsing more complicated structures + , storable + + -- * Efficient string handling + , skipWhile + , string + , stringTransform + , take + , scan + , runScanner + , takeWhile + , takeWhile1 + , takeTill + + -- ** Consume all remaining input + , takeByteString + , takeLazyByteString + + -- * Utilities + , endOfLine + , endOfInput + , match + , atEnd + ) where + +import Control.Applicative ((<|>), (<$>)) +import Control.Monad (when) +import Data.Attoparsec.ByteString.Buffer (Buffer, buffer) +import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8) +import Data.Attoparsec.Combinator (()) +import Data.Attoparsec.Internal +import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO) +import Data.Attoparsec.Internal.Types hiding (Parser, Failure, Success) +import Data.ByteString (ByteString) +import Data.Word (Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (castPtr, minusPtr, plusPtr) +import Foreign.Storable (Storable(peek, sizeOf)) +import Prelude hiding (getChar, succ, take, takeWhile) +import qualified Data.Attoparsec.ByteString.Buffer as Buf +import qualified Data.Attoparsec.Internal.Types as T +import qualified Data.ByteString as B8 +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Unsafe as B + +type Parser = T.Parser ByteString +type Result = IResult ByteString +type Failure r = T.Failure ByteString Buffer r +type Success a r = T.Success ByteString Buffer a r + +-- | The parser @satisfy p@ succeeds for any byte for which the +-- predicate @p@ returns 'True'. Returns the byte that is actually +-- parsed. +-- +-- >digit = satisfy isDigit +-- > where isDigit w = w >= 48 && w <= 57 +satisfy :: (Word8 -> Bool) -> Parser Word8 +satisfy p = do + h <- peekWord8' + if p h + then advance 1 >> return h + else fail "satisfy" +{-# INLINE satisfy #-} + +-- | The parser @skip p@ succeeds for any byte for which the predicate +-- @p@ returns 'True'. +-- +-- >skipDigit = skip isDigit +-- > where isDigit w = w >= 48 && w <= 57 +skip :: (Word8 -> Bool) -> Parser () +skip p = do + h <- peekWord8' + if p h + then advance 1 + else fail "skip" + +-- | The parser @satisfyWith f p@ transforms a byte, and succeeds if +-- the predicate @p@ returns 'True' on the transformed value. The +-- parser returns the transformed byte that was parsed. +satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a +satisfyWith f p = do + h <- peekWord8' + let c = f h + if p c + then advance 1 >> return c + else fail "satisfyWith" +{-# INLINE satisfyWith #-} + +storable :: Storable a => Parser a +storable = hack undefined + where + hack :: Storable b => b -> Parser b + hack dummy = do + (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy) + return . B.inlinePerformIO . withForeignPtr fp $ \p -> + peek (castPtr $ p `plusPtr` o) + +-- | Consume @n@ bytes of input, but succeed only if the predicate +-- returns 'True'. +takeWith :: Int -> (ByteString -> Bool) -> Parser ByteString +takeWith n0 p = do + let n = max n0 0 + s <- ensure n + if p s + then advance n >> return s + else fail "takeWith" + +-- | Consume exactly @n@ bytes of input. +take :: Int -> Parser ByteString +take n = takeWith n (const True) +{-# INLINE take #-} + +-- | @string s@ parses a sequence of bytes that identically match +-- @s@. Returns the parsed string (i.e. @s@). This parser consumes no +-- input if it fails (even if a partial match). +-- +-- /Note/: The behaviour of this parser is different to that of the +-- similarly-named parser in Parsec, as this one is all-or-nothing. +-- To illustrate the difference, the following parser will fail under +-- Parsec given an input of @\"for\"@: +-- +-- >string "foo" <|> string "for" +-- +-- The reason for its failure is that the first branch is a +-- partial match, and will consume the letters @\'f\'@ and @\'o\'@ +-- before failing. In attoparsec, the above parser will /succeed/ on +-- that input, because the failed first branch will consume nothing. +string :: ByteString -> Parser ByteString +string s = takeWith (B.length s) (==s) +{-# INLINE string #-} + +stringTransform :: (ByteString -> ByteString) -> ByteString + -> Parser ByteString +stringTransform f s = takeWith (B.length s) ((==f s) . f) +{-# INLINE stringTransform #-} + +-- | Skip past input for as long as the predicate returns 'True'. +skipWhile :: (Word8 -> Bool) -> Parser () +skipWhile p = go + where + go = do + t <- B8.takeWhile p <$> get + continue <- inputSpansChunks (B.length t) + when continue go +{-# INLINE skipWhile #-} + +-- | Consume input as long as the predicate returns 'False' +-- (i.e. until it returns 'True'), and return the consumed input. +-- +-- This parser does not fail. It will return an empty string if the +-- predicate returns 'True' on the first byte of input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'Control.Applicative.many', because such +-- parsers loop until a failure occurs. Careless use will thus result +-- in an infinite loop. +takeTill :: (Word8 -> Bool) -> Parser ByteString +takeTill p = takeWhile (not . p) +{-# INLINE takeTill #-} + +-- | Consume input as long as the predicate returns 'True', and return +-- the consumed input. +-- +-- This parser does not fail. It will return an empty string if the +-- predicate returns 'False' on the first byte of input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'Control.Applicative.many', because such +-- parsers loop until a failure occurs. Careless use will thus result +-- in an infinite loop. +takeWhile :: (Word8 -> Bool) -> Parser ByteString +takeWhile p = (B.concat . reverse) `fmap` go [] + where + go acc = do + s <- B8.takeWhile p <$> get + continue <- inputSpansChunks (B.length s) + if continue + then go (s:acc) + else return (s:acc) +{-# INLINE takeWhile #-} + +takeRest :: Parser [ByteString] +takeRest = go [] + where + go acc = do + input <- wantInput + if input + then do + s <- get + advance (B.length s) + go (s:acc) + else return (reverse acc) + +-- | Consume all remaining input and return it as a single string. +takeByteString :: Parser ByteString +takeByteString = B.concat `fmap` takeRest + +-- | Consume all remaining input and return it as a single string. +takeLazyByteString :: Parser L.ByteString +takeLazyByteString = L.fromChunks `fmap` takeRest + +data T s = T {-# UNPACK #-} !Int s + +scan_ :: (s -> [ByteString] -> Parser r) -> s -> (s -> Word8 -> Maybe s) + -> Parser r +scan_ f s0 p = go [] s0 + where + go acc s1 = do + let scanner (B.PS fp off len) = + withForeignPtr fp $ \ptr0 -> do + let start = ptr0 `plusPtr` off + end = start `plusPtr` len + inner ptr !s + | ptr < end = do + w <- peek ptr + case p s w of + Just s' -> inner (ptr `plusPtr` 1) s' + _ -> done (ptr `minusPtr` start) s + | otherwise = done (ptr `minusPtr` start) s + done !i !s = return (T i s) + inner start s1 + bs <- get + let T i s' = inlinePerformIO $ scanner bs + !h = B.unsafeTake i bs + continue <- inputSpansChunks i + if continue + then go (h:acc) s' + else f s' (h:acc) +{-# INLINE scan_ #-} + +-- | A stateful scanner. The predicate consumes and transforms a +-- state argument, and each transformed state is passed to successive +-- invocations of the predicate on each byte of the input until one +-- returns 'Nothing' or the input ends. +-- +-- This parser does not fail. It will return an empty string if the +-- predicate returns 'Nothing' on the first byte of input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'Control.Applicative.many', because such +-- parsers loop until a failure occurs. Careless use will thus result +-- in an infinite loop. +scan :: s -> (s -> Word8 -> Maybe s) -> Parser ByteString +scan = scan_ $ \_ chunks -> + case chunks of + [x] -> return x + xs -> return $! B.concat $ reverse xs +{-# INLINE scan #-} + +-- | Like 'scan', but generalized to return the final state of the +-- scanner. +runScanner :: s -> (s -> Word8 -> Maybe s) -> Parser (ByteString, s) +runScanner = scan_ $ \s xs -> return (B.concat (reverse xs), s) +{-# INLINE runScanner #-} + +-- | Consume input as long as the predicate returns 'True', and return +-- the consumed input. +-- +-- This parser requires the predicate to succeed on at least one byte +-- of input: it will fail if the predicate never returns 'True' or if +-- there is no input left. +takeWhile1 :: (Word8 -> Bool) -> Parser ByteString +takeWhile1 p = do + (`when` demandInput) =<< endOfChunk + s <- B8.takeWhile p <$> get + let len = B.length s + if len == 0 + then fail "takeWhile1" + else do + advance len + eoc <- endOfChunk + if eoc + then (s<>) `fmap` takeWhile p + else return s + +-- | Match any byte in a set. +-- +-- >vowel = inClass "aeiou" +-- +-- Range notation is supported. +-- +-- >halfAlphabet = inClass "a-nA-N" +-- +-- To add a literal @\'-\'@ to a set, place it at the beginning or end +-- of the string. +inClass :: String -> Word8 -> Bool +inClass s = (`memberWord8` mySet) + where mySet = charClass s + {-# NOINLINE mySet #-} +{-# INLINE inClass #-} + +-- | Match any byte not in a set. +notInClass :: String -> Word8 -> Bool +notInClass s = not . inClass s +{-# INLINE notInClass #-} + +-- | Match any byte. +anyWord8 :: Parser Word8 +anyWord8 = satisfy $ const True +{-# INLINE anyWord8 #-} + +-- | Match a specific byte. +word8 :: Word8 -> Parser Word8 +word8 c = satisfy (== c) show c +{-# INLINE word8 #-} + +-- | Match any byte except the given one. +notWord8 :: Word8 -> Parser Word8 +notWord8 c = satisfy (/= c) "not " ++ show c +{-# INLINE notWord8 #-} + +-- | Match any byte, to perform lookahead. Returns 'Nothing' if end of +-- input has been reached. Does not consume any input. +-- +-- /Note/: Because this parser does not fail, do not use it with +-- combinators such as 'Control.Applicative.many', because such +-- parsers loop until a failure occurs. Careless use will thus result +-- in an infinite loop. +peekWord8 :: Parser (Maybe Word8) +peekWord8 = T.Parser $ \t pos@(Pos pos_) more _lose succ -> + case () of + _| pos_ < Buf.length t -> + let !w = Buf.unsafeIndex t pos_ + in succ t pos more (Just w) + | more == Complete -> + succ t pos more Nothing + | otherwise -> + let succ' t' pos' more' = let !w = Buf.unsafeIndex t' pos_ + in succ t' pos' more' (Just w) + lose' t' pos' more' = succ t' pos' more' Nothing + in prompt t pos more lose' succ' +{-# INLINE peekWord8 #-} + +-- | Match any byte, to perform lookahead. Does not consume any +-- input, but will fail if end of input has been reached. +peekWord8' :: Parser Word8 +peekWord8' = T.Parser $ \t pos more lose succ -> + if lengthAtLeast pos 1 t + then succ t pos more (Buf.unsafeIndex t (fromPos pos)) + else let succ' t' pos' more' bs' = succ t' pos' more' $! B.unsafeHead bs' + in ensureSuspended 1 t pos more lose succ' +{-# INLINE peekWord8' #-} + +-- | Match either a single newline character @\'\\n\'@, or a carriage +-- return followed by a newline character @\"\\r\\n\"@. +endOfLine :: Parser () +endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ()) + +-- | Terminal failure continuation. +failK :: Failure a +failK t (Pos pos) _more stack msg = Fail (Buf.unsafeDrop pos t) stack msg +{-# INLINE failK #-} + +-- | Terminal success continuation. +successK :: Success a a +successK t (Pos pos) _more a = Done (Buf.unsafeDrop pos t) a +{-# INLINE successK #-} + +-- | Run a parser. +parse :: Parser a -> ByteString -> Result a +parse m s = T.runParser m (buffer s) (Pos 0) Incomplete failK successK +{-# INLINE parse #-} + +-- | Run a parser that cannot be resupplied via a 'Partial' result. +-- +-- This function does not force a parser to consume all of its input. +-- Instead, any residual input will be discarded. To force a parser +-- to consume all of its input, use something like this: +-- +-- @ +--'parseOnly' (myParser 'Control.Applicative.<*' 'endOfInput') +-- @ +parseOnly :: Parser a -> ByteString -> Either String a +parseOnly m s = case T.runParser m (buffer s) (Pos 0) Complete failK successK of + Fail _ _ err -> Left err + Done _ a -> Right a + _ -> error "parseOnly: impossible error!" +{-# INLINE parseOnly #-} + +get :: Parser ByteString +get = T.Parser $ \t pos more _lose succ -> + succ t pos more (Buf.unsafeDrop (fromPos pos) t) +{-# INLINE get #-} + +endOfChunk :: Parser Bool +endOfChunk = T.Parser $ \t pos more _lose succ -> + succ t pos more (fromPos pos == Buf.length t) +{-# INLINE endOfChunk #-} + +inputSpansChunks :: Int -> Parser Bool +inputSpansChunks i = T.Parser $ \t pos_ more _lose succ -> + let pos = pos_ + Pos i + in if fromPos pos < Buf.length t || more == Complete + then succ t pos more False + else let lose' t' pos' more' = succ t' pos' more' False + succ' t' pos' more' = succ t' pos' more' True + in prompt t pos more lose' succ' +{-# INLINE inputSpansChunks #-} + +advance :: Int -> Parser () +advance n = T.Parser $ \t pos more _lose succ -> + succ t (pos + Pos n) more () +{-# INLINE advance #-} + +ensureSuspended :: Int -> Buffer -> Pos -> More + -> Failure r + -> Success ByteString r + -> Result r +ensureSuspended n t pos more lose succ = + runParser (demandInput >> go) t pos more lose succ + where go = T.Parser $ \t' pos' more' lose' succ' -> + if lengthAtLeast pos' n t' + then succ' t' pos' more' (substring pos (Pos n) t') + else runParser (demandInput >> go) t' pos' more' lose' succ' + +-- | If at least @n@ elements of input are available, return the +-- current input, otherwise fail. +ensure :: Int -> Parser ByteString +ensure n = T.Parser $ \t pos more lose succ -> + if lengthAtLeast pos n t + then succ t pos more (substring pos (Pos n) t) + -- The uncommon case is kept out-of-line to reduce code size: + else ensureSuspended n t pos more lose succ +-- Non-recursive so the bounds check can be inlined: +{-# INLINE ensure #-} + +-- | Return both the result of a parse and the portion of the input +-- that was consumed while it was being parsed. +match :: Parser a -> Parser (ByteString, a) +match p = T.Parser $ \t pos more lose succ -> + let succ' t' pos' more' a = + succ t' pos' more' (substring pos (pos'-pos) t', a) + in runParser p t pos more lose succ' + +lengthAtLeast :: Pos -> Int -> Buffer -> Bool +lengthAtLeast (Pos pos) n bs = Buf.length bs >= pos + n +{-# INLINE lengthAtLeast #-} + +substring :: Pos -> Pos -> Buffer -> ByteString +substring (Pos pos) (Pos n) = Buf.substring pos n +{-# INLINE substring #-} diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Combinator.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Combinator.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Combinator.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE BangPatterns #-} +-- | +-- Module : Data.Attoparsec.Combinator +-- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : portable +-- +-- Useful parser combinators, similar to those provided by Parsec. +module Data.Attoparsec.Combinator + ( + -- * Combinators + try + , () + , choice + , count + , option + , many' + , many1 + , many1' + , manyTill + , manyTill' + , sepBy + , sepBy' + , sepBy1 + , sepBy1' + , skipMany + , skipMany1 + , eitherP + , feed + , satisfyElem + , endOfInput + , atEnd + ) where + +import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2, + many, (<|>), (*>), (<$>)) +import Control.Monad (MonadPlus(..)) +import Data.Attoparsec.Internal.Types (Parser(..), IResult(..)) +import Data.Attoparsec.Internal (endOfInput, atEnd, satisfyElem) +import Data.ByteString (ByteString) +import Data.Monoid (Monoid(mappend)) +import Prelude hiding (succ) + +-- | Attempt a parse, and if it fails, rewind the input so that no +-- input appears to have been consumed. +-- +-- This combinator is provided for compatibility with Parsec. +-- attoparsec parsers always backtrack on failure. +try :: Parser i a -> Parser i a +try p = p +{-# INLINE try #-} + +-- | Name the parser, in case failure occurs. +() :: Parser i a + -> String -- ^ the name to use if parsing fails + -> Parser i a +p msg0 = Parser $ \t pos more lose succ -> + let lose' t' pos' more' strs msg = lose t' pos' more' (msg0:strs) msg + in runParser p t pos more lose' succ +{-# INLINE () #-} +infix 0 + +-- | @choice ps@ tries to apply the actions in the list @ps@ in order, +-- until one of them succeeds. Returns the value of the succeeding +-- action. +choice :: Alternative f => [f a] -> f a +choice = foldr (<|>) empty +{-# SPECIALIZE choice :: [Parser ByteString a] + -> Parser ByteString a #-} + +-- | @option x p@ tries to apply action @p@. If @p@ fails without +-- consuming input, it returns the value @x@, otherwise the value +-- returned by @p@. +-- +-- > priority = option 0 (digitToInt <$> digit) +option :: Alternative f => a -> f a -> f a +option x p = p <|> pure x +{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-} + +-- | A version of 'liftM2' that is strict in the result of its first +-- action. +liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c +liftM2' f a b = do + !x <- a + y <- b + return (f x y) +{-# INLINE liftM2' #-} + +-- | @many' p@ applies the action @p@ /zero/ or more times. Returns a +-- list of the returned values of @p@. The value returned by @p@ is +-- forced to WHNF. +-- +-- > word = many' letter +many' :: (MonadPlus m) => m a -> m [a] +many' p = many_p + where many_p = some_p `mplus` return [] + some_p = liftM2' (:) p many_p +{-# INLINE many' #-} + +-- | @many1 p@ applies the action @p@ /one/ or more times. Returns a +-- list of the returned values of @p@. +-- +-- > word = many1 letter +many1 :: Alternative f => f a -> f [a] +many1 p = liftA2 (:) p (many p) +{-# INLINE many1 #-} + +-- | @many1' p@ applies the action @p@ /one/ or more times. Returns a +-- list of the returned values of @p@. The value returned by @p@ is +-- forced to WHNF. +-- +-- > word = many1' letter +many1' :: (MonadPlus m) => m a -> m [a] +many1' p = liftM2' (:) p (many' p) +{-# INLINE many1' #-} + +-- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of the values returned by @p@. +-- +-- > commaSep p = p `sepBy` (symbol ",") +sepBy :: Alternative f => f a -> f s -> f [a] +sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure [] +{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s + -> Parser ByteString [a] #-} + +-- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of the values returned by @p@. The value +-- returned by @p@ is forced to WHNF. +-- +-- > commaSep p = p `sepBy'` (symbol ",") +sepBy' :: (MonadPlus m) => m a -> m s -> m [a] +sepBy' p s = scan `mplus` return [] + where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return []) +{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s + -> Parser ByteString [a] #-} + +-- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of the values returned by @p@. +-- +-- > commaSep p = p `sepBy1` (symbol ",") +sepBy1 :: Alternative f => f a -> f s -> f [a] +sepBy1 p s = scan + where scan = liftA2 (:) p ((s *> scan) <|> pure []) +{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s + -> Parser ByteString [a] #-} + +-- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated +-- by @sep@. Returns a list of the values returned by @p@. The value +-- returned by @p@ is forced to WHNF. +-- +-- > commaSep p = p `sepBy1'` (symbol ",") +sepBy1' :: (MonadPlus m) => m a -> m s -> m [a] +sepBy1' p s = scan + where scan = liftM2' (:) p ((s >> scan) `mplus` return []) +{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s + -> Parser ByteString [a] #-} + +-- | @manyTill p end@ applies action @p@ /zero/ or more times until +-- action @end@ succeeds, and returns the list of values returned by +-- @p@. This can be used to scan comments: +-- +-- > simpleComment = string "") +-- +-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@. +-- While this will work, it is not very efficient, as it will cause a +-- lot of backtracking.) +manyTill :: Alternative f => f a -> f b -> f [a] +manyTill p end = scan + where scan = (end *> pure []) <|> liftA2 (:) p scan +{-# SPECIALIZE manyTill :: Parser ByteString a -> Parser ByteString b + -> Parser ByteString [a] #-} + +-- | @manyTill' p end@ applies action @p@ /zero/ or more times until +-- action @end@ succeeds, and returns the list of values returned by +-- @p@. This can be used to scan comments: +-- +-- > simpleComment = string "") +-- +-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@. +-- While this will work, it is not very efficient, as it will cause a +-- lot of backtracking.) +-- +-- The value returned by @p@ is forced to WHNF. +manyTill' :: (MonadPlus m) => m a -> m b -> m [a] +manyTill' p end = scan + where scan = (end >> return []) `mplus` liftM2' (:) p scan +{-# SPECIALIZE manyTill' :: Parser ByteString a -> Parser ByteString b + -> Parser ByteString [a] #-} + +-- | Skip zero or more instances of an action. +skipMany :: Alternative f => f a -> f () +skipMany p = scan + where scan = (p *> scan) <|> pure () +{-# SPECIALIZE skipMany :: Parser ByteString a -> Parser ByteString () #-} + +-- | Skip one or more instances of an action. +skipMany1 :: Alternative f => f a -> f () +skipMany1 p = p *> skipMany p +{-# SPECIALIZE skipMany1 :: Parser ByteString a -> Parser ByteString () #-} + +-- | Apply the given action repeatedly, returning every result. +count :: Monad m => Int -> m a -> m [a] +count n p = sequence (replicate n p) +{-# INLINE count #-} + +-- | Combine two alternatives. +eitherP :: (Alternative f) => f a -> f b -> f (Either a b) +eitherP a b = (Left <$> a) <|> (Right <$> b) +{-# INLINE eitherP #-} + +-- | If a parser has returned a 'T.Partial' result, supply it with more +-- input. +feed :: Monoid i => IResult i r -> i -> IResult i r +feed f@(Fail _ _ _) _ = f +feed (Partial k) d = k d +feed (Done t r) d = Done (mappend t d) r +{-# INLINE feed #-} diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} +-- | +-- Module : Data.Attoparsec.Internal +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient parser combinators, loosely based on the Parsec +-- library. + +module Data.Attoparsec.Internal + ( compareResults + , prompt + , demandInput + , wantInput + , endOfInput + , atEnd + , satisfyElem + ) where + +import Control.Applicative ((<$>)) +#if __GLASGOW_HASKELL__ >= 700 +import Data.ByteString (ByteString) +#endif +import Data.Attoparsec.Internal.Types +import Prelude hiding (succ) + +-- | Compare two 'IResult' values for equality. +-- +-- If both 'IResult's are 'Partial', the result will be 'Nothing', as +-- they are incomplete and hence their equality cannot be known. +-- (This is why there is no 'Eq' instance for 'IResult'.) +compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool +compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) = + Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1) +compareResults (Done t0 r0) (Done t1 r1) = + Just (t0 == t1 && r0 == r1) +compareResults (Partial _) (Partial _) = Nothing +compareResults _ _ = Just False + +-- | Ask for input. If we receive any, pass it to a success +-- continuation, otherwise to a failure continuation. +prompt :: Chunk t + => State t -> Pos -> More + -> (State t -> Pos -> More -> IResult t r) + -> (State t -> Pos -> More -> IResult t r) + -> IResult t r +prompt t pos _more lose succ = Partial $ \s -> + if nullChunk s + then lose t pos Complete + else succ (pappendChunk t s) pos Incomplete +#if __GLASGOW_HASKELL__ >= 700 +{-# SPECIALIZE prompt :: State ByteString -> Pos -> More + -> (State ByteString -> Pos -> More + -> IResult ByteString r) + -> (State ByteString -> Pos -> More + -> IResult ByteString r) + -> IResult ByteString r #-} +#endif + +-- | Immediately demand more input via a 'Partial' continuation +-- result. +demandInput :: Chunk t => Parser t () +demandInput = Parser $ \t pos more lose succ -> + case more of + Complete -> lose t pos more [] "not enough input" + _ -> let lose' t' pos' more' = lose t' pos' more' [] "not enough input" + succ' t' pos' more' = succ t' pos' more' () + in prompt t pos more lose' succ' +#if __GLASGOW_HASKELL__ >= 700 +{-# SPECIALIZE demandInput :: Parser ByteString () #-} +#endif + +-- | This parser always succeeds. It returns 'True' if any input is +-- available either immediately or on demand, and 'False' if the end +-- of all input has been reached. +wantInput :: forall t . Chunk t => Parser t Bool +wantInput = Parser $ \t pos more _lose succ -> + case () of + _ | pos < atBufferEnd (undefined :: t) t -> succ t pos more True + | more == Complete -> succ t pos more False + | otherwise -> let lose' t' pos' more' = succ t' pos' more' False + succ' t' pos' more' = succ t' pos' more' True + in prompt t pos more lose' succ' +{-# INLINE wantInput #-} + +-- | Match only if all input has been consumed. +endOfInput :: forall t . Chunk t => Parser t () +endOfInput = Parser $ \t pos more lose succ -> + case () of + _| pos < atBufferEnd (undefined :: t) t -> lose t pos more [] "endOfInput" + | more == Complete -> succ t pos more () + | otherwise -> + let lose' t' pos' more' _ctx _msg = succ t' pos' more' () + succ' t' pos' more' _a = lose t' pos' more' [] "endOfInput" + in runParser demandInput t pos more lose' succ' +#if __GLASGOW_HASKELL__ >= 700 +{-# SPECIALIZE endOfInput :: Parser ByteString () #-} +#endif + +-- | Return an indication of whether the end of input has been +-- reached. +atEnd :: Chunk t => Parser t Bool +atEnd = not <$> wantInput +{-# INLINE atEnd #-} + +satisfySuspended :: forall t r . Chunk t + => (ChunkElem t -> Bool) + -> State t -> Pos -> More + -> Failure t (State t) r + -> Success t (State t) (ChunkElem t) r + -> IResult t r +satisfySuspended p t pos more lose succ = + runParser (demandInput >> go) t pos more lose succ + where go = Parser $ \t' pos' more' lose' succ' -> + case bufferElemAt (undefined :: t) pos' t' of + Just (e, l) | p e -> succ' t' (pos' + Pos l) more' e + | otherwise -> lose' t' pos' more' [] "satisfyElem" + Nothing -> runParser (demandInput >> go) t' pos' more' lose' succ' +#if __GLASGOW_HASKELL__ >= 700 +{-# SPECIALIZE satisfySuspended :: (ChunkElem ByteString -> Bool) + -> State ByteString -> Pos -> More + -> Failure ByteString (State ByteString) r + -> Success ByteString (State ByteString) + (ChunkElem ByteString) r + -> IResult ByteString r #-} +#endif + +-- | The parser @satisfyElem p@ succeeds for any chunk element for which the +-- predicate @p@ returns 'True'. Returns the element that is +-- actually parsed. +satisfyElem :: forall t . Chunk t + => (ChunkElem t -> Bool) -> Parser t (ChunkElem t) +satisfyElem p = Parser $ \t pos more lose succ -> + case bufferElemAt (undefined :: t) pos t of + Just (e, l) | p e -> succ t (pos + Pos l) more e + | otherwise -> lose t pos more [] "satisfyElem" + Nothing -> satisfySuspended p t pos more lose succ +{-# INLINE satisfyElem #-} diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Fhthagn.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Fhthagn.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Fhthagn.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE BangPatterns, Rank2Types, OverloadedStrings, + RecordWildCards, MagicHash, UnboxedTuples #-} + +module Data.Attoparsec.Internal.Fhthagn + ( + inlinePerformIO + ) where + +import GHC.Base (realWorld#) +import GHC.IO (IO(IO)) + +-- | Just like unsafePerformIO, but we inline it. Big performance gains as +-- it exposes lots of things to further inlining. /Very unsafe/. In +-- particular, you should do no memory allocation inside an +-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r +{-# INLINE inlinePerformIO #-} diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Internal/Types.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, OverloadedStrings, + Rank2Types, RecordWildCards, TypeFamilies #-} +-- | +-- Module : Data.Attoparsec.Internal.Types +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple, efficient parser combinators, loosely based on the Parsec +-- library. + +module Data.Attoparsec.Internal.Types + ( + Parser(..) + , State + , Failure + , Success + , Pos(..) + , IResult(..) + , More(..) + , (<>) + , Chunk(..) + ) where + +import Control.Applicative (Alternative(..), Applicative(..), (<$>)) +import Control.DeepSeq (NFData(rnf)) +import Control.Monad (MonadPlus(..)) +import Data.Word (Word8) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (w2c) +import Data.Monoid (Monoid(..)) +import Prelude hiding (getChar, succ) +import qualified Data.Attoparsec.ByteString.Buffer as B + +newtype Pos = Pos { fromPos :: Int } + deriving (Eq, Ord, Show, Num) + +-- | The result of a parse. This is parameterised over the type @i@ +-- of string that was processed. +-- +-- This type is an instance of 'Functor', where 'fmap' transforms the +-- value in a 'Done' result. +data IResult i r = + Fail i [String] String + -- ^ The parse failed. The @i@ parameter is the input that had + -- not yet been consumed when the failure occurred. The + -- @[@'String'@]@ is a list of contexts in which the error + -- occurred. The 'String' is the message describing the error, if + -- any. + | Partial (i -> IResult i r) + -- ^ Supply this continuation with more input so that the parser + -- can resume. To indicate that no more input is available, pass + -- an empty string to the continuation. + -- + -- __Note__: if you get a 'Partial' result, do not call its + -- continuation more than once. + | Done i r + -- ^ The parse succeeded. The @i@ parameter is the input that had + -- not yet been consumed (if any) when the parse succeeded. + +instance (Show i, Show r) => Show (IResult i r) where + show (Fail t stk msg) = + unwords [ "Fail", show t, show stk, show msg] + show (Partial _) = "Partial _" + show (Done t r) = unwords ["Done", show t, show r] + +instance (NFData i, NFData r) => NFData (IResult i r) where + rnf (Fail t stk msg) = rnf t `seq` rnf stk `seq` rnf msg + rnf (Partial _) = () + rnf (Done t r) = rnf t `seq` rnf r + {-# INLINE rnf #-} + +instance Functor (IResult i) where + fmap _ (Fail t stk msg) = Fail t stk msg + fmap f (Partial k) = Partial (fmap f . k) + fmap f (Done t r) = Done t (f r) + +-- | The core parser type. This is parameterised over the types @i@ +-- of string being processed and @t@ of internal state representation. +-- +-- This type is an instance of the following classes: +-- +-- * 'Monad', where 'fail' throws an exception (i.e. fails) with an +-- error message. +-- +-- * 'Functor' and 'Applicative', which follow the usual definitions. +-- +-- * 'MonadPlus', where 'mzero' fails (with no error message) and +-- 'mplus' executes the right-hand parser if the left-hand one +-- fails. When the parser on the right executes, the input is reset +-- to the same state as the parser on the left started with. (In +-- other words, attoparsec is a backtracking parser that supports +-- arbitrary lookahead.) +-- +-- * 'Alternative', which follows 'MonadPlus'. +newtype Parser i a = Parser { + runParser :: forall r. + State i -> Pos -> More + -> Failure i (State i) r + -> Success i (State i) a r + -> IResult i r + } + +type family State i +type instance State ByteString = B.Buffer + +type Failure i t r = t -> Pos -> More -> [String] -> String + -> IResult i r +type Success i t a r = t -> Pos -> More -> a -> IResult i r + +-- | Have we read all available input? +data More = Complete | Incomplete + deriving (Eq, Show) + +instance Monoid More where + mappend c@Complete _ = c + mappend _ m = m + mempty = Incomplete + +instance Monad (Parser i) where + fail err = Parser $ \t pos more lose _succ -> lose t pos more [] msg + where msg = "Failed reading: " ++ err + {-# INLINE fail #-} + + return v = Parser $ \t pos more _lose succ -> succ t pos more v + {-# INLINE return #-} + + m >>= k = Parser $ \t !pos more lose succ -> + let succ' t' !pos' more' a = runParser (k a) t' pos' more' lose succ + in runParser m t pos more lose succ' + {-# INLINE (>>=) #-} + +plus :: Parser i a -> Parser i a -> Parser i a +plus f g = Parser $ \t pos more lose succ -> + let lose' t' _pos' more' _ctx _msg = runParser g t' pos more' lose succ + in runParser f t pos more lose' succ + +instance MonadPlus (Parser i) where + mzero = fail "mzero" + {-# INLINE mzero #-} + mplus = plus + +instance Functor (Parser i) where + fmap f p = Parser $ \t pos more lose succ -> + let succ' t' pos' more' a = succ t' pos' more' (f a) + in runParser p t pos more lose succ' + {-# INLINE fmap #-} + +apP :: Parser i (a -> b) -> Parser i a -> Parser i b +apP d e = do + b <- d + a <- e + return (b a) +{-# INLINE apP #-} + +instance Applicative (Parser i) where + pure = return + {-# INLINE pure #-} + (<*>) = apP + {-# INLINE (<*>) #-} + + -- These definitions are equal to the defaults, but this + -- way the optimizer doesn't have to work so hard to figure + -- that out. + (*>) = (>>) + {-# INLINE (*>) #-} + x <* y = x >>= \a -> y >> return a + {-# INLINE (<*) #-} + +instance Monoid (Parser i a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = plus + {-# INLINE mappend #-} + +instance Alternative (Parser i) where + empty = fail "empty" + {-# INLINE empty #-} + + (<|>) = plus + {-# INLINE (<|>) #-} + + many v = many_v + where many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + {-# INLINE many #-} + + some v = some_v + where + many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + {-# INLINE some #-} + +(<>) :: (Monoid m) => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} + +-- | A common interface for input chunks. +class Monoid c => Chunk c where + type ChunkElem c + -- | Test if the chunk is empty. + nullChunk :: c -> Bool + -- | Append chunk to a buffer. + pappendChunk :: State c -> c -> State c + -- | Position at the end of a buffer. The first argument is ignored. + atBufferEnd :: c -> State c -> Pos + -- | Return the buffer element at the given position along with its length. + bufferElemAt :: c -> Pos -> State c -> Maybe (ChunkElem c, Int) + -- | Map an element to the corresponding character. + -- The first argument is ignored. + chunkElemToChar :: c -> ChunkElem c -> Char + +instance Chunk ByteString where + type ChunkElem ByteString = Word8 + nullChunk = BS.null + {-# INLINE nullChunk #-} + pappendChunk = B.pappend + {-# INLINE pappendChunk #-} + atBufferEnd _ = Pos . B.length + {-# INLINE atBufferEnd #-} + bufferElemAt _ (Pos i) buf + | i < B.length buf = Just (B.unsafeIndex buf i, 1) + | otherwise = Nothing + {-# INLINE bufferElemAt #-} + chunkElemToChar _ = w2c + {-# INLINE chunkElemToChar #-} diff --git a/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Number.hs b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Number.hs new file mode 100644 --- /dev/null +++ b/haddock-library/vendor/attoparsec-0.12.1.1/Data/Attoparsec/Number.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module : Data.Attoparsec.Number +-- Copyright : Bryan O'Sullivan 2007-2014 +-- License : BSD3 +-- +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module is deprecated, and both the module and 'Number' type +-- will be removed in the next major release. Use the +-- package +-- and the 'Data.Scientific.Scientific' type instead. +-- +-- A simple number type, useful for parsing both exact and inexact +-- quantities without losing much precision. +module Data.Attoparsec.Number + {-# DEPRECATED "This module will be removed in the next major release." #-} + ( + Number(..) + ) where + +import Control.DeepSeq (NFData(rnf)) +import Data.Data (Data) +import Data.Function (on) +import Data.Typeable (Typeable) + +-- | A numeric type that can represent integers accurately, and +-- floating point numbers to the precision of a 'Double'. +-- +-- /Note/: this type is deprecated, and will be removed in the next +-- major release. Use the 'Data.Scientific.Scientific' type instead. +data Number = I !Integer + | D {-# UNPACK #-} !Double + deriving (Typeable, Data) +{-# DEPRECATED Number "Use Scientific instead." #-} + +instance Show Number where + show (I a) = show a + show (D a) = show a + +instance NFData Number where + rnf (I _) = () + rnf (D _) = () + {-# INLINE rnf #-} + +binop :: (Integer -> Integer -> a) -> (Double -> Double -> a) + -> Number -> Number -> a +binop _ d (D a) (D b) = d a b +binop i _ (I a) (I b) = i a b +binop _ d (D a) (I b) = d a (fromIntegral b) +binop _ d (I a) (D b) = d (fromIntegral a) b +{-# INLINE binop #-} + +instance Eq Number where + (==) = binop (==) (==) + {-# INLINE (==) #-} + + (/=) = binop (/=) (/=) + {-# INLINE (/=) #-} + +instance Ord Number where + (<) = binop (<) (<) + {-# INLINE (<) #-} + + (<=) = binop (<=) (<=) + {-# INLINE (<=) #-} + + (>) = binop (>) (>) + {-# INLINE (>) #-} + + (>=) = binop (>=) (>=) + {-# INLINE (>=) #-} + + compare = binop compare compare + {-# INLINE compare #-} + +instance Num Number where + (+) = binop (((I$!).) . (+)) (((D$!).) . (+)) + {-# INLINE (+) #-} + + (-) = binop (((I$!).) . (-)) (((D$!).) . (-)) + {-# INLINE (-) #-} + + (*) = binop (((I$!).) . (*)) (((D$!).) . (*)) + {-# INLINE (*) #-} + + abs (I a) = I $! abs a + abs (D a) = D $! abs a + {-# INLINE abs #-} + + negate (I a) = I $! negate a + negate (D a) = D $! negate a + {-# INLINE negate #-} + + signum (I a) = I $! signum a + signum (D a) = D $! signum a + {-# INLINE signum #-} + + fromInteger = (I$!) . fromInteger + {-# INLINE fromInteger #-} + +instance Real Number where + toRational (I a) = fromIntegral a + toRational (D a) = toRational a + {-# INLINE toRational #-} + +instance Fractional Number where + fromRational = (D$!) . fromRational + {-# INLINE fromRational #-} + + (/) = binop (((D$!).) . (/) `on` fromIntegral) + (((D$!).) . (/)) + {-# INLINE (/) #-} + + recip (I a) = D $! recip (fromIntegral a) + recip (D a) = D $! recip a + {-# INLINE recip #-} + +instance RealFrac Number where + properFraction (I a) = (fromIntegral a,0) + properFraction (D a) = case properFraction a of + (i,d) -> (i,D d) + {-# INLINE properFraction #-} + truncate (I a) = fromIntegral a + truncate (D a) = truncate a + {-# INLINE truncate #-} + round (I a) = fromIntegral a + round (D a) = round a + {-# INLINE round #-} + ceiling (I a) = fromIntegral a + ceiling (D a) = ceiling a + {-# INLINE ceiling #-} + floor (I a) = fromIntegral a + floor (D a) = floor a + {-# INLINE floor #-} diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.14.3 +version: 2.15.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -26,54 +26,28 @@ doc/docbook-xml.mk doc/fptools.css doc/haddock.xml - haddock.spec - haskell.vim - src/haddock.sh + haddock-api/src/haddock.sh html-test/src/*.hs html-test/ref/*.html latex-test/src/Simple/*.hs latex-test/ref/Simple/*.tex latex-test/ref/Simple/*.sty -data-dir: resources -data-files: html/frames.html - html/haddock-util.js - html/Classic.theme/haskell_icon.gif - html/Classic.theme/minus.gif - html/Classic.theme/plus.gif - html/Classic.theme/xhaddock.css - html/Ocean.std-theme/hslogo-16.png - html/Ocean.std-theme/minus.gif - html/Ocean.std-theme/ocean.css - html/Ocean.std-theme/plus.gif - html/Ocean.std-theme/synopsis.png - latex/haddock.sty - flag in-ghc-tree description: Are we in a GHC tree? default: False manual: True --- Using this disables -O2, and hence allows to use --disable-optimization, --- which is about twice as fast. This should probably be the default, but we --- need some benchmarks first.. -flag dev - default: False - manual: True - executable haddock default-language: Haskell2010 main-is: Main.hs hs-source-dirs: driver - if flag(dev) - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs - else - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 build-depends: base >= 4.3 && < 4.8 if flag(in-ghc-tree) - hs-source-dirs: src, vendor/attoparsec-0.10.4.0 + hs-source-dirs: haddock-api/src, haddock-library/vendor/attoparsec-0.12.1.1, haddock-library/src cpp-options: -DIN_GHC_TREE build-depends: filepath, @@ -83,20 +57,28 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc == 7.8.*, + ghc == 7.8.3, bytestring other-modules: - Documentation.Haddock + Documentation.Haddock.Parser + Documentation.Haddock.Types + Documentation.Haddock.Doc Data.Attoparsec Data.Attoparsec.ByteString + Data.Attoparsec.ByteString.Buffer Data.Attoparsec.ByteString.Char8 - Data.Attoparsec.Combinator - Data.Attoparsec.Number Data.Attoparsec.ByteString.FastSet Data.Attoparsec.ByteString.Internal + Data.Attoparsec.Combinator Data.Attoparsec.Internal + Data.Attoparsec.Internal.Fhthagn Data.Attoparsec.Internal.Types + Data.Attoparsec.Number + Documentation.Haddock.Utf8 + Documentation.Haddock.Parser.Util + + Documentation.Haddock Haddock Haddock.Interface Haddock.Interface.Rename @@ -105,8 +87,6 @@ Haddock.Interface.LexParseRn Haddock.Interface.ParseModuleHeader Haddock.Parser - Haddock.Parser.Util - Haddock.Utf8 Haddock.Utils Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl @@ -128,81 +108,7 @@ Haddock.GhcUtils Haddock.Convert else - build-depends: haddock - -library - default-language: Haskell2010 - - build-depends: - base >= 4.3 && < 4.8, - bytestring, - filepath, - directory, - containers, - deepseq, - array, - xhtml >= 3000.2 && < 3000.3, - Cabal >= 1.10, - ghc == 7.8.* - - if flag(in-ghc-tree) - cpp-options: -DIN_GHC_TREE - else - build-depends: ghc-paths - - hs-source-dirs: src, vendor/attoparsec-0.10.4.0 - if flag(dev) - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs - else - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 - - exposed-modules: - Documentation.Haddock - - other-modules: - Data.Attoparsec - Data.Attoparsec.ByteString - Data.Attoparsec.ByteString.Char8 - Data.Attoparsec.Combinator - Data.Attoparsec.Number - Data.Attoparsec.ByteString.FastSet - Data.Attoparsec.ByteString.Internal - Data.Attoparsec.Internal - Data.Attoparsec.Internal.Types - Haddock - Haddock.Interface - Haddock.Interface.Rename - Haddock.Interface.Create - Haddock.Interface.AttachInstances - Haddock.Interface.LexParseRn - Haddock.Interface.ParseModuleHeader - Haddock.Parser - Haddock.Parser.Util - Haddock.Utf8 - Haddock.Utils - Haddock.Backends.Xhtml - Haddock.Backends.Xhtml.Decl - Haddock.Backends.Xhtml.DocMarkup - Haddock.Backends.Xhtml.Layout - Haddock.Backends.Xhtml.Names - Haddock.Backends.Xhtml.Themes - Haddock.Backends.Xhtml.Types - Haddock.Backends.Xhtml.Utils - Haddock.Backends.LaTeX - Haddock.Backends.HaddockDB - Haddock.Backends.Hoogle - Haddock.ModuleTree - Haddock.Types - Haddock.Doc - Haddock.Version - Haddock.InterfaceFile - Haddock.Options - Haddock.GhcUtils - Haddock.Convert - Paths_haddock - - if flag(in-ghc-tree) - buildable: False + build-depends: haddock-api == 2.15.0 test-suite html-test type: exitcode-stdio-1.0 @@ -218,34 +124,6 @@ hs-source-dirs: latex-test build-depends: base, directory, process, filepath, Cabal -test-suite spec - type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Spec.hs - hs-source-dirs: - test - , src - , vendor/attoparsec-0.10.4.0 - - other-modules: - Helper - Haddock.ParserSpec - Haddock.Utf8Spec - Haddock.Parser.UtilSpec - - build-depends: - base - , bytestring - , ghc - , containers - , deepseq - , array - , hspec - , QuickCheck == 2.* - - build-depends: - haddock - source-repository head type: git - location: http://git.haskell.org/haddock.git + location: https://github.com/haskell/haddock.git diff --git a/haddock.spec b/haddock.spec deleted file mode 100644 --- a/haddock.spec +++ /dev/null @@ -1,81 +0,0 @@ -# This is an RPM spec file that specifies how to package -# haddock for Red Hat Linux and, possibly, similar systems. -# It has been tested on Red Hat Linux 7.2 and SuSE Linux 9.1. -# -# If this file is part of a tarball, you can build RPMs directly from -# the tarball by using the following command: -# -# rpm -ta haddock-(VERSION).tar.gz -# -# The resulting package will be placed in the RPMS/(arch) subdirectory -# of your RPM build directory (usually /usr/src/redhat or ~/rpm), with -# the name haddock-(VERSION)-(RELEASE).noarch.rpm. A corresponding -# source RPM package will be in the SRPMS subdirectory. -# -# NOTE TO HADDOCK MAINTAINERS: When you release a new version of -# Haskell mode, update the version definition below to match the -# version label of your release tarball. - -%define name haddock -%define version 2.14.1 -%define release 1 - -Name: %{name} -Version: %{version} -Release: %{release} -License: BSD-like -Group: Development/Languages/Haskell -URL: http://haskell.org/haddock/ -Source: http://haskell.org/haddock/haddock-%{version}.tar.gz -Packager: Sven Panne -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 deleted file mode 100644 --- a/haskell.vim +++ /dev/null @@ -1,68 +0,0 @@ -" 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-test/ref/A.html b/html-test/ref/A.html --- a/html-test/ref/A.html +++ b/html-test/ref/A.html @@ -172,7 +172,7 @@ >

Produced by Haddock version 2.14.2

version 2.15.0

Produced by Haddock version 2.14.2

version 2.15.0

Produced by Haddock version 2.14.2

version 2.15.0

Synopsis

foo :: t

:: t

Some

Produced by Haddock version 2.14.2

version 2.15.0

Produced by Haddock version 2.14.2

version 2.15.0

Produced by Haddock version 2.14.2

version 2.15.0

Produced by Haddock version 2.14.2

version 2.15.0

Produced by Haddock version 2.14.2

version 2.15.0

  • (<^>) :: (a -> a) -> a -> a
    • :: (a -> a) -> a -> a
  • (<^) :: a -> a -> a
    • :: a -> a -> a
  • (^>) :: a -> a -> a
    • :: a -> a -> a
  • (⋆^) :: a -> a -> a
    • :: a -> a -> a
  • f

    (<^>) :: (a -> a) -> a -> a

    :: (a -> a) -> a -> a

    (<^) :: a -> a -> a

    :: a -> a -> a

    (^>) :: a -> a -> a

    :: a -> a -> a

    (⋆^) :: a -> a -> a

    :: a -> a -> a

    Produced by Haddock version 2.14.2

    version 2.15.0

    +Bug313
    Safe HaskellSafe-Inferred

    Bug313

    Description

    The first list is incorrectly numbered as 1. 2. 1.; the second example + renders fine (1. 2. 3.).

    See https://github.com/haskell/haddock/issues/313

    Synopsis

    • a :: a
    • b :: a

    Documentation

    a :: a

    Some text.

    1. Item 1

    2. Item 2

      Some code
    3. Item 3

    Some more text.

    b :: a

    Some text.

    1. Item 1

    2. Item 2

      Some code
    3. Item 3

    Some more text.

    diff --git a/html-test/ref/Bug4.html b/html-test/ref/Bug4.html --- a/html-test/ref/Bug4.html +++ b/html-test/ref/Bug4.html @@ -74,7 +74,7 @@ >

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    (-->) :: t -> t1 -> :: t -> t1 -> Typ infix 9

    (--->) :: [a] -> :: [a] -> Typ -> -> Typ infix 9

    s :: t

    :: t

    t :: t

    :: t

    main :: t

    :: t

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

  • bazbar :: Int
  • barbaz :: Int
  • threetwo :: Int
  • twothree :: Int

    • bazbar :: Int

    Deprecated: for baz

    Deprecated: for bar

    barbaz :: Int

    Deprecated: for bar

    Deprecated: for baz

    Deprecated: for one

    some documentation for one, two and three

    some documentation for one

    threetwo :: Int

    Deprecated: for three

    Deprecated: for two

    some documentation for one, two and three

    twothree :: Int

    Deprecated: for two

    Deprecated: for three

    some documentation for one, two and three

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.0

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

  • foobar :: t
    • :: t

    foobar :: t

    :: t

    Bar

    Produced by Haddock version 2.14.2

    version 2.15.0

    :: forall a . :: Ord a

    h

    Arguments

    :: a

    First argument

    -> b

    Second argument

    -> c

    Third argument

    -> d

    Result

    i

    Arguments

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

    abcd

    -> ()

    Result

    j

    Arguments

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

    First argument

    -> b

    Result

    Produced by Haddock version 2.14.2

    version 2.15.0

    Description

    Implementation of fixed-size hash tables, with a type + >Implementation of fixed-size hash tables, with a type class for constructing hash values for structured types.

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    f :: ((?x :: :: ((?x :: X) => a) -> a

    Produced by Haddock version 2.14.2

    version 2.15.0

    foo, bat, bar :: a

    Any two of these are required...

    bar :: a

    bat :: a

    fooBarBat :: (a, a, a)

    a, g, f, e, d, c, :: a

    b :: a

    c :: a

    d :: a

    e :: a

    f :: a

    g :: a

    x, z, :: a

    y :: a

    z :: a

    aaa, :: a

    bbb :: a

    eee, :: a

    fff :: a

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

  • d :: t
    • :: t
  • e :: t
    • :: t
  • f :: t
    • :: t
  • g :: t
    • :: t
  • h :: t
    • :: t
  • i :: t
    • :: t
  • j :: t
    • :: t

    d :: t

    :: t

    • We can

        We can

        • easily go back

            easily go back

            1. some indentation

            e :: t

            :: t

            • Beginning of list

                Beginning of list

                • second list

                f :: t

                :: t

                • Beginning of list
                  Beginning of list
                  nested code
     we preserve the space correctly
 
                  g ::  t
                   :: t
                  • Beginning of list
                      Beginning of list
                      • Nested list
                      h ::  t
                       :: t
                      • Beginning of list
                        Beginning of list
                        nested
 bird
 tracks
                        i ::  t
                         :: t
                        • Beginning of list
-This belongs to the list above!
                          Beginning of list
+This belongs to the list above!
                          nested
 bird
 tracks
@@ -194,12 +208,18 @@
   without leading space
                          • Next list
-More of the indented list.
                              Next list
+More of the indented list.
                              • Deeper
                                  Deeper
                                  • Deeper
                                      Deeper
                                      • Even deeper!
                                      • j ::  t
                                         :: t
                                        • Next list
-with more of the indented list content.
                                          Next list
+with more of the indented list content.
                                          Even more content on a new line.
                                          1. Different type of list
                                              Different type of list
                                              1. Deeper
                                              No newline separation even in indented lists.
         We can have any paragraph level element that we normally
-        can, like headers
                                              Level 3 header
                                              Level 3 header
                                              with some content…
                                                Produced by Haddock version 2.14.2
                                                 version 2.15.0
                                        Produced by Haddock version 2.14.2
                                         version 2.15.0
                      • f ::  a
                        •  :: a
                      f ::  a
                       :: a
                      Produced by Haddock version 2.14.2
                       version 2.15.0
                    • (+-) ::  a -> a -> a
                      •  :: a -> a -> a
                    • (*/) ::  a -> a -> a
                      •  :: a -> a -> a
                    • foo ::  a -> a -> a
                      •  :: a -> a -> a
                    • data
                      (+-) ::  a -> a -> a
                       :: a -> a -> a
                      Operator with no fixity
                      (*/) ::  a -> a -> a  :: a -> a -> a infixr 7
                      foo ::  a -> a -> a  :: a -> a -> a infixl 3
                      Produced by Haddock version 2.14.2
                       version 2.15.0
                      Produced by Haddock version 2.14.2
                       version 2.15.0
                      • Produced by Haddock version 2.14.2
                       version 2.15.0
                  Produced by Haddock version 2.14.2
                   version 2.15.0

                Produced by Haddock version 2.14.2

                version 2.15.0

            Produced by Haddock version 2.14.2

            version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    f :: t -> t

    :: t -> t

    Produced by Haddock version 2.14.2

    version 2.15.0

  • d :: :: T a b
  • withoutType :: t
    • :: t

    d :: :: T a b

    withoutType :: t

    :: t

    Comment on a definition without type signature

    Produced by Haddock version 2.14.2

    version 2.15.0

  • f :: a
    • :: a

    f :: a

    :: a

    ...given a raw

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    biO :: (g :: (g `O` f) a

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    Produced by Haddock version 2.14.2

    version 2.15.0

    data A

    data X

    data Pattern

    data X

    data T

    data A

    data B

    data C

    data D

    data E

    data Foo

    data Typ

    bazbar

    barbaz

    threetwo

    twothree

    data Foo

    data One

    data SomeNewType

    data SomeOtherNewType

    data Foo

    type TypeSyn

    type OtherTypeSyn

    data VisibleData

    data Bar

    data Expr

    data BinOp

    data T6

    data R

    data R1

    Class declarations

    data Baz

    data X

    data Y

    data Z

    class Test a

    type family GFoo a :: k

    data family Bat a :: *

    class AAssoc a

    type family F a

    Bar b

    g

    type family a <> b :: k

    class a >< b

    TypeOperators

    stuff

    data

    class a <=> b

    biO

    f

    g

    x

    y

    Some code + +3. Item 3 + +Some more text. +-} +a :: a +a = undefined + +{- | +Some text. + +1. Item 1 + +2. Item 2 + + > Some code + +3. Item 3 + +-} +-- | Some more text. +b :: a +b = undefined diff --git a/html-test/src/BugDeprecated.hs b/html-test/src/BugDeprecated.hs --- a/html-test/src/BugDeprecated.hs +++ b/html-test/src/BugDeprecated.hs @@ -1,17 +1,25 @@ module BugDeprecated where -foo, bar, baz :: Int +foo :: Int foo = 23 + +bar :: Int bar = 23 + +baz :: Int baz = 23 {-# DEPRECATED foo "for foo" #-} {-# DEPRECATED bar "for bar" #-} {-# DEPRECATED baz "for baz" #-} --- | some documentation for one, two and three -one, two, three :: Int +-- | some documentation for one +one :: Int one = 23 + +two :: Int two = 23 + +three :: Int three = 23 {-# DEPRECATED one "for one" #-} {-# DEPRECATED two "for two" #-} diff --git a/html-test/src/FunArgs.hs b/html-test/src/FunArgs.hs --- a/html-test/src/FunArgs.hs +++ b/html-test/src/FunArgs.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RankNTypes, DataKinds, TypeFamilies #-} module FunArgs where f :: forall a. Ord a @@ -15,3 +15,24 @@ -> c -- ^ Third argument -> d -- ^ Result g = undefined + + +h :: forall a b c + . a -- ^ First argument + -> b -- ^ Second argument + -> c -- ^ Third argument + -> forall d. d -- ^ Result +h = undefined + + +i :: forall a (b :: ()) d. (d ~ '()) + => forall c + . a b c d -- ^ abcd + -> () -- ^ Result +i = undefined + + +j :: forall proxy (a :: ()) b + . proxy a -- ^ First argument + -> b -- ^ Result +j = undefined diff --git a/html-test/src/Hash.hs b/html-test/src/Hash.hs --- a/html-test/src/Hash.hs +++ b/html-test/src/Hash.hs @@ -1,5 +1,5 @@ {- | - Implementation of fixed-size hash tables, with a type + Implementation of fixed-size hash tables, with a type class for constructing hash values for structured types. -} module Hash ( @@ -30,7 +30,7 @@ -- | Looks up a key in the hash table, returns @'Just' val@ if the key -- was found, or 'Nothing' otherwise. -lookup :: Hash key => key -> IO (Maybe val) +lookup :: Hash key => key -> IO (Maybe val) lookup = undefined -- | A class of types which can be hashed. diff --git a/html-test/src/Minimal.hs b/html-test/src/Minimal.hs --- a/html-test/src/Minimal.hs +++ b/html-test/src/Minimal.hs @@ -10,7 +10,9 @@ class Foo a where -- | Any two of these are required... - foo, bar, bat :: a + foo :: a + bar :: a + bat :: a -- | .. or just this fooBarBat :: (a,a,a) @@ -18,23 +20,34 @@ {-# MINIMAL (foo, bar) | (bar, bat) | (foo, bat) | fooBarBat #-} class Weird a where - a,b,c,d,e,f,g :: a + a :: a + b :: a + c :: a + d :: a + e :: a + f :: a + g :: a {-# MINIMAL ((a, b), c | (d | (e, (f | g)))) #-} class NoMins a where - x,y,z :: a + x :: a + y :: a + z :: a -- | Has a default implementation! z = x class FullMin a where - aaa,bbb :: a + aaa :: a + bbb :: a class PartialMin a where - ccc,ddd :: a + ccc :: a + ddd :: a class EmptyMin a where - eee,fff :: a + eee :: a + fff :: a eee = fff fff = undefined diff --git a/resources/html/Classic.theme/haskell_icon.gif b/resources/html/Classic.theme/haskell_icon.gif deleted file mode 100644 Binary files a/resources/html/Classic.theme/haskell_icon.gif and /dev/null differ diff --git a/resources/html/Classic.theme/minus.gif b/resources/html/Classic.theme/minus.gif deleted file mode 100644 Binary files a/resources/html/Classic.theme/minus.gif and /dev/null differ diff --git a/resources/html/Classic.theme/plus.gif b/resources/html/Classic.theme/plus.gif deleted file mode 100644 Binary files a/resources/html/Classic.theme/plus.gif and /dev/null differ diff --git a/resources/html/Classic.theme/xhaddock.css b/resources/html/Classic.theme/xhaddock.css deleted file mode 100644 --- a/resources/html/Classic.theme/xhaddock.css +++ /dev/null @@ -1,499 +0,0 @@ -* { - margin: 0; - padding: 0; -} - -.extension-list { - list-style-type: none; - margin-left: 0; - padding-left: 0; -} - -body { - background-color: #ffffff; - color: #000000; - font-size: 100%; - font-family: sans-serif; - padding: 8px; -} - -a:link { color: #0000e0; text-decoration: none } -a:visited { color: #0000a0; text-decoration: none } -a:hover { background-color: #e0e0ff; text-decoration: none } - -/* font is a little too small in MSIE */ -tt { font-size: 100%; } -pre { font-size: 100%; } -.keyword { text-decoration: underline; } -.caption { - font-weight: bold; - margin: 0; - padding: 0; -} - -h1 { - padding-top: 15px; - font-weight: bold; - font-size: 150%; -} - -h2 { - padding-top: 10px; - font-weight: bold; - font-size: 130% - } - -h3 { - padding-top: 5px; - font-weight: bold; - font-size: 110% - } - -h4, h5 { - font-weight: bold; - font-size: 100% - } - -h1, h2, h3, h4, h5 { - margin-top: 0.5em; - margin-bottom: 0.5em; -} - -p { - padding-top: 2px; - padding-left: 10px; -} - -ul, ol, dl { - padding-top: 2px; - padding-left: 10px; - margin-left: 2.5em; -} - -pre { - padding-top: 2px; - padding-left: 20px; -} - -* + p, * + pre { - margin-top: 1em; -} -.caption + p, .src + p { - margin-top: 0; -} - -.def { - font-weight: bold; -} - -ul.links { - list-style: none; - text-align: left; - float: right; - display: inline-table; - padding: 0; -} - -ul.links li { - display: inline; - border-left-width: 1px; - border-left-color: #ffffff; - border-left-style: solid; - white-space: nowrap; - padding: 1px 5px; -} - -.hide { display: none; } -.show { } -.collapser { - background: url(minus.gif) no-repeat 0 0.3em; -} -.expander { - background: url(plus.gif) no-repeat 0 0.3em; -} -.collapser, .expander { - padding-left: 14px; - cursor: pointer; -} - -#package-header { - color: #ffffff; - padding: 5px 5px 5px 31px; - margin: 0 0 1px; - background: #000099 url(haskell_icon.gif) no-repeat 5px 6px; - position: relative; -} - -#package-header .caption { - font-weight: normal; - font-style: normal; -} -#package-header a:link { color: #ffffff } -#package-header a:visited { color: #ffff00 } -#package-header a:hover { background-color: #6060ff; } -#package-header ul.links li:hover { background-color: #6060ff; } - -div#style-menu-holder { - position: relative; - z-index: 2; - display: inline; -} - -#style-menu { - position: absolute; - z-index: 1; - overflow: visible; - background-color: #000099; - margin: 0; - width: 6em; - text-align: center; - right: 0; - padding: 2px 2px 1px; -} - -#style-menu li { - display: list-item; - border-style: none; - margin: 0; - padding: 3px; - color: #000; - list-style-type: none; - border-top: 1px solid #ffffff; -} - -#module-header { - overflow: hidden; /* makes sure info float is properly contained */ - display: inline-block; /* triggers hasLayout in IE*/ -} - -#module-header { - display: block; /* back to block */ - background-color: #0077dd; - padding: 5px; -} - -#module-header .caption { - font-size: 200%; - padding: .35em 0; - font-weight: normal; - font-style: normal; -} - -table.info { - color: #ffffff; - display: block; - float: right; - max-width: 50%; -} - -.info th, .info td { - text-align: left; - padding: 0 10px 0 0; -} - - -#table-of-contents { - margin-top: 1em; - margin-bottom: 2em; -} - -#table-of-contents ul { - margin-top: 1em; - margin-bottom: 1em; - margin-left: 0; - list-style-type: none; - padding: 0; -} - -#table-of-contents ul ul { - margin-left: 2.5em; -} - -#description .caption, -#synopsis .caption, -#module-list .caption, -#index .caption { - padding-top: 15px; - font-weight: bold; - font-size: 150% -} - -#synopsis { - margin-bottom: 2em; -} - -#synopsis .expander, -#synopsis .collapser { - background: none; - padding-left: inherit; -} - -#synopsis .hide { - display: inherit; -} - -#synopsis ul { - margin: 0; - padding-top: 0; - padding-left: 20px; - list-style-type: none; -} - -#synopsis li { - margin-top: 8px; - margin-bottom: 8px; - padding: 3px; -} - -#synopsis li li { - padding: 0; - margin-top: 0; - margin-bottom: 0; -} - - -div.top { - margin-top: 1em; - clear: left; - margin-bottom: 1em; -} - -div.top h5 { - margin-left: 10px; -} - - -.src { - padding: 3px; - background-color: #f0f0f0; - font-family: monospace; - margin-bottom: 0; -} - - -.src a.link { - float: right; - border-left-width: 1px; - border-left-color: #000099; - border-left-style: solid; - white-space: nowrap; - font-size: small; - padding: 0 8px 2px 5px; - margin-right: -3px; - background-color: #f0f0f0; -} - -div.subs { - margin-left: 10px; - clear: both; - margin-top: 2px; -} - -.subs dl { - margin-left: 0; -} - -.subs dl dl { - padding-left: 0; - padding-top: 4px; -} - -.subs dd -{ - margin: 2px 0 9px 2em; -} - -.subs dd.empty { - display: none; -} - -.subs table { - margin-left: 10px; - border-spacing: 1px 1px; - margin-top: 4px; - margin-bottom: 4px; -} - -.subs table table { - margin-left: 0; -} - -.arguments .caption, -.fields .caption { - display: none; -} - -/* need extra .subs in the selector to make it override the rules for .subs and .subs table */ - -.subs.arguments { - margin: 0; -} - -.subs.arguments table { - border-spacing: 0; - margin-top: 0; - margin-bottom: 0; -} - -.subs.arguments td.src { - white-space: nowrap; -} - -.subs.arguments + p { - margin-top: 0; -} - -.subs.associated-types, -.subs.methods { - margin-left: 20px; -} - -.subs.associated-types .caption, -.subs.methods .caption { - margin-top: 0.5em; - margin-left: -10px; -} - -.subs.associated-types .src + .src, -.subs.methods .src + .src { - margin-top: 8px; -} - -p.arg { - margin-bottom: 0; -} -p.arg span { - background-color: #f0f0f0; - font-family: monospace; - white-space: nowrap; - float: none; -} - - -img.coll { - width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em -} - - -td.arg { - padding: 3px; - background-color: #f0f0f0; - font-family: monospace; - margin-bottom: 0; -} - -td.rdoc p { - margin-bottom: 0; -} - - - -#footer { - background-color: #000099; - color: #ffffff; - padding: 4px - } - -#footer p { - padding: 1px; - margin: 0; -} - -#footer a:link { - color: #ffffff; - text-decoration: underline - } -#footer a:visited { - color: #ffff00 - } -#footer a:hover { - background-color: #6060ff - } - - -#module-list ul { - list-style: none; - padding-bottom: 15px; - padding-left: 2px; - margin: 0; -} - -#module-list ul ul { - padding-bottom: 0; - padding-left: 20px; -} - -#module-list li .package { - float: right; -} -#mini #module-list .caption { - display: none; -} - -#index .caption { -} - -#alphabet ul { - list-style: none; - padding: 0; - margin: 0.5em 0 0; -} - -#alphabet li { - display: inline; - margin: 0 0.2em; -} - -#index .src { - background: none; - font-family: inherit; -} - -#index td.alt { - padding-left: 2em; -} - -#index td { - padding-top: 2px; - padding-bottom: 1px; - padding-right: 1em; -} - - -#mini h1 { font-size: 130%; } -#mini h2 { font-size: 110%; } -#mini h3 { font-size: 100%; } -#mini h1, #mini h2, #mini h3 { - margin-top: 0.5em; - margin-bottom: 0.25em; - padding: 0 0; -} - -#mini h1 { border-bottom: 1px solid #ccc; } - -#mini #module-header { - margin: 0; - padding: 0; -} -#mini #module-header .caption { - font-size: 130%; - background: #0077dd; - padding: 0.25em; - height: inherit; - margin: 0; -} - -#mini #interface .top { - margin: 0; - padding: 0; -} -#mini #interface .src { - margin: 0; - padding: 0; - font-family: inherit; - background: inherit; -} - -.warning { - color: red; -} diff --git a/resources/html/Ocean.std-theme/hslogo-16.png b/resources/html/Ocean.std-theme/hslogo-16.png deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/hslogo-16.png and /dev/null differ diff --git a/resources/html/Ocean.std-theme/minus.gif b/resources/html/Ocean.std-theme/minus.gif deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/minus.gif and /dev/null differ diff --git a/resources/html/Ocean.std-theme/ocean.css b/resources/html/Ocean.std-theme/ocean.css deleted file mode 100644 --- a/resources/html/Ocean.std-theme/ocean.css +++ /dev/null @@ -1,577 +0,0 @@ -/* @group Fundamentals */ - -* { margin: 0; padding: 0 } - -/* Is this portable? */ -html { - background-color: white; - width: 100%; - height: 100%; -} - -body { - background: white; - color: black; - text-align: left; - min-height: 100%; - position: relative; -} - -p { - margin: 0.8em 0; -} - -ul, ol { - margin: 0.8em 0 0.8em 2em; -} - -dl { - margin: 0.8em 0; -} - -dt { - font-weight: bold; -} -dd { - margin-left: 2em; -} - -a { text-decoration: none; } -a[href]:link { color: rgb(196,69,29); } -a[href]:visited { color: rgb(171,105,84); } -a[href]:hover { text-decoration:underline; } - -/* @end */ - -/* @group Fonts & Sizes */ - -/* Basic technique & IE workarounds from YUI 3 - For reasons, see: - http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css - */ - -body { - font:13px/1.4 sans-serif; - *font-size:small; /* for IE */ - *font:x-small; /* for IE in quirks mode */ -} - -h1 { font-size: 146.5%; /* 19pt */ } -h2 { font-size: 131%; /* 17pt */ } -h3 { font-size: 116%; /* 15pt */ } -h4 { font-size: 100%; /* 13pt */ } -h5 { font-size: 100%; /* 13pt */ } - -select, input, button, textarea { - font:99% sans-serif; -} - -table { - font-size:inherit; - font:100%; -} - -pre, code, kbd, samp, tt, .src { - font-family:monospace; - *font-size:108%; - line-height: 124%; -} - -.links, .link { - font-size: 85%; /* 11pt */ -} - -#module-header .caption { - font-size: 182%; /* 24pt */ -} - -.info { - font-size: 85%; /* 11pt */ -} - -#table-of-contents, #synopsis { - /* font-size: 85%; /* 11pt */ -} - - -/* @end */ - -/* @group Common */ - -.caption, h1, h2, h3, h4, h5, h6 { - font-weight: bold; - color: rgb(78,98,114); - margin: 0.8em 0 0.4em; -} - -* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { - margin-top: 2em; -} - -h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { - margin-top: inherit; -} - -ul.links { - list-style: none; - text-align: left; - float: right; - display: inline-table; - margin: 0 0 0 1em; -} - -ul.links li { - display: inline; - border-left: 1px solid #d5d5d5; - white-space: nowrap; - padding: 0; -} - -ul.links li a { - padding: 0.2em 0.5em; -} - -.hide { display: none; } -.show { display: inherit; } -.clear { clear: both; } - -.collapser { - background-image: url(minus.gif); - background-repeat: no-repeat; -} -.expander { - background-image: url(plus.gif); - background-repeat: no-repeat; -} -p.caption.collapser, -p.caption.expander { - background-position: 0 0.4em; -} -.collapser, .expander { - padding-left: 14px; - margin-left: -14px; - cursor: pointer; -} - -pre { - padding: 0.25em; - margin: 0.8em 0; - background: rgb(229,237,244); - overflow: auto; - border-bottom: 0.25em solid white; - /* white border adds some space below the box to compensate - for visual extra space that paragraphs have between baseline - and the bounding box */ -} - -.src { - background: #f0f0f0; - padding: 0.2em 0.5em; -} - -.keyword { font-weight: normal; } -.def { font-weight: bold; } - - -/* @end */ - -/* @group Page Structure */ - -#content { - margin: 0 auto; - padding: 0 2em 6em; -} - -#package-header { - background: rgb(41,56,69); - border-top: 5px solid rgb(78,98,114); - color: #ddd; - padding: 0.2em; - position: relative; - text-align: left; -} - -#package-header .caption { - background: url(hslogo-16.png) no-repeat 0em; - color: white; - margin: 0 2em; - font-weight: normal; - font-style: normal; - padding-left: 2em; -} - -#package-header a:link, #package-header a:visited { color: white; } -#package-header a:hover { background: rgb(78,98,114); } - -#module-header .caption { - color: rgb(78,98,114); - font-weight: bold; - border-bottom: 1px solid #ddd; -} - -table.info { - float: right; - padding: 0.5em 1em; - border: 1px solid #ddd; - color: rgb(78,98,114); - background-color: #fff; - max-width: 40%; - border-spacing: 0; - position: relative; - top: -0.5em; - margin: 0 0 0 2em; -} - -.info th { - padding: 0 1em 0 0; -} - -div#style-menu-holder { - position: relative; - z-index: 2; - display: inline; -} - -#style-menu { - position: absolute; - z-index: 1; - overflow: visible; - background: #374c5e; - margin: 0; - text-align: center; - right: 0; - padding: 0; - top: 1.25em; -} - -#style-menu li { - display: list-item; - border-style: none; - margin: 0; - padding: 0; - color: #000; - list-style-type: none; -} - -#style-menu li + li { - border-top: 1px solid #919191; -} - -#style-menu a { - width: 6em; - padding: 3px; - display: block; -} - -#footer { - background: #ddd; - border-top: 1px solid #aaa; - padding: 0.5em 0; - color: #666; - text-align: center; - position: absolute; - bottom: 0; - width: 100%; - height: 3em; -} - -/* @end */ - -/* @group Front Matter */ - -#table-of-contents { - float: right; - clear: right; - background: #faf9dc; - border: 1px solid #d8d7ad; - padding: 0.5em 1em; - max-width: 20em; - margin: 0.5em 0 1em 1em; -} - -#table-of-contents .caption { - text-align: center; - margin: 0; -} - -#table-of-contents ul { - list-style: none; - margin: 0; -} - -#table-of-contents ul ul { - margin-left: 2em; -} - -#description .caption { - display: none; -} - -#synopsis { - display: none; -} - -.no-frame #synopsis { - display: block; - position: fixed; - right: 0; - height: 80%; - top: 10%; - padding: 0; -} - -#synopsis .caption { - float: left; - width: 29px; - color: rgba(255,255,255,0); - height: 110px; - margin: 0; - font-size: 1px; - padding: 0; -} - -#synopsis p.caption.collapser { - background: url(synopsis.png) no-repeat -64px -8px; -} - -#synopsis p.caption.expander { - background: url(synopsis.png) no-repeat 0px -8px; -} - -#synopsis ul { - height: 100%; - overflow: auto; - padding: 0.5em; - margin: 0; -} - -#synopsis ul ul { - overflow: hidden; -} - -#synopsis ul, -#synopsis ul li.src { - background-color: #faf9dc; - white-space: nowrap; - list-style: none; - margin-left: 0; -} - -/* @end */ - -/* @group Main Content */ - -#interface div.top { margin: 2em 0; } -#interface h1 + div.top, -#interface h2 + div.top, -#interface h3 + div.top, -#interface h4 + div.top, -#interface h5 + div.top { - margin-top: 1em; -} -#interface p.src .link { - float: right; - color: #919191; - border-left: 1px solid #919191; - background: #f0f0f0; - padding: 0 0.5em 0.2em; - margin: 0 -0.5em 0 0.5em; -} - -#interface span.fixity { - color: #919191; - border-left: 1px solid #919191; - padding: 0.2em 0.5em 0.2em 0.5em; - margin: 0 -1em 0 1em; -} - -#interface span.rightedge { - border-left: 1px solid #919191; - padding: 0.2em 0 0.2em 0; - margin: 0 0 0 1em; -} - -#interface table { border-spacing: 2px; } -#interface td { - vertical-align: top; - padding-left: 0.5em; -} -#interface td.src { - white-space: nowrap; -} -#interface td.doc p { - margin: 0; -} -#interface td.doc p + p { - margin-top: 0.8em; -} - -.subs dl { - margin: 0; -} - -.subs dt { - float: left; - clear: left; - display: block; - margin: 1px 0; -} - -.subs dd { - float: right; - width: 90%; - display: block; - padding-left: 0.5em; - margin-bottom: 0.5em; -} - -.subs dd.empty { - display: none; -} - -.subs dd p { - margin: 0; -} - -/* Render short-style data instances */ -.inst ul { - height: 100%; - padding: 0.5em; - margin: 0; -} - -.inst, .inst li { - list-style: none; - margin-left: 1em; -} - -.top p.src { - border-top: 1px solid #ccc; -} - -.subs, .doc { - /* use this selector for one level of indent */ - padding-left: 2em; -} - -.warning { - color: red; -} - -.arguments { - margin-top: -0.4em; -} -.arguments .caption { - display: none; -} - -.fields { padding-left: 1em; } - -.fields .caption { display: none; } - -.fields p { margin: 0 0; } - -/* this seems bulky to me -.methods, .constructors { - background: #f8f8f8; - border: 1px solid #eee; -} -*/ - -/* @end */ - -/* @group Auxillary Pages */ - - -.extension-list { - list-style-type: none; - margin-left: 0; -} - -#mini { - margin: 0 auto; - padding: 0 1em 1em; -} - -#mini > * { - font-size: 93%; /* 12pt */ -} - -#mini #module-list .caption, -#mini #module-header .caption { - font-size: 125%; /* 15pt */ -} - -#mini #interface h1, -#mini #interface h2, -#mini #interface h3, -#mini #interface h4 { - font-size: 109%; /* 13pt */ - margin: 1em 0 0; -} - -#mini #interface .top, -#mini #interface .src { - margin: 0; -} - -#mini #module-list ul { - list-style: none; - margin: 0; -} - -#alphabet ul { - list-style: none; - padding: 0; - margin: 0.5em 0 0; - text-align: center; -} - -#alphabet li { - display: inline; - margin: 0 0.25em; -} - -#alphabet a { - font-weight: bold; -} - -#index .caption, -#module-list .caption { font-size: 131%; /* 17pt */ } - -#index table { - margin-left: 2em; -} - -#index .src { - font-weight: bold; -} -#index .alt { - font-size: 77%; /* 10pt */ - font-style: italic; - padding-left: 2em; -} - -#index td + td { - padding-left: 1em; -} - -#module-list ul { - list-style: none; - margin: 0 0 0 2em; -} - -#module-list li { - clear: right; -} - -#module-list span.collapser, -#module-list span.expander { - background-position: 0 0.3em; -} - -#module-list .package { - float: right; -} - -/* @end */ diff --git a/resources/html/Ocean.std-theme/plus.gif b/resources/html/Ocean.std-theme/plus.gif deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/plus.gif and /dev/null differ diff --git a/resources/html/Ocean.std-theme/synopsis.png b/resources/html/Ocean.std-theme/synopsis.png deleted file mode 100644 Binary files a/resources/html/Ocean.std-theme/synopsis.png and /dev/null differ diff --git a/resources/html/frames.html b/resources/html/frames.html deleted file mode 100644 --- a/resources/html/frames.html +++ /dev/null @@ -1,30 +0,0 @@ - - - - - - - - - - - - - - - diff --git a/resources/html/haddock-util.js b/resources/html/haddock-util.js deleted file mode 100644 --- a/resources/html/haddock-util.js +++ /dev/null @@ -1,344 +0,0 @@ -// Haddock JavaScript utilities - -var rspace = /\s\s+/g, - rtrim = /^\s+|\s+$/g; - -function spaced(s) { return (" " + s + " ").replace(rspace, " "); } -function trim(s) { return s.replace(rtrim, ""); } - -function hasClass(elem, value) { - var className = spaced(elem.className || ""); - return className.indexOf( " " + value + " " ) >= 0; -} - -function addClass(elem, value) { - var className = spaced(elem.className || ""); - if ( className.indexOf( " " + value + " " ) < 0 ) { - elem.className = trim(className + " " + value); - } -} - -function removeClass(elem, value) { - var className = spaced(elem.className || ""); - className = className.replace(" " + value + " ", " "); - elem.className = trim(className); -} - -function toggleClass(elem, valueOn, valueOff, bool) { - if (bool == null) { bool = ! hasClass(elem, valueOn); } - if (bool) { - removeClass(elem, valueOff); - addClass(elem, valueOn); - } - else { - removeClass(elem, valueOn); - addClass(elem, valueOff); - } - return bool; -} - - -function makeClassToggle(valueOn, valueOff) -{ - return function(elem, bool) { - return toggleClass(elem, valueOn, valueOff, bool); - } -} - -toggleShow = makeClassToggle("show", "hide"); -toggleCollapser = makeClassToggle("collapser", "expander"); - -function toggleSection(id) -{ - var b = toggleShow(document.getElementById("section." + id)); - toggleCollapser(document.getElementById("control." + id), b); - rememberCollapsed(id, b); - return b; -} - -var collapsed = {}; -function rememberCollapsed(id, b) -{ - if(b) - delete collapsed[id] - else - collapsed[id] = null; - - var sections = []; - for(var i in collapsed) - { - if(collapsed.hasOwnProperty(i)) - sections.push(i); - } - // cookie specific to this page; don't use setCookie which sets path=/ - document.cookie = "collapsed=" + escape(sections.join('+')); -} - -function restoreCollapsed() -{ - var cookie = getCookie("collapsed"); - if(!cookie) - return; - - var ids = cookie.split('+'); - for(var i in ids) - { - if(document.getElementById("section." + ids[i])) - toggleSection(ids[i]); - } -} - -function setCookie(name, value) { - document.cookie = name + "=" + escape(value) + ";path=/;"; -} - -function clearCookie(name) { - document.cookie = name + "=;path=/;expires=Thu, 01-Jan-1970 00:00:01 GMT;"; -} - -function getCookie(name) { - var nameEQ = name + "="; - var ca = document.cookie.split(';'); - for(var i=0;i < ca.length;i++) { - var c = ca[i]; - while (c.charAt(0)==' ') c = c.substring(1,c.length); - if (c.indexOf(nameEQ) == 0) { - return unescape(c.substring(nameEQ.length,c.length)); - } - } - return null; -} - - - -var max_results = 75; // 50 is not enough to search for map in the base libraries -var shown_range = null; -var last_search = null; - -function quick_search() -{ - perform_search(false); -} - -function full_search() -{ - perform_search(true); -} - - -function perform_search(full) -{ - var text = document.getElementById("searchbox").value.toLowerCase(); - if (text == last_search && !full) return; - last_search = text; - - var table = document.getElementById("indexlist"); - var status = document.getElementById("searchmsg"); - var children = table.firstChild.childNodes; - - // first figure out the first node with the prefix - var first = bisect(-1); - var last = (first == -1 ? -1 : bisect(1)); - - if (first == -1) - { - table.className = ""; - status.innerHTML = "No results found, displaying all"; - } - else if (first == 0 && last == children.length - 1) - { - table.className = ""; - status.innerHTML = ""; - } - else if (last - first >= max_results && !full) - { - table.className = ""; - status.innerHTML = "More than " + max_results + ", press Search to display"; - } - else - { - // decide what you need to clear/show - if (shown_range) - setclass(shown_range[0], shown_range[1], "indexrow"); - setclass(first, last, "indexshow"); - shown_range = [first, last]; - table.className = "indexsearch"; - status.innerHTML = ""; - } - - - function setclass(first, last, status) - { - for (var i = first; i <= last; i++) - { - children[i].className = status; - } - } - - - // do a binary search, treating 0 as ... - // return either -1 (no 0's found) or location of most far match - function bisect(dir) - { - var first = 0, finish = children.length - 1; - var mid, success = false; - - while (finish - first > 3) - { - mid = Math.floor((finish + first) / 2); - - var i = checkitem(mid); - if (i == 0) i = dir; - if (i == -1) - finish = mid; - else - first = mid; - } - var a = (dir == 1 ? first : finish); - var b = (dir == 1 ? finish : first); - for (var i = b; i != a - dir; i -= dir) - { - if (checkitem(i) == 0) return i; - } - return -1; - } - - - // from an index, decide what the result is - // 0 = match, -1 is lower, 1 is higher - function checkitem(i) - { - var s = getitem(i).toLowerCase().substr(0, text.length); - if (s == text) return 0; - else return (s > text ? -1 : 1); - } - - - // from an index, get its string - // this abstracts over alternates - function getitem(i) - { - for ( ; i >= 0; i--) - { - var s = children[i].firstChild.firstChild.data; - if (s.indexOf(' ') == -1) - return s; - } - return ""; // should never be reached - } -} - -function setSynopsis(filename) { - if (parent.window.synopsis) { - if (parent.window.synopsis.location.replace) { - // In Firefox this avoids adding the change to the history. - parent.window.synopsis.location.replace(filename); - } else { - parent.window.synopsis.location = filename; - } - } -} - -function addMenuItem(html) { - var menu = document.getElementById("page-menu"); - if (menu) { - var btn = menu.firstChild.cloneNode(false); - btn.innerHTML = html; - menu.appendChild(btn); - } -} - -function adjustForFrames() { - var bodyCls; - - if (parent.location.href == window.location.href) { - // not in frames, so add Frames button - addMenuItem("Frames"); - bodyCls = "no-frame"; - } - else { - bodyCls = "in-frame"; - } - addClass(document.body, bodyCls); -} - -function reframe() { - setCookie("haddock-reframe", document.URL); - window.location = "frames.html"; -} - -function postReframe() { - var s = getCookie("haddock-reframe"); - if (s) { - parent.window.main.location = s; - clearCookie("haddock-reframe"); - } -} - -function styles() { - var i, a, es = document.getElementsByTagName("link"), rs = []; - for (i = 0; a = es[i]; i++) { - if(a.rel.indexOf("style") != -1 && a.title) { - rs.push(a); - } - } - return rs; -} - -function addStyleMenu() { - var as = styles(); - var i, a, btns = ""; - for(i=0; a = as[i]; i++) { - btns += "
  • " - + a.title + "
    • " - } - if (as.length > 1) { - var h = "
    " - + "Style ▾" - + "
      " + btns + "
    " - + "
    "; - addMenuItem(h); - } -} - -function setActiveStyleSheet(title) { - var as = styles(); - var i, a, found; - for(i=0; a = as[i]; i++) { - a.disabled = true; - // need to do this always, some browsers are edge triggered - if(a.title == title) { - found = a; - } - } - if (found) { - found.disabled = false; - setCookie("haddock-style", title); - } - else { - as[0].disabled = false; - clearCookie("haddock-style"); - } - styleMenu(false); -} - -function resetStyle() { - var s = getCookie("haddock-style"); - if (s) setActiveStyleSheet(s); -} - - -function styleMenu(show) { - var m = document.getElementById('style-menu'); - if (m) toggleShow(m, show); -} - - -function pageLoad() { - addStyleMenu(); - adjustForFrames(); - resetStyle(); - restoreCollapsed(); -} - diff --git a/resources/latex/haddock.sty b/resources/latex/haddock.sty deleted file mode 100644 --- a/resources/latex/haddock.sty +++ /dev/null @@ -1,57 +0,0 @@ -% Default Haddock style definitions. To use your own style, invoke -% Haddock with the option --latex-style=mystyle. - -\usepackage{tabulary} % see below - -% make hyperlinks in the PDF, and add an expandabale index -\usepackage[pdftex,bookmarks=true]{hyperref} - -\newenvironment{haddocktitle} - {\begin{center}\bgroup\large\bfseries} - {\egroup\end{center}} -\newenvironment{haddockprologue}{\vspace{1in}}{} - -\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} - -\newcommand{\haddockbeginheader}{\hrulefill} -\newcommand{\haddockendheader}{\noindent\hrulefill} - -% a little gap before the ``Methods'' header -\newcommand{\haddockpremethods}{\vspace{2ex}} - -% inserted before \\begin{verbatim} -\newcommand{\haddockverb}{\small} - -% an identifier: add an index entry -\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} - -% The tabulary environment lets us have a column that takes up ``the -% rest of the space''. Unfortunately it doesn't allow -% the \end{tabulary} to be in the expansion of a macro, it must appear -% literally in the document text, so Haddock inserts -% the \end{tabulary} itself. -\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} -\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} - -\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} -\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} - -\makeatletter -\newenvironment{haddockdesc} - {\list{}{\labelwidth\z@ \itemindent-\leftmargin - \let\makelabel\haddocklabel}} - {\endlist} -\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} -\makeatother - -% after a declaration, start a new line for the documentation. -% Otherwise, the documentation starts right after the declaration, -% because we're using the list environment and the declaration is the -% ``label''. I tried making this newline part of the label, but -% couldn't get that to work reliably (the space seemed to stretch -% sometimes). -\newcommand{\haddockbegindoc}{\hfill\\[1ex]} - -% spacing between paragraphs and no \parindent looks better -\parskip=10pt plus2pt minus2pt -\setlength{\parindent}{0cm} diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs deleted file mode 100644 --- a/src/Documentation/Haddock.hs +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Documentation.Haddock --- Copyright : (c) David Waern 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskellorg --- Stability : experimental --- Portability : portable --- --- The Haddock API: A rudimentory, highly experimental API exposing some of --- the internals of Haddock. Don't expect it to be stable. ------------------------------------------------------------------------------ -module Documentation.Haddock ( - - -- * Interface - Interface(..), - InstalledInterface(..), - createInterfaces, - processModules, - - -- * Export items & declarations - ExportItem(..), - DocForDecl, - FnArgsDoc, - - -- * Cross-referencing - LinkEnv, - DocName(..), - - -- * Instances - DocInstance, - InstHead, - - -- * Documentation comments - Doc(..), - Example(..), - Hyperlink(..), - DocMarkup(..), - Documentation(..), - ArgMap, - AliasMap, - WarningMap, - DocMap, - HaddockModInfo(..), - markup, - - -- * Interface files - InterfaceFile(..), - readInterfaceFile, - nameCacheFromGhc, - freshNameCache, - NameCacheAccessor, - - -- * Flags and options - Flag(..), - DocOption(..), - - -- * Program entry point - haddock, -) where - - -import Haddock.InterfaceFile -import Haddock.Interface -import Haddock.Types -import Haddock.Options -import Haddock.Utils -import Haddock - - --- | Create 'Interface' structures from a given list of Haddock command-line --- flags and file or module names (as accepted by 'haddock' executable). Flags --- that control documentation generation or show help or version information --- are ignored. -createInterfaces - :: [Flag] -- ^ A list of command-line flags - -> [String] -- ^ File or module names - -> IO [Interface] -- ^ Resulting list of interfaces -createInterfaces flags modules = do - (_, ifaces, _) <- withGhc' flags (readPackagesAndProcessModules flags modules) - return ifaces diff --git a/src/Haddock.hs b/src/Haddock.hs deleted file mode 100644 --- a/src/Haddock.hs +++ /dev/null @@ -1,482 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE CPP, ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Haddock - A Haskell Documentation Tool --- --- Program entry point and top-level code. ------------------------------------------------------------------------------ -module Haddock (haddock, readPackagesAndProcessModules, withGhc') where - - -import Haddock.Backends.Xhtml -import Haddock.Backends.Xhtml.Themes (getThemes) -import Haddock.Backends.LaTeX -import Haddock.Backends.Hoogle -import Haddock.Interface -import Haddock.Parser -import Haddock.Types -import Haddock.Version -import Haddock.InterfaceFile -import Haddock.Options -import Haddock.Utils -import Haddock.GhcUtils hiding (pretty) - -import Control.Monad hiding (forM_) -import Data.Foldable (forM_) -import Data.List (isPrefixOf) -import Control.Exception -import Data.Maybe -import Data.IORef -import qualified Data.Map as Map -import System.IO -import System.Exit -import System.Directory - -#if defined(mingw32_HOST_OS) -import Foreign -import Foreign.C -import Data.Int -#endif - -#ifdef IN_GHC_TREE -import System.FilePath -#else -import qualified GHC.Paths as GhcPaths -import Paths_haddock -#endif - -import GHC hiding (verbosity) -import Config -import DynFlags hiding (verbosity) -import StaticFlags (discardStaticFlags) -import Panic (handleGhcException) -import Module - --------------------------------------------------------------------------------- --- * Exception handling --------------------------------------------------------------------------------- - - -handleTopExceptions :: IO a -> IO a -handleTopExceptions = - handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions - - --- | Either returns normally or throws an ExitCode exception; --- all other exceptions are turned into exit exceptions. -handleNormalExceptions :: IO a -> IO a -handleNormalExceptions inner = - (inner `onException` hFlush stdout) - `catches` - [ Handler (\(code :: ExitCode) -> exitWith code) - - , Handler (\(ex :: AsyncException) -> - case ex of - StackOverflow -> do - putStrLn "stack overflow: use -g +RTS -K to increase it" - exitFailure - _ -> do - putStrLn ("haddock: " ++ show ex) - exitFailure) - - , Handler (\(ex :: SomeException) -> do - putStrLn ("haddock: internal error: " ++ show ex) - exitFailure) - ] - - -handleHaddockExceptions :: IO a -> IO a -handleHaddockExceptions inner = - catches inner [Handler handler] - where - handler (e::HaddockException) = do - putStrLn $ "haddock: " ++ show e - exitFailure - - -handleGhcExceptions :: IO a -> IO a -handleGhcExceptions = - -- error messages propagated as exceptions - handleGhcException $ \e -> do - hFlush stdout - case e of - PhaseFailed _ code -> exitWith code - _ -> do - print (e :: GhcException) - exitFailure - - -------------------------------------------------------------------------------- --- * Top level -------------------------------------------------------------------------------- - - --- | Run Haddock with given list of arguments. --- --- Haddock's own main function is defined in terms of this: --- --- > main = getArgs >>= haddock -haddock :: [String] -> IO () -haddock args = handleTopExceptions $ do - - -- Parse command-line flags and handle some of them initially. - -- TODO: unify all of this (and some of what's in the 'render' function), - -- into one function that returns a record with a field for each option, - -- or which exits with an error or help message. - (flags, files) <- parseHaddockOpts args - shortcutFlags flags - qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} - - -- inject dynamic-too into flags before we proceed - flags' <- withGhc' flags $ do - df <- getDynFlags - case lookup "GHC Dynamic" (compilerInfo df) of - Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags - _ -> return flags - - unless (Flag_NoWarnings `elem` flags) $ do - forM_ (warnings args) $ \warning -> do - hPutStrLn stderr warning - - withGhc' flags' $ do - - dflags <- getDynFlags - - if not (null files) then do - (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files - - -- Dump an "interface file" (.haddock file), if requested. - forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do - writeInterfaceFile path InterfaceFile { - ifInstalledIfaces = map toInstalledIface ifaces - , ifLinkEnv = homeLinks - } - - -- Render the interfaces. - liftIO $ renderStep dflags flags qual packages ifaces - - else do - when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ - throwE "No input file(s)." - - -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) - - -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags flags qual packages [] - --- | Create warnings about potential misuse of -optghc -warnings :: [String] -> [String] -warnings = map format . filter (isPrefixOf "-optghc") - where - format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] - - -withGhc' :: [Flag] -> Ghc a -> IO a -withGhc' flags action = do - libDir <- fmap snd (getGhcDirs flags) - - -- Catches all GHC source errors, then prints and re-throws them. - let handleSrcErrors action' = flip handleSourceError action' $ \err -> do - printException err - liftIO exitFailure - - withGhc libDir (ghcFlags flags) (\_ -> handleSrcErrors action) - - -readPackagesAndProcessModules :: [Flag] -> [String] - -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) -readPackagesAndProcessModules flags files = do - -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) - - -- Create the interfaces -- this is the core part of Haddock. - let ifaceFiles = map snd packages - (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles - - return (packages, ifaces, homeLinks) - - -renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags flags qual pkgs interfaces = do - updateHTMLXRefs pkgs - let - ifaceFiles = map snd pkgs - installedIfaces = concatMap ifInstalledIfaces ifaceFiles - srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] - render dflags flags qual interfaces installedIfaces srcMap - - --- | Render the interfaces with whatever backend is specified in the flags. -render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render dflags flags qual ifaces installedIfaces srcMap = do - - let - title = fromMaybe "" (optTitle flags) - unicode = Flag_UseUnicode `elem` flags - pretty = Flag_PrettyHtml `elem` flags - opt_wiki_urls = wikiUrls flags - opt_contents_url = optContentsUrl flags - opt_index_url = optIndexUrl flags - odir = outputDir flags - opt_latex_style = optLaTeXStyle flags - - visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - - -- /All/ visible interfaces including external package modules. - allIfaces = map toInstalledIface ifaces ++ installedIfaces - allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] - - pkgMod = ifaceMod (head ifaces) - pkgId = modulePackageId pkgMod - pkgStr = Just (packageIdString pkgId) - (pkgName,pkgVer) = modulePackageInfo pkgMod - - (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags - srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity - -- TODO: Get these from the interface files as with srcMap - srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity - sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') - - libDir <- getHaddockLibDir flags - prologue <- getPrologue dflags flags - themes <- getThemes libDir flags >>= either bye return - - when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title pkgStr - themes opt_contents_url sourceUrls' opt_wiki_urls - allVisibleIfaces pretty - copyHtmlBits odir libDir themes - - when (Flag_GenContents `elem` flags) $ do - ppHtmlContents odir title pkgStr - themes opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty - (makeContentsQual qual) - copyHtmlBits odir libDir themes - - when (Flag_Html `elem` flags) $ do - ppHtml title pkgStr visibleIfaces odir - prologue - themes sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes - - when (Flag_Hoogle `elem` flags) $ do - let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName - ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir - - when (Flag_LaTeX `elem` flags) $ do - ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style - libDir - - -------------------------------------------------------------------------------- --- * Reading and dumping interface files -------------------------------------------------------------------------------- - - -readInterfaceFiles :: MonadIO m - => NameCacheAccessor m - -> [(DocPaths, FilePath)] - -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do - catMaybes `liftM` mapM tryReadIface pairs - where - -- try to read an interface, warn if we can't - tryReadIface (paths, file) = do - eIface <- readInterfaceFile name_cache_accessor file - case eIface of - Left err -> liftIO $ do - putStrLn ("Warning: Cannot read " ++ file ++ ":") - putStrLn (" " ++ err) - putStrLn "Skipping this interface." - return Nothing - Right f -> return $ Just (paths, f) - - -------------------------------------------------------------------------------- --- * Creating a GHC session -------------------------------------------------------------------------------- - - --- | Start a GHC session with the -haddock flag set. Also turn off --- compilation and linking. Then run the given 'Ghc' action. -withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc libDir flags ghcActs = runGhc (Just libDir) $ do - dynflags <- getSessionDynFlags - dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) { - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink - } - let dynflags'' = gopt_unset dynflags' Opt_SplitObjs - defaultCleanupHandler dynflags'' $ do - -- ignore the following return-value, which is a list of packages - -- that may need to be re-linked: Haddock doesn't do any - -- dynamic or static linking at all! - _ <- setSessionDynFlags dynflags'' - ghcActs dynflags'' - where - parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags - parseGhcFlags dynflags = do - -- TODO: handle warnings? - - -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot - -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if - -- we pass any, Haddock will fail. Since StaticFlags are global to the - -- GHC invocation, there's also no way to reparse/save them to set them - -- again properly. - -- - -- This is a bit of a hack until we get rid of the rest of the remaining - -- StaticFlags. See GHC issue #8276. - let flags' = discardStaticFlags flags - (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags') - if not (null rest) - then throwE ("Couldn't parse GHC options: " ++ unwords flags') - else return dynflags' - -------------------------------------------------------------------------------- --- * Misc -------------------------------------------------------------------------------- - - -getHaddockLibDir :: [Flag] -> IO String -getHaddockLibDir flags = - case [str | Flag_Lib str <- flags] of - [] -> do -#ifdef IN_GHC_TREE - getInTreeDir -#else - d <- getDataDir -- provided by Cabal - doesDirectoryExist d >>= \exists -> case exists of - True -> return d - False -> do - -- If directory does not exist then we are probably invoking from - -- ./dist/build/haddock/haddock so we use ./resources as a fallback. - doesDirectoryExist "resources" >>= \exists_ -> case exists_ of - True -> return "resources" - False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n") -#endif - fs -> return (last fs) - - -getGhcDirs :: [Flag] -> IO (String, String) -getGhcDirs flags = do - case [ dir | Flag_GhcLibDir dir <- flags ] of - [] -> do -#ifdef IN_GHC_TREE - libDir <- getInTreeDir - return (ghcPath, libDir) -#else - return (ghcPath, GhcPaths.libdir) -#endif - xs -> return (ghcPath, last xs) - where -#ifdef IN_GHC_TREE - ghcPath = "not available" -#else - ghcPath = GhcPaths.ghc -#endif - - -shortcutFlags :: [Flag] -> IO () -shortcutFlags flags = do - usage <- getUsage - - when (Flag_Help `elem` flags) (bye usage) - when (Flag_Version `elem` flags) byeVersion - when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n")) - when (Flag_CompatibleInterfaceVersions `elem` flags) - (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\n")) - when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n")) - - when (Flag_PrintGhcPath `elem` flags) $ do - dir <- fmap fst (getGhcDirs flags) - bye $ dir ++ "\n" - - when (Flag_PrintGhcLibDir `elem` flags) $ do - dir <- fmap snd (getGhcDirs flags) - bye $ dir ++ "\n" - - when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $ - throwE "Unicode can only be enabled for HTML output." - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Html `elem` flags) $ - throwE "-h cannot be used with --gen-index or --gen-contents" - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_Hoogle `elem` flags) $ - throwE "--hoogle cannot be used with --gen-index or --gen-contents" - - when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) - && Flag_LaTeX `elem` flags) $ - throwE "--latex cannot be used with --gen-index or --gen-contents" - where - byeVersion = bye $ - "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" - ++ "Ported to use the GHC API by David Waern 2006-2008\n" - - -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () -updateHTMLXRefs packages = do - writeIORef html_xrefs_ref (Map.fromList mapping) - writeIORef html_xrefs_ref' (Map.fromList mapping') - where - mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages - , iface <- ifInstalledIfaces ifaces ] - mapping' = [ (moduleName m, html) | (m, html) <- mapping ] - - -getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName)) -getPrologue dflags flags = - case [filename | Flag_Prologue filename <- flags ] of - [] -> return Nothing - [filename] -> do - str <- readFile filename - case parseParasMaybe dflags str of - Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename - Just doc -> return (Just doc) - _otherwise -> throwE "multiple -p/--prologue options" - - -#ifdef IN_GHC_TREE - -getInTreeDir :: IO String -getInTreeDir = do - m <- getExecDir - case m of - Nothing -> error "No GhcDir found" - Just d -> return (d ".." "lib") - - -getExecDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) -getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. - where - try_size size = allocaArray (fromIntegral size) $ \buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> return Nothing - _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf - | otherwise -> try_size (size * 2) - -foreign import stdcall unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 -#else -getExecDir = return Nothing -#endif - -#endif diff --git a/src/Haddock/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs deleted file mode 100644 --- a/src/Haddock/Backends/HaddockDB.hs +++ /dev/null @@ -1,170 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.HaddockDB --- Copyright : (c) Simon Marlow 2003 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.HaddockDB (ppDocBook) where - -{- -import HaddockTypes -import HaddockUtil -import HsSyn2 - -import Text.PrettyPrint --} - ------------------------------------------------------------------------------ --- Printing the results in DocBook format - -ppDocBook :: a -ppDocBook = error "not working" -{- -ppDocBook :: FilePath -> [(Module, Interface)] -> String -ppDocBook odir mods = render (ppIfaces mods) - -ppIfaces mods - = text "" - $$ 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 deleted file mode 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ /dev/null @@ -1,331 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Hoogle --- Copyright : (c) Neil Mitchell 2006-2008 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Write out Hoogle compatible documentation --- http://www.haskell.org/hoogle/ ------------------------------------------------------------------------------ -module Haddock.Backends.Hoogle ( - ppHoogle - ) where - - -import Haddock.GhcUtils -import Haddock.Types -import Haddock.Utils hiding (out) -import GHC -import Outputable - -import Data.Char -import Data.List -import Data.Maybe -import System.FilePath -import System.IO - -prefix :: [String] -prefix = ["-- Hoogle documentation, generated by Haddock" - ,"-- See Hoogle, http://www.haskell.org/hoogle/" - ,""] - - -ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle dflags package version synopsis prologue ifaces odir = do - let filename = package ++ ".txt" - contents = prefix ++ - docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ - ["@package " ++ package] ++ - ["@version " ++ version | version /= ""] ++ - concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] - h <- openFile (odir filename) WriteMode - hSetEncoding h utf8 - hPutStr h (unlines contents) - hClose h - -ppModule :: DynFlags -> Interface -> [String] -ppModule dflags iface = - "" : ppDocumentation dflags (ifaceDoc iface) ++ - ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap (ppExport dflags) (ifaceExportItems iface) ++ - concatMap (ppInstance dflags) (ifaceInstances iface) - - ---------------------------------------------------------------------- --- Utility functions - -dropHsDocTy :: HsType a -> HsType a -dropHsDocTy = f - where - g (L src x) = L src (f x) - f (HsForAllTy a b c d) = HsForAllTy a b c (g d) - f (HsBangTy a b) = HsBangTy a (g b) - f (HsAppTy a b) = HsAppTy (g a) (g b) - f (HsFunTy a b) = HsFunTy (g a) (g b) - f (HsListTy a) = HsListTy (g a) - f (HsPArrTy a) = HsPArrTy (g a) - f (HsTupleTy a b) = HsTupleTy a (map g b) - f (HsOpTy a b c) = HsOpTy (g a) b (g c) - f (HsParTy a) = HsParTy (g a) - f (HsKindSig a b) = HsKindSig (g a) b - f (HsDocTy a _) = f $ unL a - f x = x - -outHsType :: OutputableBndr a => DynFlags -> HsType a -> String -outHsType dflags = out dflags . dropHsDocTy - - -makeExplicit :: HsType a -> HsType a -makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c -makeExplicit x = x - -makeExplicitL :: LHsType a -> LHsType a -makeExplicitL (L src x) = L src (makeExplicit x) - - -dropComment :: String -> String -dropComment (' ':'-':'-':' ':_) = [] -dropComment (x:xs) = x : dropComment xs -dropComment [] = [] - - -out :: Outputable a => DynFlags -> a -> String -out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr - where - f xs | " " `isPrefixOf` xs = f $ drop 19 xs - f (x:xs) = x : f xs - f [] = [] - - -operator :: String -> String -operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" -operator x = x - - ---------------------------------------------------------------------- --- How to print each export - -ppExport :: DynFlags -> ExportItem Name -> [String] -ppExport dflags ExportDecl { expItemDecl = L _ decl - , expItemMbDoc = (dc, _) - , expItemSubDocs = subdocs - } = ppDocumentation dflags dc ++ f decl - where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d - f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ - f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ - f (SigD sig) = ppSig dflags sig - f _ = [] -ppExport _ _ = [] - - -ppSig :: DynFlags -> Sig Name -> [String] -ppSig dflags (TypeSig names sig) - = [operator prettyNames ++ " :: " ++ outHsType dflags typ] - where - prettyNames = intercalate ", " $ map (out dflags) names - typ = case unL sig of - HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c - x -> x -ppSig _ _ = [] - - --- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl Name -> [String] -ppClass dflags x = out dflags x{tcdSigs=[]} : - concatMap (ppSig dflags . addContext . unL) (tcdSigs x) - where - addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) - addContext (MinimalSig sig) = MinimalSig sig - addContext _ = error "expected TypeSig" - - f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d - f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) - - context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) - - -ppInstance :: DynFlags -> ClsInst -> [String] -ppInstance dflags x = [dropComment $ out dflags x] - - -ppSynonym :: DynFlags -> TyClDecl Name -> [String] -ppSynonym dflags x = [out dflags x] - -ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs - = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : - concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) - where - - -- GHC gives out "data Bar =", we want to delete the equals - -- also writes data : a b, when we want data (:) a b - showData d = unwords $ map f $ if last xs == "=" then init xs else xs - where - xs = words $ out dflags d - nam = out dflags $ tyClDeclLName d - f w = if w == nam then operator nam else w -ppData _ _ _ = panic "ppData" - --- | for constructors, and named-fields... -lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] -lookupCon dflags subdocs (L _ name) = case lookup name subdocs of - Just (d, _) -> ppDocumentation dflags d - _ -> [] - -ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) - ++ f (con_details con) - where - f (PrefixCon args) = [typeSig name $ args ++ [resType]] - f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] - f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat - [lookupCon dflags subdocs (cd_fld_name r) ++ - [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] - | r <- recs] - - funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) - apps = foldl1 (\x y -> reL $ HsAppTy x y) - - typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) - name = out dflags $ unL $ con_name con - - resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] - ResTyGADT x -> x - - ---------------------------------------------------------------------- --- DOCUMENTATION - -ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] -ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w - - -doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] -doc dflags = docWith dflags "" - - -docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] -docWith _ [] Nothing = [] -docWith dflags header d - = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ - [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ - maybe [] (showTags . markup (markupTag dflags)) d - - -data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String - deriving Show - -type Tags = [Tag] - -box :: (a -> b) -> a -> [b] -box f x = [f x] - -str :: String -> [Tag] -str a = [Str a] - --- want things like paragraph, pre etc to be handled by blank lines in the source document --- and things like \n and \t converted away --- much like blogger in HTML mode --- everything else wants to be included as tags, neatly nested for some (ul,li,ol) --- or inlne for others (a,i,tt) --- entities (&,>,<) should always be appropriately escaped - -markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] -markupTag dflags = Markup { - markupParagraph = box TagP, - markupEmpty = str "", - markupString = str, - markupAppend = (++), - markupIdentifier = box (TagInline "a") . str . out dflags, - markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, - markupModule = box (TagInline "a") . str, - markupWarning = box (TagInline "i"), - markupEmphasis = box (TagInline "i"), - markupBold = box (TagInline "b"), - markupMonospaced = box (TagInline "tt"), - markupPic = const $ str " ", - markupUnorderedList = box (TagL 'u'), - markupOrderedList = box (TagL 'o'), - markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), - markupCodeBlock = box TagPre, - markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), - markupAName = const $ str "", - markupProperty = box TagPre . str, - markupExample = box TagPre . str . unlines . map exampleToString, - markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h - } - - -showTags :: [Tag] -> [String] -showTags = intercalate [""] . map showBlock - - -showBlock :: Tag -> [String] -showBlock (TagP xs) = showInline xs -showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"] - where mid = concatMap (showInline . box (TagInline "li")) xs -showBlock (TagPre xs) = ["
    "] ++ 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/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs deleted file mode 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ /dev/null @@ -1,1221 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.LaTeX --- Copyright : (c) Simon Marlow 2010, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.LaTeX ( - ppLaTeX -) where - - -import Haddock.Types -import Haddock.Utils -import Haddock.GhcUtils -import Pretty hiding (Doc, quote) -import qualified Pretty - -import GHC -import OccName -import Name ( nameOccName ) -import RdrName ( rdrNameOcc ) -import FastString ( unpackFS, unpackLitString, zString ) - -import qualified Data.Map as Map -import System.Directory -import System.FilePath -import Data.Char -import Control.Monad -import Data.Maybe -import Data.List - -import Haddock.Doc (combineDocumentation) - --- import Debug.Trace - -{- SAMPLE OUTPUT - -\haddockmoduleheading{\texttt{Data.List}} -\hrulefill -{\haddockverb\begin{verbatim} -module Data.List ( - (++), head, last, tail, init, null, length, map, reverse, - ) where\end{verbatim}} -\hrulefill - -\section{Basic functions} -\begin{haddockdesc} -\item[\begin{tabular}{@{}l} -head\ ::\ {\char 91}a{\char 93}\ ->\ a -\end{tabular}]\haddockbegindoc -Extract the first element of a list, which must be non-empty. -\par - -\end{haddockdesc} -\begin{haddockdesc} -\item[\begin{tabular}{@{}l} -last\ ::\ {\char 91}a{\char 93}\ ->\ a -\end{tabular}]\haddockbegindoc -Extract the last element of a list, which must be finite and non-empty. -\par - -\end{haddockdesc} --} - - -{- TODO - * don't forget fixity!! --} - -ppLaTeX :: String -- Title - -> Maybe String -- Package name - -> [Interface] - -> FilePath -- destination directory - -> Maybe (Doc GHC.RdrName) -- prologue text, maybe - -> Maybe String -- style file - -> FilePath - -> IO () - -ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir - = do - createDirectoryIfMissing True odir - when (isNothing maybe_style) $ - copyFile (libdir "latex" haddockSty) (odir haddockSty) - ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces - mapM_ (ppLaTeXModule title odir) visible_ifaces - - -haddockSty :: FilePath -haddockSty = "haddock.sty" - - -type LaTeX = Pretty.Doc - - -ppLaTeXTop - :: String - -> Maybe String - -> FilePath - -> Maybe (Doc GHC.RdrName) - -> Maybe String - -> [Interface] - -> IO () - -ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do - - let tex = vcat [ - text "\\documentclass{book}", - text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), - text "\\begin{document}", - text "\\begin{titlepage}", - text "\\begin{haddocktitle}", - text doctitle, - text "\\end{haddocktitle}", - case prologue of - Nothing -> empty - Just d -> vcat [text "\\begin{haddockprologue}", - rdrDocToLaTeX d, - text "\\end{haddockprologue}"], - text "\\end{titlepage}", - text "\\tableofcontents", - vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], - text "\\end{document}" - ] - - mods = sort (map (moduleBasename.ifaceMod) ifaces) - - filename = odir (fromMaybe "haddock" packageStr <.> "tex") - - writeFile filename (show tex) - - -ppLaTeXModule :: String -> FilePath -> Interface -> IO () -ppLaTeXModule _title odir iface = do - createDirectoryIfMissing True odir - let - mdl = ifaceMod iface - mdl_str = moduleString mdl - - exports = ifaceRnExportItems iface - - tex = vcat [ - text "\\haddockmoduleheading" <> braces (text mdl_str), - text "\\label{module:" <> text mdl_str <> char '}', - text "\\haddockbeginheader", - verb $ vcat [ - text "module" <+> text mdl_str <+> lparen, - text " " <> fsep (punctuate (text ", ") $ - map exportListItem $ - filter forSummary exports), - text " ) where" - ], - text "\\haddockendheader" $$ text "", - description, - body - ] - - description - = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface - - body = processExports exports - -- - writeFile (odir moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) - - -string_txt :: TextDetails -> String -> String -string_txt (Chr c) s = c:s -string_txt (Str s1) s2 = s1 ++ s2 -string_txt (PStr s1) s2 = unpackFS s1 ++ s2 -string_txt (ZStr s1) s2 = zString s1 ++ s2 -string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - - -exportListItem :: ExportItem DocName -> LaTeX -exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } - = sep (punctuate comma . map ppDocBinder $ declNames decl) <> - case subdocs of - [] -> empty - _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) -exportListItem (ExportNoDecl y []) - = ppDocBinder y -exportListItem (ExportNoDecl y subs) - = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) -exportListItem (ExportModule mdl) - = text "module" <+> text (moduleString mdl) -exportListItem _ - = error "exportListItem" - - --- Deal with a group of undocumented exports together, to avoid lots --- of blank vertical space between them. -processExports :: [ExportItem DocName] -> LaTeX -processExports [] = empty -processExports (decl : es) - | Just sig <- isSimpleSig decl - = multiDecl [ ppTypeSig (map getName names) typ False - | (names,typ) <- sig:sigs ] $$ - processExports es' - where (sigs, es') = spanWith isSimpleSig es -processExports (ExportModule mdl : es) - = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ - processExports es' - where (mdls, es') = spanWith isExportModule es -processExports (e : es) = - processExport e $$ processExports es - - -isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) - , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } - | Map.null argDocs = Just (map unLoc lnames, t) -isSimpleSig _ = Nothing - - -isExportModule :: ExportItem DocName -> Maybe Module -isExportModule (ExportModule m) = Just m -isExportModule _ = Nothing - - -processExport :: ExportItem DocName -> LaTeX -processExport (ExportGroup lev _id0 doc) - = ppDocGroup lev (docToLaTeX doc) -processExport (ExportDecl decl doc subdocs insts fixities _splice) - = ppDecl decl doc insts subdocs fixities -processExport (ExportNoDecl y []) - = ppDocName y -processExport (ExportNoDecl y subs) - = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) -processExport (ExportModule mdl) - = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing -processExport (ExportDoc doc) - = docToLaTeX doc - - -ppDocGroup :: Int -> LaTeX -> LaTeX -ppDocGroup lev doc = sec lev <> braces doc - where sec 1 = text "\\section" - sec 2 = text "\\subsection" - sec 3 = text "\\subsubsection" - sec _ = text "\\paragraph" - - -declNames :: LHsDecl DocName -> [DocName] -declNames (L _ decl) = case decl of - TyClD d -> [tcdName d] - SigD (TypeSig lnames _) -> map unLoc lnames - SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] - ForD (ForeignImport (L _ n) _ _ _) -> [n] - ForD (ForeignExport (L _ n) _ _ _) -> [n] - _ -> error "declaration not supported by declNames" - - -forSummary :: (ExportItem DocName) -> Bool -forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True - - -moduleLaTeXFile :: Module -> FilePath -moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" - - -moduleBasename :: Module -> FilePath -moduleBasename mdl = map (\c -> if c == '.' then '-' else c) - (moduleNameString (moduleName mdl)) - - -------------------------------------------------------------------------------- --- * Decls -------------------------------------------------------------------------------- - - -ppDecl :: LHsDecl DocName - -> DocForDecl DocName - -> [DocInstance DocName] - -> [(DocName, DocForDecl DocName)] - -> [(DocName, Fixity)] - -> LaTeX - -ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of - TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode - TyClD d@(DataDecl {}) - -> ppDataDecl instances subdocs loc (Just doc) d unicode - TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode --- Family instances happen via FamInst now --- TyClD d@(TySynonym {}) --- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode --- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode - ForD d -> ppFor loc (doc, fnArgsDoc) d unicode - InstD _ -> empty - _ -> error "declaration not supported by ppDecl" - where - unicode = False - - -ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> - TyClDecl DocName -> Bool -> LaTeX -ppTyFam _ _ _ _ _ = - error "type family declarations are currently not supported by --latex" - - -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = - ppFunSig loc doc [name] typ unicode -ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" --- error "foreign declarations are currently not supported by --latex" - - -------------------------------------------------------------------------------- --- * Type Synonyms -------------------------------------------------------------------------------- - - --- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX - -ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars - , tcdRhs = ltype }) unicode - = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode - where - hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) - full = hdr <+> char '=' <+> ppLType unicode ltype - -ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" - - -------------------------------------------------------------------------------- --- * Function signatures -------------------------------------------------------------------------------- - - -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName - -> Bool -> LaTeX -ppFunSig loc doc docnames typ unicode = - ppTypeOrFunSig loc docnames typ doc - ( ppTypeSig names typ False - , hsep . punctuate comma $ map ppSymName names - , dcolon unicode) - unicode - where - names = map getName docnames - -ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName - -> HsPatSynDetails (LHsType DocName) -> LHsType DocName - -> LHsContext DocName -> LHsContext DocName - -> Bool -> LaTeX -ppLPatSig loc doc docname args typ prov req unicode = - ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode - -ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName - -> HsPatSynDetails (HsType DocName) -> HsType DocName - -> HsContext DocName -> HsContext DocName - -> Bool -> LaTeX -ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) - where - pref1 = hsep [ keyword "pattern" - , pp_ctx prov - , pp_head - , dcolon unicode - , pp_ctx req - , ppType unicode typ - ] - - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right] - - pp_type = ppParendType unicode - pp_ctx ctx = ppContext ctx unicode - -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName - -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) - -> Bool -> LaTeX -ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) - unicode - | Map.null argDocs = - declWithDoc pref1 (documentationToLaTeX doc) - | otherwise = - declWithDoc pref2 $ Just $ - text "\\haddockbeginargs" $$ - do_args 0 sep0 typ $$ - text "\\end{tabulary}\\par" $$ - fromMaybe empty (documentationToLaTeX doc) - where - do_largs n leader (L _ t) = do_args n leader t - - arg_doc n = rDoc (Map.lookup n argDocs) - - do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) - = decltt leader <-> - decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - - do_args n leader (HsForAllTy Implicit _ lctxt ltype) - | not (null (unLoc lctxt)) - = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ - do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype - do_args n leader (HsFunTy lt r) - = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ - do_largs (n+1) (arrow unicode) r - do_args n leader t - = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl - - -ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX -ppTypeSig nms ty unicode = - hsep (punctuate comma $ map ppSymName nms) - <+> dcolon unicode - <+> ppType unicode ty - - -ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] -ppTyVars tvs = map ppSymName (tyvarNames tvs) - - -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames - - -declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX -declWithDoc decl doc = - text "\\begin{haddockdesc}" $$ - text "\\item[\\begin{tabular}{@{}l}" $$ - text (latexMonoFilter (show decl)) $$ - text "\\end{tabular}]" <> - (if isNothing doc then empty else text "\\haddockbegindoc") $$ - maybe empty id doc $$ - text "\\end{haddockdesc}" - - --- in a group of decls, we don't put them all in the same tabular, --- because that would prevent the group being broken over a page --- boundary (breaks Foreign.C.Error for example). -multiDecl :: [LaTeX] -> LaTeX -multiDecl decls = - text "\\begin{haddockdesc}" $$ - vcat [ - text "\\item[" $$ - text (latexMonoFilter (show decl)) $$ - text "]" - | decl <- decls ] $$ - text "\\end{haddockdesc}" - - -------------------------------------------------------------------------------- --- * Rendering Doc -------------------------------------------------------------------------------- - - -maybeDoc :: Maybe (Doc DocName) -> LaTeX -maybeDoc = maybe empty docToLaTeX - - --- for table cells, we strip paragraphs out to avoid extra vertical space --- and don't add a quote environment. -rDoc :: Maybe (Doc DocName) -> LaTeX -rDoc = maybeDoc . fmap latexStripTrailingWhitespace - - -------------------------------------------------------------------------------- --- * Class declarations -------------------------------------------------------------------------------- - - -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] - -> Bool -> LaTeX -ppClassHdr summ lctxt n tvs fds unicode = - keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode - - -ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX -ppFds fds unicode = - if null fds then empty else - char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) - where - fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> - hsep (map ppDocName vars2) - - -ppClassDecl :: [DocInstance DocName] -> SrcSpan - -> Documentation DocName -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> LaTeX -ppClassDecl instances loc doc subdocs - (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds - , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode - = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ - instancesBit - where - classheader - | null lsigs = hdr unicode - | otherwise = hdr unicode <+> keyword "where" - - hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds - - body = catMaybes [documentationToLaTeX doc, body_] - - body_ - | null lsigs, null ats, null at_defs = Nothing - | null ats, null at_defs = Just methodTable ---- | otherwise = atTable $$ methodTable - | otherwise = error "LaTeX.ppClassDecl" - - methodTable = - text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names typ unicode - | L _ (TypeSig lnames (L _ typ)) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? - - instancesBit = ppDocInstances unicode instances - -ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - -ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX -ppDocInstances _unicode [] = empty -ppDocInstances unicode (i : rest) - | Just ihead <- isUndocdInstance i - = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ - ppDocInstances unicode rest' - | otherwise - = ppDocInstance unicode i $$ ppDocInstances unicode rest - where - (is, rest') = spanWith isUndocdInstance rest - -isUndocdInstance :: DocInstance a -> Maybe (InstHead a) -isUndocdInstance (i,Nothing) = Just i -isUndocdInstance _ = Nothing - --- | Print a possibly commented instance. The instance header is printed inside --- an 'argBox'. The comment is printed to the right of the box in normal comment --- style. -ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, doc) = - declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) - - -ppInstDecl :: Bool -> InstHead DocName -> LaTeX -ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead - - -ppInstHead :: Bool -> InstHead DocName -> LaTeX -ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode -ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode - <+> maybe empty (\t -> equals <+> ppType unicode t) rhs -ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = - error "data instances not supported by --latex yet" - -lookupAnySubdoc :: (Eq name1) => - name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 -lookupAnySubdoc n subdocs = case lookup n subdocs of - Nothing -> noDocForDecl - Just docs -> docs - - -------------------------------------------------------------------------------- --- * Data & newtype declarations -------------------------------------------------------------------------------- - - -ppDataDecl :: [DocInstance DocName] -> - [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> - LaTeX -ppDataDecl instances subdocs _loc doc dataDecl unicode - - = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) - (if null body then Nothing else Just (vcat body)) - $$ instancesBit - - where - cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons - - body = catMaybes [constrBit, doc >>= documentationToLaTeX] - - (whereBit, leaders) - | null cons = (empty,[]) - | otherwise = case resTy of - ResTyGADT _ -> (decltt (keyword "where"), repeat empty) - _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) - - constrBit - | null cons = Nothing - | otherwise = Just $ - text "\\haddockbeginconstrs" $$ - vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ - text "\\end{tabulary}\\par" - - instancesBit = ppDocInstances unicode instances - - --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then empty else ppForall) - <+> - (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") - where - ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " - Implicit -> empty - - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con) = - leader <-> - case con_res con of - ResTyH98 -> case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppBinder occ) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon fields -> - (decltt (header_ unicode <+> ppBinder occ) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppBinder occ, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl - - ResTyGADT resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) fields) - - doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] - ) <-> rDoc mbDoc - - - header_ = ppConstrHdr forall tyVars context - occ = nameOccName . getName . unLoc . con_name $ con - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall = con_explicit con - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) - - -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = - decltt (ppBinder (nameOccName . getName $ name) - <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc - where - -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= combineDocumentation . fst - --- {- --- ppHsFullConstr :: HsConDecl -> LaTeX --- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = --- declWithDoc False doc ( --- hsep ((ppHsConstrHdr tvs ctxt +++ --- ppHsBinder False nm) : map ppHsBangType typeList) --- ) --- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = --- td << vanillaTable << ( --- case doc of --- Nothing -> aboves [hdr, fields_html] --- Just _ -> aboves [hdr, constr_doc, fields_html] --- ) --- --- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) --- --- constr_doc --- | isJust doc = docBox (docToLaTeX (fromJust doc)) --- | otherwise = LaTeX.emptyTable --- --- fields_html = --- td << --- table ! [width "100%", cellpadding 0, cellspacing 8] << ( --- aboves (map ppFullField (concat (map expandField fields))) --- ) --- -} --- --- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX --- ppShortField summary unicode (ConDeclField (L _ name) ltype _) --- = tda [theclass "recfield"] << ( --- ppBinder summary (docNameOcc name) --- <+> dcolon unicode <+> ppLType unicode ltype --- ) --- --- {- --- ppFullField :: HsFieldDecl -> LaTeX --- ppFullField (HsFieldDecl [n] ty doc) --- = declWithDoc False doc ( --- ppHsBinder False n <+> dcolon <+> ppHsBangType ty --- ) --- ppFullField _ = error "ppFullField" --- --- expandField :: HsFieldDecl -> [HsFieldDecl] --- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --- -} - - --- | Print the LHS of a data\/newtype declaration. --- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX -ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars - , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode - = -- newtype or data - (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> - -- context - ppLContext ctxt unicode <+> - -- T a b c ..., or a :+: b - ppAppDocNameNames False name (tyvarNames tyvars) -ppDataHeader _ _ = error "ppDataHeader: illegal argument" - --------------------------------------------------------------------------------- --- * Type applications --------------------------------------------------------------------------------- - - --- | Print an application of a DocName and two lists of HsTypes (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX -ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) - - --- | Print an application of a DocName and a list of Names -ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX -ppAppDocNameNames _summ n ns = - ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName - - --- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX -ppTypeApp n [] (t1:t2:rest) ppDN ppT - | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) - | operator = opApp - where - operator = isNameSym . getName $ n - opApp = ppT t1 <+> ppDN n <+> ppT t2 - -ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) - - -------------------------------------------------------------------------------- --- * Contexts -------------------------------------------------------------------------------- - - -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc - - -ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX -ppContextNoArrow [] _ = empty -ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode - - -ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX -ppContextNoLocs [] _ = empty -ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode - - -ppContext :: HsContext DocName -> Bool -> LaTeX -ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode - - -pp_hs_context :: [HsType DocName] -> Bool -> LaTeX -pp_hs_context [] _ = empty -pp_hs_context [p] unicode = ppType unicode p -pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) - - -------------------------------------------------------------------------------- --- * Types and contexts -------------------------------------------------------------------------------- - - -ppBang :: HsBang -> LaTeX -ppBang HsNoBang = empty -ppBang _ = char '!' -- Unpacked args is an implementation detail, - - -tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX -tupleParens HsUnboxedTuple = ubxParenList -tupleParens _ = parenList - - -------------------------------------------------------------------------------- --- * Rendering of HsType --- --- Stolen from Html and tweaked for LaTeX generation -------------------------------------------------------------------------------- - - -pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX -ppLType unicode y = ppType unicode (unLoc y) -ppLParendType unicode y = ppParendType unicode (unLoc y) -ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) - - -ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX -ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode -ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode -ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode - -ppLKind :: Bool -> LHsKind DocName -> LaTeX -ppLKind unicode y = ppKind unicode (unLoc y) - -ppKind :: Bool -> HsKind DocName -> LaTeX -ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode - - --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Bool -> LaTeX -ppForAll expl tvs cxt unicode - | show_forall = forall_part <+> ppLContext cxt unicode - | otherwise = ppLContext cxt unicode - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot - - -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX -ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode - - -ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] - -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" -ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode - where - ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op - occName = nameOccName . getName . unLoc $ op - -ppr_mono_ty ctxt_prec (HsParTy ty) unicode --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u - - -ppr_tylit :: HsTyLit -> Bool -> LaTeX -ppr_tylit (HsNumTy n) _ = integer n -ppr_tylit (HsStrTy s) _ = text (show s) - -- XXX: Ok in verbatim, but not otherwise - -- XXX: Do something with Unicode parameter? - - -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX -ppr_fun_ty ctxt_prec ty1 ty2 unicode - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode - p2 = ppr_mono_lty pREC_TOP ty2 unicode - in - maybeParen ctxt_prec pREC_FUN $ - sep [p1, arrow unicode <+> p2] - - -------------------------------------------------------------------------------- --- * Names -------------------------------------------------------------------------------- - - -ppBinder :: OccName -> LaTeX -ppBinder n - | isInfixName n = parens $ ppOccName n - | otherwise = ppOccName n - -ppBinderInfix :: OccName -> LaTeX -ppBinderInfix n - | isInfixName n = ppOccName n - | otherwise = quotes $ ppOccName n - -isInfixName :: OccName -> Bool -isInfixName n = isVarSym n || isConSym n - -ppSymName :: Name -> LaTeX -ppSymName name - | isNameSym name = parens $ ppName name - | otherwise = ppName name - - -ppVerbOccName :: OccName -> LaTeX -ppVerbOccName = text . latexFilter . occNameString - -ppIPName :: HsIPName -> LaTeX -ppIPName ip = text $ unpackFS $ hsIPNameFS ip - -ppOccName :: OccName -> LaTeX -ppOccName = text . occNameString - - -ppVerbDocName :: DocName -> LaTeX -ppVerbDocName = ppVerbOccName . nameOccName . getName - - -ppVerbRdrName :: RdrName -> LaTeX -ppVerbRdrName = ppVerbOccName . rdrNameOcc - - -ppDocName :: DocName -> LaTeX -ppDocName = ppOccName . nameOccName . getName - - -ppLDocName :: Located DocName -> LaTeX -ppLDocName (L _ d) = ppDocName d - - -ppDocBinder :: DocName -> LaTeX -ppDocBinder = ppBinder . nameOccName . getName - -ppDocBinderInfix :: DocName -> LaTeX -ppDocBinderInfix = ppBinderInfix . nameOccName . getName - - -ppName :: Name -> LaTeX -ppName = ppOccName . nameOccName - - -latexFilter :: String -> String -latexFilter = foldr latexMunge "" - - -latexMonoFilter :: String -> String -latexMonoFilter = foldr latexMonoMunge "" - - -latexMunge :: Char -> String -> String -latexMunge '#' s = "{\\char '43}" ++ s -latexMunge '$' s = "{\\char '44}" ++ s -latexMunge '%' s = "{\\char '45}" ++ s -latexMunge '&' s = "{\\char '46}" ++ s -latexMunge '~' s = "{\\char '176}" ++ s -latexMunge '_' s = "{\\char '137}" ++ s -latexMunge '^' s = "{\\char '136}" ++ s -latexMunge '\\' s = "{\\char '134}" ++ s -latexMunge '{' s = "{\\char '173}" ++ s -latexMunge '}' s = "{\\char '175}" ++ s -latexMunge '[' s = "{\\char 91}" ++ s -latexMunge ']' s = "{\\char 93}" ++ s -latexMunge c s = c : s - - -latexMonoMunge :: Char -> String -> String -latexMonoMunge ' ' s = '\\' : ' ' : s -latexMonoMunge '\n' s = '\\' : '\\' : s -latexMonoMunge c s = latexMunge c s - - -------------------------------------------------------------------------------- --- * Doc Markup -------------------------------------------------------------------------------- - - -parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) -parLatexMarkup ppId = Markup { - markupParagraph = \p v -> p v <> text "\\par" $$ text "", - markupEmpty = \_ -> empty, - markupString = \s v -> text (fixString v s), - markupAppend = \l r v -> l v <> r v, - markupIdentifier = markupId ppId, - markupIdentifierUnchecked = markupId (ppVerbOccName . snd), - markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), - markupWarning = \p v -> emph (p v), - markupEmphasis = \p v -> emph (p v), - markupBold = \p v -> bold (p v), - markupMonospaced = \p _ -> tt (p Mono), - markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", - markupPic = \p _ -> markupPic p, - markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", - markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), - markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \l _ -> markupLink l, - markupAName = \_ _ -> empty, - markupProperty = \p _ -> quote $ verb $ text p, - markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, - markupHeader = \(Header l h) p -> header l (h p) - } - where - header 1 d = text "\\section*" <> braces d - header 2 d = text "\\subsection*" <> braces d - header l d - | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d - header l _ = error $ "impossible header level in LaTeX generation: " ++ show l - - fixString Plain s = latexFilter s - fixString Verb s = s - fixString Mono s = latexMonoFilter s - - markupLink (Hyperlink url mLabel) = case mLabel of - Just label -> text "\\href" <> braces (text url) <> braces (text label) - Nothing -> text "\\url" <> braces (text url) - - -- Is there a better way of doing this? Just a space is an aribtrary choice. - markupPic (Picture uri title) = parens (imageText title) - where - imageText Nothing = beg - imageText (Just t) = beg <> text " " <> text t - - beg = text "image: " <> text uri - - markupId ppId_ id v = - case v of - Verb -> theid - Mono -> theid - Plain -> text "\\haddockid" <> braces theid - where theid = ppId_ id - - -latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) -latexMarkup = parLatexMarkup ppVerbDocName - - -rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) -rdrLatexMarkup = parLatexMarkup ppVerbRdrName - - -docToLaTeX :: Doc DocName -> LaTeX -docToLaTeX doc = markup latexMarkup doc Plain - - -documentationToLaTeX :: Documentation DocName -> Maybe LaTeX -documentationToLaTeX = fmap docToLaTeX . combineDocumentation - - -rdrDocToLaTeX :: Doc RdrName -> LaTeX -rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain - - -data StringContext = Plain | Verb | Mono - - -latexStripTrailingWhitespace :: Doc a -> Doc a -latexStripTrailingWhitespace (DocString s) - | null s' = DocEmpty - | otherwise = DocString s - where s' = reverse (dropWhile isSpace (reverse s)) -latexStripTrailingWhitespace (DocAppend l r) - | DocEmpty <- r' = latexStripTrailingWhitespace l - | otherwise = DocAppend l r' - where - r' = latexStripTrailingWhitespace r -latexStripTrailingWhitespace (DocParagraph p) = - latexStripTrailingWhitespace p -latexStripTrailingWhitespace other = other - - -------------------------------------------------------------------------------- --- * LaTeX utils -------------------------------------------------------------------------------- - - -itemizedList :: [LaTeX] -> LaTeX -itemizedList items = - text "\\begin{itemize}" $$ - vcat (map (text "\\item" $$) items) $$ - text "\\end{itemize}" - - -enumeratedList :: [LaTeX] -> LaTeX -enumeratedList items = - text "\\begin{enumerate}" $$ - vcat (map (text "\\item " $$) items) $$ - text "\\end{enumerate}" - - -descriptionList :: [(LaTeX,LaTeX)] -> LaTeX -descriptionList items = - text "\\begin{description}" $$ - vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ - text "\\end{description}" - - -tt :: LaTeX -> LaTeX -tt ltx = text "\\haddocktt" <> braces ltx - - -decltt :: LaTeX -> LaTeX -decltt ltx = text "\\haddockdecltt" <> braces ltx - - -emph :: LaTeX -> LaTeX -emph ltx = text "\\emph" <> braces ltx - -bold :: LaTeX -> LaTeX -bold ltx = text "\\textbf" <> braces ltx - -verb :: LaTeX -> LaTeX -verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" - -- NB. swallow a trailing \n in the verbatim text by appending the - -- \end{verbatim} directly, otherwise we get spurious blank lines at the - -- end of code blocks. - - -quote :: LaTeX -> LaTeX -quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" - - -dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX -dcolon unicode = text (if unicode then "∷" else "::") -arrow unicode = text (if unicode then "→" else "->") -darrow unicode = text (if unicode then "⇒" else "=>") -forallSymbol unicode = text (if unicode then "∀" else "forall") - - -dot :: LaTeX -dot = char '.' - - -parenList :: [LaTeX] -> LaTeX -parenList = parens . hsep . punctuate comma - - -ubxParenList :: [LaTeX] -> LaTeX -ubxParenList = ubxparens . hsep . punctuate comma - - -ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" - - -pabrackets :: LaTeX -> LaTeX -pabrackets h = text "[:" <> h <> text ":]" - - -nl :: LaTeX -nl = text "\\\\" - - -keyword :: String -> LaTeX -keyword = text - - -infixr 4 <-> -- combining table cells -(<->) :: LaTeX -> LaTeX -> LaTeX -a <-> b = a <+> char '&' <+> b diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ /dev/null @@ -1,690 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -{-# LANGUAGE CPP #-} -module Haddock.Backends.Xhtml ( - ppHtml, copyHtmlBits, - ppHtmlIndex, ppHtmlContents, -) where - - -import Prelude hiding (div) - -import Haddock.Backends.Xhtml.Decl -import Haddock.Backends.Xhtml.DocMarkup -import Haddock.Backends.Xhtml.Layout -import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Themes -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils -import Haddock.ModuleTree -import Haddock.Types -import Haddock.Version -import Haddock.Utils -import Text.XHtml hiding ( name, title, p, quote ) -import Haddock.GhcUtils - -import Control.Monad ( when, unless ) -#if !MIN_VERSION_base(4,7,0) -import Control.Monad.Instances ( ) -- for Functor Either a -#endif -import Data.Char ( toUpper ) -import Data.Functor ( (<$>) ) -import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) -import Data.Maybe -import System.FilePath hiding ( () ) -import System.Directory -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import qualified Data.Set as Set hiding ( Set ) -import Data.Function -import Data.Ord ( comparing ) - -import DynFlags (Language(..)) -import GHC hiding ( NoLink, moduleInfo ) -import Name -import Module - --------------------------------------------------------------------------------- --- * Generating HTML documentation --------------------------------------------------------------------------------- - - -ppHtml :: String - -> Maybe String -- ^ Package - -> [Interface] - -> FilePath -- ^ Destination directory - -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe - -> Themes -- ^ Themes - -> SourceURLs -- ^ The source URL (--source) - -> WikiURLs -- ^ The wiki URL (--wiki) - -> Maybe String -- ^ The contents URL (--use-contents) - -> Maybe String -- ^ The index URL (--use-index) - -> Bool -- ^ Whether to use unicode in output (--use-unicode) - -> QualOption -- ^ How to qualify names - -> Bool -- ^ Output pretty html (newlines and indenting) - -> IO () - -ppHtml doctitle maybe_package ifaces odir prologue - themes maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode - qual debug = do - let - visible_ifaces = filter visible ifaces - visible i = OptHide `notElem` ifaceOptions i - - when (isNothing maybe_contents_url) $ - ppHtmlContents odir doctitle maybe_package - themes maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) - False -- we don't want to display the packages in a single-package contents - prologue debug (makeContentsQual qual) - - when (isNothing maybe_index_url) $ - ppHtmlIndex odir doctitle maybe_package - themes maybe_contents_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) debug - - mapM_ (ppHtmlModule odir doctitle themes - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces - - -copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () -copyHtmlBits odir libdir themes = do - let - libhtmldir = joinPath [libdir, "html"] - copyCssFile f = copyFile f (combine odir (takeFileName f)) - copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) - mapM_ copyCssFile (cssFiles themes) - mapM_ copyLibFile [ jsFile, framesFile ] - - -headHtml :: String -> Maybe String -> Themes -> Html -headHtml docTitle miniPage themes = - header << [ - meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], - thetitle << docTitle, - styleSheet themes, - script ! [src jsFile, thetype "text/javascript"] << noHtml, - script ! [thetype "text/javascript"] - -- NB: Within XHTML, the content of script tags needs to be - -- a " in it! - << primHtml ( - "//\n") - ] - where - setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage - - -srcButton :: SourceURLs -> Maybe Interface -> Maybe Html -srcButton (Just src_base_url, _, _, _) Nothing = - Just (anchor ! [href src_base_url] << "Source") -srcButton (_, Just src_module_url, _, _) (Just iface) = - let url = spliceURL (Just $ ifaceOrigFilename iface) - (Just $ ifaceMod iface) Nothing Nothing src_module_url - in Just (anchor ! [href url] << "Source") -srcButton _ _ = - Nothing - - -wikiButton :: WikiURLs -> Maybe Module -> Maybe Html -wikiButton (Just wiki_base_url, _, _) Nothing = - Just (anchor ! [href wiki_base_url] << "User Comments") - -wikiButton (_, Just wiki_module_url, _) (Just mdl) = - let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url - in Just (anchor ! [href url] << "User Comments") - -wikiButton _ _ = - Nothing - - -contentsButton :: Maybe String -> Maybe Html -contentsButton maybe_contents_url - = Just (anchor ! [href url] << "Contents") - where url = fromMaybe contentsHtmlFile maybe_contents_url - - -indexButton :: Maybe String -> Maybe Html -indexButton maybe_index_url - = Just (anchor ! [href url] << "Index") - where url = fromMaybe indexHtmlFile maybe_index_url - - -bodyHtml :: String -> Maybe Interface - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String - -> Html -> Html -bodyHtml doctitle iface - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url - pageContent = - body << [ - divPackageHeader << [ - unordList (catMaybes [ - srcButton maybe_source_url iface, - wikiButton maybe_wiki_url (ifaceMod <$> iface), - contentsButton maybe_contents_url, - indexButton maybe_index_url]) - ! [theclass "links", identifier "page-menu"], - nonEmptySectionName << doctitle - ], - divContent << pageContent, - divFooter << paragraph << ( - "Produced by " +++ - (anchor ! [href projectUrl] << toHtml projectName) +++ - (" version " ++ projectVersion) - ) - ] - - -moduleInfo :: Interface -> Html -moduleInfo iface = - let - info = ifaceInfo iface - - doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable - doOneEntry (fieldName, field) = - field info >>= \a -> return (th << fieldName <-> td << a) - - entries :: [HtmlTable] - entries = mapMaybe doOneEntry [ - ("Copyright",hmi_copyright), - ("License",hmi_license), - ("Maintainer",hmi_maintainer), - ("Stability",hmi_stability), - ("Portability",hmi_portability), - ("Safe Haskell",hmi_safety), - ("Language", lg) - ] ++ extsForm - where - lg inf = case hmi_language inf of - Nothing -> Nothing - Just Haskell98 -> Just "Haskell98" - Just Haskell2010 -> Just "Haskell2010" - - extsForm - | OptShowExtensions `elem` ifaceOptions iface = - let fs = map (dropOpt . show) (hmi_extensions info) - in case map stringToHtml fs of - [] -> [] - [x] -> extField x -- don't use a list for a single extension - xs -> extField $ unordList xs ! [theclass "extension-list"] - | otherwise = [] - where - extField x = return $ th << "Extensions" <-> td << x - dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x - in - case entries of - [] -> noHtml - _ -> table ! [theclass "info"] << aboves entries - - --------------------------------------------------------------------------------- --- * Generate the module contents --------------------------------------------------------------------------------- - - -ppHtmlContents - :: FilePath - -> String - -> Maybe String - -> Themes - -> Maybe String - -> SourceURLs - -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) - -> Bool - -> Qualification -- ^ How to qualify names - -> IO () -ppHtmlContents odir doctitle _maybe_package - themes maybe_index_url - maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do - let tree = mkModuleTree showPkgs - [(instMod iface, toInstalledDescription iface) | iface <- ifaces] - html = - headHtml doctitle Nothing themes +++ - bodyHtml doctitle Nothing - maybe_source_url maybe_wiki_url - Nothing maybe_index_url << [ - ppPrologue qual doctitle prologue, - ppModuleTree qual tree - ] - createDirectoryIfMissing True odir - writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) - - -- XXX: think of a better place for this? - ppHtmlContentsFrame odir doctitle themes ifaces debug - - -ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html -ppPrologue _ _ Nothing = noHtml -ppPrologue qual title (Just doc) = - divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) - - -ppModuleTree :: Qualification -> [ModuleTree] -> Html -ppModuleTree qual ts = - divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) - - -mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html -mkNodeList qual ss p ts = case ts of - [] -> noHtml - _ -> unordList (zipWith (mkNode qual ss) ps ts) - where - ps = [ p ++ '.' : show i | i <- [(1::Int)..]] - - -mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg short ts) = - htmlModule <+> shortDescr +++ htmlPkg +++ subtree - where - modAttrs = case (ts, leaf) of - (_:_, False) -> collapseControl p True "module" - (_, _ ) -> [theclass "module"] - - cBtn = case (ts, leaf) of - (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml - (_, _ ) -> noHtml - -- We only need an explicit collapser button when the module name - -- is also a leaf, and so is a link to a module page. Indeed, the - -- spaceHtml is a minor hack and does upset the layout a fraction. - - htmlModule = thespan ! modAttrs << (cBtn +++ - if leaf - then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg)) - (mkModuleName mdl)) - else toHtml s - ) - - mdl = intercalate "." (reverse (s:ss)) - - shortDescr = maybe noHtml (origDocToHtml qual) short - htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg - - subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" - - --- | Turn a module tree into a flat list of full module names. E.g., --- @ --- A --- +-B --- +-C --- @ --- becomes --- @["A", "A.B", "A.B.C"]@ -flatModuleTree :: [InstalledInterface] -> [Html] -flatModuleTree ifaces = - map (uncurry ppModule' . head) - . groupBy ((==) `on` fst) - . sortBy (comparing fst) - $ mods - where - mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] - ppModule' txt mdl = - anchor ! [href (moduleHtmlFile mdl), target mainFrameName] - << toHtml txt - - -ppHtmlContentsFrame :: FilePath -> String -> Themes - -> [InstalledInterface] -> Bool -> IO () -ppHtmlContentsFrame odir doctitle themes ifaces debug = do - let mods = flatModuleTree ifaces - html = - headHtml doctitle Nothing themes +++ - miniBody << divModuleList << - (sectionName << "Modules" +++ - ulist << [ li ! [theclass "module"] << m | m <- mods ]) - createDirectoryIfMissing True odir - writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html) - - --------------------------------------------------------------------------------- --- * Generate the index --------------------------------------------------------------------------------- - - -ppHtmlIndex :: FilePath - -> String - -> Maybe String - -> Themes - -> Maybe String - -> SourceURLs - -> WikiURLs - -> [InstalledInterface] - -> Bool - -> IO () -ppHtmlIndex odir doctitle _maybe_package themes - maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do - let html = indexPage split_indices Nothing - (if split_indices then [] else index) - - createDirectoryIfMissing True odir - - when split_indices $ do - mapM_ (do_sub_index index) initialChars - -- Let's add a single large index as well for those who don't know exactly what they're looking for: - let mergedhtml = indexPage False Nothing index - writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) - - writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) - - where - indexPage showLetters ch items = - headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++ - bodyHtml doctitle Nothing - maybe_source_url maybe_wiki_url - maybe_contents_url Nothing << [ - if showLetters then indexInitialLetterLinks else noHtml, - if null items then noHtml else - divIndex << [sectionName << indexName ch, buildIndex items] - ] - - indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch - merged_name = "All" - - buildIndex items = table << aboves (map indexElt items) - - -- an arbitrary heuristic: - -- too large, and a single-page will be slow to load - -- too small, and we'll have lots of letter-indexes with only one - -- or two members in them, which seems inefficient or - -- unnecessarily hard to use. - split_indices = length index > 150 - - indexInitialLetterLinks = - divAlphabet << - unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ - [ [c] | c <- initialChars - , any ((==c) . toUpper . head . fst) index ] ++ - [merged_name]) - - -- todo: what about names/operators that start with Unicode - -- characters? - -- Exports beginning with '_' can be listed near the end, - -- presumably they're not as important... but would be listed - -- with non-split index! - initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" - - do_sub_index this_ix c - = unless (null index_part) $ - writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) - where - html = indexPage True (Just c) index_part - index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] - - - index :: [(String, Map GHC.Name [(Module,Bool)])] - index = sortBy cmp (Map.toAscList full_index) - where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2 - - -- for each name (a plain string), we have a number of original HsNames that - -- it can refer to, and for each of those we have a list of modules - -- that export that entity. Each of the modules exports the entity - -- in a visible or invisible way (hence the Bool). - full_index :: Map String (Map GHC.Name [(Module,Bool)]) - full_index = Map.fromListWith (flip (Map.unionWith (++))) - (concatMap getIfaceIndex ifaces) - - getIfaceIndex iface = - [ (getOccString name - , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) - | name <- instExports iface ] - where - mdl = instMod iface - visible = Set.fromList (instVisibleExports iface) - - indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable - indexElt (str, entities) = - case Map.toAscList entities of - [(nm,entries)] -> - td ! [ theclass "src" ] << toHtml str <-> - indexLinks nm entries - many_entities -> - td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml - aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) - - doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable - doAnnotatedEntity (j,(nm,entries)) - = td ! [ theclass "alt" ] << - toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> - indexLinks nm entries - - ppAnnot n | not (isValOcc n) = toHtml "Type/Class" - | isDataOcc n = toHtml "Data Constructor" - | otherwise = toHtml "Function" - - indexLinks nm entries = - td ! [ theclass "module" ] << - hsep (punctuate comma - [ if visible then - linkId mdl (Just nm) << toHtml (moduleString mdl) - else - toHtml (moduleString mdl) - | (mdl, visible) <- entries ]) - - --------------------------------------------------------------------------------- --- * Generate the HTML page for a module --------------------------------------------------------------------------------- - - -ppHtmlModule - :: FilePath -> String -> Themes - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> QualOption - -> Bool -> Interface -> IO () -ppHtmlModule odir doctitle themes - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode qual debug iface = do - let - mdl = ifaceMod iface - aliases = ifaceModuleAliases iface - mdl_str = moduleString mdl - real_qual = makeModuleQual qual aliases mdl - html = - headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ - bodyHtml doctitle (Just iface) - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url << [ - divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), - ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual - ] - - createDirectoryIfMissing True odir - writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug - -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes - -> Interface -> Bool -> Qualification -> Bool -> IO () -ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do - let mdl = ifaceMod iface - html = - headHtml (moduleString mdl) Nothing themes +++ - miniBody << - (divModuleHeader << sectionName << moduleString mdl +++ - miniSynopsis mdl iface unicode qual) - createDirectoryIfMissing True odir - writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) - - -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html -ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual - = ppModuleContents qual exports +++ - description +++ - synopsis +++ - divInterface (maybe_doc_hdr +++ bdy) - where - exports = numberSectionHeadings (ifaceRnExportItems iface) - - -- todo: if something has only sub-docs, or fn-args-docs, should - -- it be measured here and thus prevent omitting the synopsis? - has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning - has_doc (ExportNoDecl _ _) = False - has_doc (ExportModule _) = False - has_doc _ = True - - no_doc_at_all = not (any has_doc exports) - - description | isNoHtml doc = doc - | otherwise = divDescription $ sectionName << "Description" +++ doc - where doc = docSection qual (ifaceRnDoc iface) - - -- omit the synopsis if there are no documentation annotations at all - synopsis - | no_doc_at_all = noHtml - | otherwise - = divSynposis $ - paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ - shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports - ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") - - -- if the documentation doesn't begin with a section header, then - -- add one ("Documentation"). - maybe_doc_hdr - = case exports of - [] -> noHtml - ExportGroup {} : _ -> noHtml - _ -> h1 << "Documentation" - - bdy = - foldr (+++) noHtml $ - mapMaybe (processExport False linksInfo unicode qual) exports - - linksInfo = (maybe_source_url, maybe_wiki_url) - - -miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html -miniSynopsis mdl iface unicode qual = - divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports - where - exports = numberSectionHeadings (ifaceRnExportItems iface) - - -processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName - -> [Html] -processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = - ((divTopDecl <<).(declElem <<)) <$> case decl0 of - TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of - (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] - (DataDecl{}) -> [keyword "data" <+> b] - (SynDecl{}) -> [keyword "type" <+> b] - (ClassDecl {}) -> [keyword "class" <+> b] - _ -> [] - SigD (TypeSig lnames (L _ _)) -> - map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames - _ -> [] -processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = - [groupTag lvl << docToHtml qual txt] -processForMiniSynopsis _ _ _ _ = [] - - -ppNameMini :: Notation -> Module -> OccName -> Html -ppNameMini notation mdl nm = - anchor ! [ href (moduleNameUrl mdl nm) - , target mainFrameName ] - << ppBinder' notation nm - - -ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html -ppTyClBinderWithVarsMini mdl decl = - let n = tcdName decl - ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above - in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName - - -ppModuleContents :: Qualification -> [ExportItem DocName] -> Html -ppModuleContents qual exports - | null sections = noHtml - | otherwise = contentsDiv - where - contentsDiv = divTableOfContents << ( - sectionName << "Contents" +++ - unordList sections) - - (sections, _leftovers{-should be []-}) = process 0 exports - - process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) - process _ [] = ([], []) - process n items@(ExportGroup lev id0 doc : rest) - | lev <= n = ( [], items ) - | otherwise = ( html:secs, rest2 ) - where - html = linkedAnchor (groupId id0) - << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs - (ssecs, rest1) = process lev rest - (secs, rest2) = process n rest1 - process n (_ : rest) = process n rest - - mk_subsections [] = noHtml - mk_subsections ss = unordList ss - --- we need to assign a unique id to each section heading so we can hyperlink --- them from the contents: -numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] -numberSectionHeadings = go 1 - where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] - go _ [] = [] - go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es - go n (other:es) - = other : go n es - - -processExport :: Bool -> LinksInfo -> Bool -> Qualification - -> ExportItem DocName -> Maybe Html -processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances -processExport summary _ _ qual (ExportGroup lev id0 doc) - = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc -processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) - = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual -processExport summary _ _ qual (ExportNoDecl y []) - = processDeclOneLiner summary $ ppDocName qual Prefix True y -processExport summary _ _ qual (ExportNoDecl y subs) - = processDeclOneLiner summary $ - ppDocName qual Prefix True y - +++ parenList (map (ppDocName qual Prefix True) subs) -processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection_ qual doc -processExport summary _ _ _ (ExportModule mdl) - = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl - - -nothingIf :: Bool -> a -> Maybe a -nothingIf True _ = Nothing -nothingIf False a = Just a - - -processDecl :: Bool -> Html -> Maybe Html -processDecl True = Just -processDecl False = Just . divTopDecl - - -processDeclOneLiner :: Bool -> Html -> Maybe Html -processDeclOneLiner True = Just -processDeclOneLiner False = Just . divTopDecl . declElem - -groupHeading :: Int -> String -> Html -> Html -groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] - -groupTag :: Int -> Html -> Html -groupTag lev - | lev == 1 = h1 - | lev == 2 = h2 - | lev == 3 = h3 - | otherwise = h4 diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ /dev/null @@ -1,885 +0,0 @@ -{-# LANGUAGE TransformListComp #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Decl --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Decl ( - ppDecl, - - ppTyName, ppTyFamHeader, ppTypeApp, - tyvarNames -) where - - -import Haddock.Backends.Xhtml.DocMarkup -import Haddock.Backends.Xhtml.Layout -import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils -import Haddock.GhcUtils -import Haddock.Types -import Haddock.Doc (combineDocumentation) - -import Data.List ( intersperse, sort ) -import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid ( mempty ) -import Text.XHtml hiding ( name, title, p, quote ) - -import GHC -import GHC.Exts -import Name -import BooleanFormula - -ppDecl :: Bool -> LinksInfo -> LHsDecl DocName - -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] - -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html -ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual - SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual - SigD (PatSynSig lname args ty prov req) -> - ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual - InstD _ -> noHtml - _ -> error "declaration not supported by ppDecl" - - -ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = - ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities - splice unicode qual - -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [DocName] -> HsType DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppFunSig summary links loc doc docnames typ fixities splice unicode qual = - ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) - splice unicode qual - where - pp_typ = ppType unicode qual typ - -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - Located DocName -> - HsPatSynDetails (LHsType DocName) -> LHsType DocName -> - LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual = - ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ) - (unLoc prov) (unLoc req) fixities splice unicode qual - -ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> - HsPatSynDetails (HsType DocName) -> HsType DocName -> - HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities - splice unicode qual - | summary = pref1 - | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) - +++ docSection qual doc - where - pref1 = hsep [ toHtml "pattern" - , pp_cxt prov - , pp_head - , dcolon unicode - , pp_cxt req - , ppType unicode qual typ - ] - pp_head = case args of - PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs - InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] - - pp_cxt cxt = ppContext cxt unicode qual - pp_type = ppParendType unicode qual - - occname = nameOccName . getName $ docname - -ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> - [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> - Splice -> Unicode -> Qualification -> Html -ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) - splice unicode qual = - ppTypeOrFunSig summary links loc docnames typ doc - ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode - , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames - , dcolon unicode - ) - splice unicode qual - where - occnames = map (nameOccName . getName) docnames - addFixities html - | summary = html - | otherwise = html <+> ppFixities fixities qual - - -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName - -> DocForDecl DocName -> (Html, Html, Html) - -> Splice -> Unicode -> Qualification -> Html -ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual - | summary = pref1 - | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc - | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ docSection qual doc - where - argDoc n = Map.lookup n argDocs - - do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> HsType DocName -> [SubDecl] - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) - = (leader <+> - hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode qual, - Nothing, []) - : do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Implicit _ lctxt ltype) - | not (null (unLoc lctxt)) - = (leader <+> ppLContextNoArrow lctxt unicode qual, - Nothing, []) - : do_largs n (darrow unicode) ltype - -- if we're not showing any 'forall' or class constraints or - -- anything, skip having an empty line for the context. - | otherwise - = do_largs n leader ltype - do_args n leader (HsFunTy lt r) - = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) - : do_largs (n+1) (arrow unicode) r - do_args n leader t - = [(leader <+> ppType unicode qual t, argDoc n, [])] - -ppFixities :: [(DocName, Fixity)] -> Qualification -> Html -ppFixities [] _ = noHtml -ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge - where - ppFix (ns, p, d) = thespan ! [theclass "fixity"] << - (toHtml d <+> toHtml (show p) <+> ppNames ns) - - ppDir InfixR = "infixr" - ppDir InfixL = "infixl" - ppDir InfixN = "infix" - - ppNames = case fs of - _:[] -> const noHtml -- Don't display names for fixities on single names - _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) - - uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs - , let d' = ppDir d - , then group by Down (p,d') using groupWith ] - - rightEdge = thespan ! [theclass "rightedge"] << noHtml - - -ppTyVars :: LHsTyVarBndrs DocName -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) - - -tyvarNames :: LHsTyVarBndrs DocName -> [Name] -tyvarNames = map getName . hsLTyVarNames - - -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName - -> ForeignDecl DocName -> [(DocName, Fixity)] - -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities - splice unicode qual - = ppFunSig summary links loc doc [name] typ fixities splice unicode qual -ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" - - --- we skip type patterns for now -ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan - -> DocForDecl DocName -> TyClDecl DocName - -> Splice -> Unicode -> Qualification -> Html -ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars - , tcdRhs = ltype }) - splice unicode qual - = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc - (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) - splice unicode qual - where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) - full = hdr <+> equals <+> ppLType unicode qual ltype - occ = nameOccName . getName $ name - fixs - | summary = noHtml - | otherwise = ppFixities fixities qual -ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" - - -ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html -ppTypeSig summary nms pp_ty unicode = - concatHtml htmlNames <+> dcolon unicode <+> pp_ty - where - htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms - - -ppTyName :: Name -> Html -ppTyName = ppName Prefix - - --------------------------------------------------------------------------------- --- * Type families --------------------------------------------------------------------------------- - - -ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName - -> Unicode -> Qualification -> Html -ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info - , fdKindSig = mkind }) - unicode qual = - (case info of - OpenTypeFamily - | associated -> keyword "type" - | otherwise -> keyword "type family" - DataFamily - | associated -> keyword "data" - | otherwise -> keyword "data family" - ClosedTypeFamily _ - -> keyword "type family" - ) <+> - - ppFamDeclBinderWithVars summary d <+> - - (case mkind of - Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml - ) - -ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> - [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> - FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html -ppTyFam summary associated links instances fixities loc doc decl splice unicode qual - - | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ docSection qual doc +++ instancesBit - - where - docname = unLoc $ fdLName decl - - header_ = topDeclElem links loc splice [docname] $ - ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual - - instancesBit - | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl - , not summary - = subEquations qual $ map (ppTyFamEqn . unLoc) eqns - - | otherwise - = ppInstances instances docname unicode qual - - -- Individual equation of a closed type family - ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs - , tfie_pats = HsWB { hswb_cts = ts }} - = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual - <+> equals <+> ppType unicode qual (unLoc rhs) - , Nothing, [] ) - --------------------------------------------------------------------------------- --- * Associated Types --------------------------------------------------------------------------------- - - -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName - -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppAssocType summ links doc (L loc decl) fixities splice unicode qual = - ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual - - --------------------------------------------------------------------------------- --- * TyClDecl helpers --------------------------------------------------------------------------------- - --- | Print a type family and its variables -ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html -ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = - ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) - --- | Print a newtype / data binder and its variables -ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html -ppDataBinderWithVars summ decl = - ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) - --------------------------------------------------------------------------------- --- * Type applications --------------------------------------------------------------------------------- - - --- | Print an application of a DocName and two lists of HsTypes (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] - -> Unicode -> Qualification -> Html -ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) - - --- | Print an application of a DocName and a list of Names -ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html -ppAppDocNameNames summ n ns = - ppTypeApp n [] ns ppDN ppTyName - where - ppDN notation = ppBinderFixity notation summ . nameOccName . getName - ppBinderFixity Infix = ppBinderInfix - ppBinderFixity _ = ppBinder - --- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html -ppTypeApp n [] (t1:t2:rest) ppDN ppT - | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) - | operator = opApp - where - operator = isNameSym . getName $ n - opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 - -ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) - - -------------------------------------------------------------------------------- --- * Contexts -------------------------------------------------------------------------------- - - -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode - -> Qualification -> Html -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc - - -ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html -ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual - - -ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html -ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual - <+> darrow unicode - - -ppContext :: HsContext DocName -> Unicode -> Qualification -> Html -ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual - - -ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html -ppHsContext [] _ _ = noHtml -ppHsContext [p] unicode qual = ppCtxType unicode qual p -ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) - - -------------------------------------------------------------------------------- --- * Class declarations -------------------------------------------------------------------------------- - - -ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] - -> Unicode -> Qualification -> Html -ppClassHdr summ lctxt n tvs fds unicode qual = - keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames tvs) - <+> ppFds fds unicode qual - - -ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html -ppFds fds unicode qual = - if null fds then noHtml else - char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) - where - fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 - ppVars = hsep . map (ppDocName qual Prefix True) - -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan - -> [(DocName, DocForDecl DocName)] - -> Splice -> Unicode -> Qualification -> Html -ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs - , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc - subdocs splice unicode qual = - if not (any isVanillaLSig sigs) && null ats - then (if summary then id else topDeclElem links loc splice [nm]) hdr - else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") - +++ shortSubDecls False - ( - [ ppAssocType summary links doc at [] splice unicode qual | at <- ats - , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ - - -- ToDo: add associated type defaults - - [ ppFunSig summary links loc doc names typ [] splice unicode qual - | L _ (TypeSig lnames (L _ typ)) <- sigs - , let doc = lookupAnySubdoc (head names) subdocs - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? - ) - where - hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual - nm = unLoc lname -ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - - - -ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] - -> SrcSpan -> Documentation DocName - -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName - -> Splice -> Unicode -> Qualification -> Html -ppClassDecl summary links instances fixities loc d subdocs - decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) - splice unicode qual - | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual - | otherwise = classheader +++ docSection qual d - +++ minimalBit +++ atBit +++ methodBit +++ instancesBit - where - classheader - | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) - | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) - - -- Only the fixity relevant to the class header - fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual - - nm = tcdName decl - - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - - -- ToDo: add assocatied typ defaults - atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual - | at <- ats - , let n = unL . fdLName $ unL at - doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs - subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] - - methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual - | L _ (TypeSig lnames (L _ typ)) <- lsigs - , let doc = lookupAnySubdoc (head names) subdocs - subfixs = [ f | n <- names - , f@(n',_) <- fixities - , n == n' ] - names = map unLoc lnames ] - -- FIXME: is taking just the first name ok? Is it possible that - -- there are different subdocs for different names in a single - -- type signature? - - minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of - -- Miminal complete definition = every shown method - And xs : _ | sort [getName n | Var (L _ n) <- xs] == - sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns] - -> noHtml - - -- Minimal complete definition = the only shown method - Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] - -> noHtml - - -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml "Nothing" - - m : _ -> subMinimal $ ppMinimal False m - _ -> noHtml - - ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs - where wrap | p = parens | otherwise = id - - instancesBit = ppInstances instances nm unicode qual - -ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - - -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html -ppInstances instances baseName unicode qual - = subInstances qual instName (map instDecl instances) - where - instName = getOccString $ getName baseName - instDecl :: DocInstance DocName -> SubDecl - instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) - instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual - <+> ppAppNameTypes n ks ts unicode qual - instHead (n, ks, ts, TypeInst rhs) = keyword "type" - <+> ppAppNameTypes n ks ts unicode qual - <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs - instHead (n, ks, ts, DataInst dd) = keyword "data" - <+> ppAppNameTypes n ks ts unicode qual - <+> ppShortDataDecl False True dd unicode qual - -lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 -lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n - - -------------------------------------------------------------------------------- --- * Data & newtype declarations -------------------------------------------------------------------------------- - - --- TODO: print contexts -ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html -ppShortDataDecl summary dataInst dataDecl unicode qual - - | [] <- cons = dataHeader - - | [lcon] <- cons, ResTyH98 <- resTy, - (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual - = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot - - | ResTyH98 <- resTy = dataHeader - +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) - - | otherwise = (dataHeader <+> keyword "where") - +++ shortSubDecls dataInst (map doGADTConstr cons) - - where - dataHeader - | dataInst = noHtml - | otherwise = ppDataHeader summary dataDecl unicode qual - doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual - doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - - cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons - - -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocName -> - Splice -> Unicode -> Qualification -> Html -ppDataDecl summary links instances fixities subdocs loc doc dataDecl - splice unicode qual - - | summary = ppShortDataDecl summary False dataDecl unicode qual - | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit - - where - docname = tcdName dataDecl - cons = dd_cons (tcdDataDefn dataDecl) - resTy = (con_res . unLoc . head) cons - - header_ = topDeclElem links loc splice [docname] $ - ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix - - fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual - - whereBit - | null cons = noHtml - | otherwise = case resTy of - ResTyGADT _ -> keyword "where" - _ -> noHtml - - constrBit = subConstructors qual - [ ppSideBySideConstr subdocs subfixs unicode qual c - | c <- cons - , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities - ] - - instancesBit = ppInstances instances docname unicode qual - - - -ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html -ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot - where - (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual - - --- returns three pieces: header, body, footer so that header & footer can be --- incorporated into the declaration -ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con_res con of - ResTyH98 -> case con_details con of - PrefixCon args -> - (header_ unicode qual +++ hsep (ppBinder summary occ - : map (ppLParendType unicode qual) args), noHtml, noHtml) - RecCon fields -> - (header_ unicode qual +++ ppBinder summary occ <+> char '{', - doRecordFields fields, - char '}') - InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, - ppBinderInfix summary occ, ppLParendType unicode qual arg2], - noHtml, noHtml) - - ResTyGADT resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml) - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> - ppForAll forall_ ltvs lcontext unicode qual <+> char '{', - doRecordFields fields, - char '}' <+> arrow unicode <+> ppLType unicode qual resTy) - InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) - - where - doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields) - doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall_ ltvs lcontext unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] - - header_ = ppConstrHdr forall_ tyVars context - occ = nameOccName . getName . unLoc . con_name $ con - ltvs = con_qvars con - tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall_ = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) - - --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode - -> Qualification -> Html -ppConstrHdr forall_ tvs ctxt unicode qual - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual - <+> darrow unicode +++ toHtml " ") - where - ppForall = case forall_ of - Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " - Implicit -> noHtml - - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocName -> SubDecl -ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) - where - decl = case con_res con of - ResTyH98 -> case con_details con of - PrefixCon args -> - hsep ((header_ +++ ppBinder False occ) - : map (ppLParendType unicode qual) args) - <+> fixity - - RecCon _ -> header_ +++ ppBinder False occ <+> fixity - - InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual arg1, - ppBinderInfix False occ, - ppLParendType unicode qual arg2] - <+> fixity - - ResTyGADT resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - fieldPart = case con_details con of - RecCon fields -> [doRecordFields fields] - _ -> [] - - doRecordFields fields = subFields qual - (map (ppSideBySideField subdocs unicode qual) fields) - doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html - doGADTCon args resTy = ppBinder False occ <+> dcolon unicode - <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, - ppLType unicode qual (foldr mkFunTy resTy args) ] - <+> fixity - - fixity = ppFixities fixities qual - header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = nameOccName . getName . unLoc . con_name $ con - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall_ = con_explicit con - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) - - -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification - -> ConDeclField DocName -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = - (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype, - mbDoc, - []) - where - -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = lookup name subdocs >>= combineDocumentation . fst - - -ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html -ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) - = ppBinder summary (nameOccName . getName $ name) - <+> dcolon unicode <+> ppLType unicode qual ltype - - --- | Print the LHS of a data\/newtype declaration. --- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html -ppDataHeader summary decl@(DataDecl { tcdDataDefn = - HsDataDefn { dd_ND = nd - , dd_ctxt = ctxt - , dd_kindSig = ks } }) - unicode qual - = -- newtype or data - (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) - <+> - -- context - ppLContext ctxt unicode qual <+> - -- T a b c ..., or a :+: b - ppDataBinderWithVars summary decl - <+> case ks of - Nothing -> mempty - Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x - -ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" - --------------------------------------------------------------------------------- --- * Types and contexts --------------------------------------------------------------------------------- - - -ppBang :: HsBang -> Html -ppBang HsNoBang = noHtml -ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, - -- so we just show the strictness annotation - - -tupleParens :: HsTupleSort -> [Html] -> Html -tupleParens HsUnboxedTuple = ubxParenList -tupleParens _ = parenList - - --------------------------------------------------------------------------------- --- * Rendering of HsType --------------------------------------------------------------------------------- - - -pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC -pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type - -- (as opposed to (ctx1, ctx2) => type) -pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = 3 :: Int -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = 4 :: Int -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> Html -> Html -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification - -> Located (HsType DocName) -> Html -ppLType unicode qual y = ppType unicode qual (unLoc y) -ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) -ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) - - -ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification - -> HsType DocName -> Html -ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual -ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual -ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual - -ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html -ppLKind unicode qual y = ppKind unicode qual (unLoc y) - -ppKind :: Unicode -> Qualification -> HsKind DocName -> Html -ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual - --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName - -> Located (HsContext DocName) -> Unicode -> Qualification -> Html -ppForAll expl tvs cxt unicode qual - | show_forall = forall_part <+> ppLContext cxt unicode qual - | otherwise = ppLContext cxt unicode qual - where - show_forall = not (null (hsQTvBndrs tvs)) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - - -ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) - - -ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual - = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] - --- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar name) True _ - | getOccString (getName name) == "*" = toHtml "★" - | getOccString (getName name) == "(->)" = toHtml "(→)" - -ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q -ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q = - parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q -ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys -ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual - = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual - where - ppr_op = ppLDocName qual Infix op - -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual - = ppr_mono_lty ctxt_prec ty unicode qual - -ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n - -ppr_tylit :: HsTyLit -> Html -ppr_tylit (HsNumTy n) = toHtml (show n) -ppr_tylit (HsStrTy s) = toHtml (show s) - - -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual - in - maybeParen ctxt_prec pREC_FUN $ - hsep [p1, arrow unicode <+> p2] diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.DocMarkup --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.DocMarkup ( - docToHtml, - rdrDocToHtml, - origDocToHtml, - docToHtmlNoAnchors, - - docElement, docSection, docSection_, -) where - -import Control.Applicative ((<$>)) - -import Haddock.Backends.Xhtml.Names -import Haddock.Backends.Xhtml.Utils -import Haddock.Types -import Haddock.Utils -import Haddock.Doc (combineDocumentation) - -import Text.XHtml hiding ( name, p, quote ) -import Data.Maybe (fromMaybe) - -import GHC - -parHtmlMarkup :: Qualification -> Bool - -> (Bool -> a -> Html) -> DocMarkup a Html -parHtmlMarkup qual insertAnchors ppId = Markup { - markupEmpty = noHtml, - markupString = toHtml, - markupParagraph = paragraph, - markupAppend = (+++), - markupIdentifier = thecode . ppId insertAnchors, - markupIdentifierUnchecked = thecode . ppUncheckedLink qual, - markupModule = \m -> let (mdl,ref) = break (=='#') m - -- Accomodate for old style - -- foo\#bar anchors - mdl' = case reverse mdl of - '\\':_ -> init mdl - _ -> mdl - in ppModuleRef (mkModuleName mdl') ref, - markupWarning = thediv ! [theclass "warning"], - markupEmphasis = emphasize, - markupBold = strong, - markupMonospaced = thecode, - markupUnorderedList = unordList, - markupOrderedList = ordList, - markupDefList = defList, - markupCodeBlock = pre, - markupHyperlink = \(Hyperlink url mLabel) - -> if insertAnchors - then anchor ! [href url] - << fromMaybe url mLabel - else toHtml $ fromMaybe url mLabel, - markupAName = \aname -> namedAnchor aname << "", - markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), - markupProperty = pre . toHtml, - markupExample = examplesToHtml, - markupHeader = \(Header l t) -> makeHeader l t - } - where - makeHeader :: Int -> Html -> Html - makeHeader 1 mkup = h1 mkup - makeHeader 2 mkup = h2 mkup - makeHeader 3 mkup = h3 mkup - makeHeader 4 mkup = h4 mkup - makeHeader 5 mkup = h5 mkup - makeHeader 6 mkup = h6 mkup - makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" - - - examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] - - exampleToHtml (Example expression result) = htmlExample - where - htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) - htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] - htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] - - --- If the doc is a single paragraph, don't surround it with

    (this causes --- ugly extra whitespace with some browsers). FIXME: Does this still apply? -docToHtml :: Qualification -> Doc DocName -> Html -docToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual True (ppDocName qual Raw) - --- | Same as 'docToHtml' but it doesn't insert the 'anchor' element --- in links. This is used to generate the Contents box elements. -docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html -docToHtmlNoAnchors qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual False (ppDocName qual Raw) - -origDocToHtml :: Qualification -> Doc Name -> Html -origDocToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual True (const $ ppName Raw) - - -rdrDocToHtml :: Qualification -> Doc RdrName -> Html -rdrDocToHtml qual = markup fmt . cleanup - where fmt = parHtmlMarkup qual True (const ppRdrName) - - -docElement :: (Html -> Html) -> Html -> Html -docElement el content_ = - if isNoHtml content_ - then el ! [theclass "doc empty"] << spaceHtml - else el ! [theclass "doc"] << content_ - - -docSection :: Qualification -> Documentation DocName -> Html -docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation - - -docSection_ :: Qualification -> Doc DocName -> Html -docSection_ qual = (docElement thediv <<) . docToHtml qual - - -cleanup :: Doc a -> Doc a -cleanup = markup fmtUnParagraphLists - where - -- If there is a single paragraph, then surrounding it with

    ..

    - -- can add too much whitespace in some browsers (eg. IE). However if - -- we have multiple paragraphs, then we want the extra whitespace to - -- separate them. So we catch the single paragraph case and transform it - -- here. We don't do this in code blocks as it eliminates line breaks. - unParagraph :: Doc a -> Doc a - unParagraph (DocParagraph d) = d - unParagraph doc = doc - - fmtUnParagraphLists :: DocMarkup a (Doc a) - fmtUnParagraphLists = idMarkup { - markupUnorderedList = DocUnorderedList . map unParagraph, - markupOrderedList = DocOrderedList . map unParagraph - } diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Layout --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Layout ( - miniBody, - - divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, - divIndex, divAlphabet, divModuleList, - - sectionName, - nonEmptySectionName, - - shortDeclList, - shortSubDecls, - - divTopDecl, - - SubDecl, - subArguments, - subAssociatedTypes, - subConstructors, - subEquations, - subFields, - subInstances, - subMethods, - subMinimal, - - topDeclElem, declElem, -) where - - -import Haddock.Backends.Xhtml.DocMarkup -import Haddock.Backends.Xhtml.Types -import Haddock.Backends.Xhtml.Utils -import Haddock.Types -import Haddock.Utils (makeAnchorId) - -import qualified Data.Map as Map -import Text.XHtml hiding ( name, title, p, quote ) - -import FastString ( unpackFS ) -import GHC - - --------------------------------------------------------------------------------- --- * Sections of the document --------------------------------------------------------------------------------- - - -miniBody :: Html -> Html -miniBody = body ! [identifier "mini"] - - -sectionDiv :: String -> Html -> Html -sectionDiv i = thediv ! [identifier i] - - -sectionName :: Html -> Html -sectionName = paragraph ! [theclass "caption"] - - --- | Make an element that always has at least something (a non-breaking space). --- If it would have otherwise been empty, then give it the class ".empty". -nonEmptySectionName :: Html -> Html -nonEmptySectionName c - | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml - | otherwise = paragraph ! [theclass "caption"] $ c - - -divPackageHeader, divContent, divModuleHeader, divFooter, - divTableOfContents, divDescription, divSynposis, divInterface, - divIndex, divAlphabet, divModuleList - :: Html -> Html - -divPackageHeader = sectionDiv "package-header" -divContent = sectionDiv "content" -divModuleHeader = sectionDiv "module-header" -divFooter = sectionDiv "footer" -divTableOfContents = sectionDiv "table-of-contents" -divDescription = sectionDiv "description" -divSynposis = sectionDiv "synopsis" -divInterface = sectionDiv "interface" -divIndex = sectionDiv "index" -divAlphabet = sectionDiv "alphabet" -divModuleList = sectionDiv "module-list" - - --------------------------------------------------------------------------------- --- * Declaration containers --------------------------------------------------------------------------------- - - -shortDeclList :: [Html] -> Html -shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items - - -shortSubDecls :: Bool -> [Html] -> Html -shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items - where i | inst = li ! [theclass "inst"] - | otherwise = li - c | inst = "inst" - | otherwise = "subs" - - -divTopDecl :: Html -> Html -divTopDecl = thediv ! [theclass "top"] - - -type SubDecl = (Html, Maybe (Doc DocName), [Html]) - - -divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html -divSubDecls cssClass captionName = maybe noHtml wrap - where - wrap = (subSection <<) . (subCaption +++) - subSection = thediv ! [theclass $ unwords ["subs", cssClass]] - subCaption = paragraph ! [theclass "caption"] << captionName - - -subDlist :: Qualification -> [SubDecl] -> Maybe Html -subDlist _ [] = Nothing -subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv - where - subEntry (decl, mdoc, subs) = - dterm ! [theclass "src"] << decl - +++ - docElement ddef << (fmap (docToHtml qual) mdoc +++ subs) - - clearDiv = thediv ! [ theclass "clear" ] << noHtml - - -subTable :: Qualification -> [SubDecl] -> Maybe Html -subTable _ [] = Nothing -subTable qual decls = Just $ table << aboves (concatMap subRow decls) - where - subRow (decl, mdoc, subs) = - (td ! [theclass "src"] << decl - <-> - docElement td << fmap (docToHtml qual) mdoc) - : map (cell . (td <<)) subs - - -subBlock :: [Html] -> Maybe Html -subBlock [] = Nothing -subBlock hs = Just $ toHtml hs - - -subArguments :: Qualification -> [SubDecl] -> Html -subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual - - -subAssociatedTypes :: [Html] -> Html -subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock - - -subConstructors :: Qualification -> [SubDecl] -> Html -subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual - - -subFields :: Qualification -> [SubDecl] -> Html -subFields qual = divSubDecls "fields" "Fields" . subDlist qual - - -subEquations :: Qualification -> [SubDecl] -> Html -subEquations qual = divSubDecls "equations" "Equations" . subTable qual - - -subInstances :: Qualification -> String -> [SubDecl] -> Html -subInstances qual nm = maybe noHtml wrap . instTable - where - wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual - subSection = thediv ! [theclass "subs instances"] - subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" - id_ = makeAnchorId $ "i:" ++ nm - -subMethods :: [Html] -> Html -subMethods = divSubDecls "methods" "Methods" . subBlock - -subMinimal :: Html -> Html -subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem - - --- a box for displaying code -declElem :: Html -> Html -declElem = paragraph ! [theclass "src"] - - --- a box for top level documented names --- it adds a source and wiki link at the right hand side of the box -topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html -topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html = - declElem << (html <+> srcLink <+> wikiLink) - where srcLink = let nameUrl = Map.lookup origPkg sourceMap - lineUrl = Map.lookup origPkg lineMap - mUrl | splice = lineUrl - -- Use the lineUrl as a backup - | otherwise = maybe lineUrl Just nameUrl in - case mUrl of - Nothing -> noHtml - Just url -> let url' = spliceURL (Just fname) (Just origMod) - (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Source" - - wikiLink = - case maybe_wiki_url of - Nothing -> noHtml - Just url -> let url' = spliceURL (Just fname) (Just mdl) - (Just n) (Just loc) url - in anchor ! [href url', theclass "link"] << "Comments" - - -- For source links, we want to point to the original module, - -- because only that will have the source. - -- TODO: do something about type instances. They will point to - -- the module defining the type family, which is wrong. - origMod = nameModule n - origPkg = modulePackageId origMod - - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = head names - -- FIXME: is it ok to simply take the first name? - - fname = case loc of - RealSrcSpan l -> unpackFS (srcSpanFile l) - UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ /dev/null @@ -1,171 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Names --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Names ( - ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, - ppBinder, ppBinderInfix, ppBinder', - ppModule, ppModuleRef, ppIPName, linkId, Notation(..) -) where - - -import Haddock.Backends.Xhtml.Utils -import Haddock.GhcUtils -import Haddock.Types -import Haddock.Utils - -import Text.XHtml hiding ( name, title, p, quote ) -import qualified Data.Map as M -import qualified Data.List as List - -import GHC -import Name -import RdrName -import FastString (unpackFS) - - --- | Indicator of how to render a 'DocName' into 'Html' -data Notation = Raw -- ^ Render as-is. - | Infix -- ^ Render using infix notation. - | Prefix -- ^ Render using prefix notation. - deriving (Eq, Show) - -ppOccName :: OccName -> Html -ppOccName = toHtml . occNameString - - -ppRdrName :: RdrName -> Html -ppRdrName = ppOccName . rdrNameOcc - -ppIPName :: HsIPName -> Html -ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS - - -ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html -ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName - - --- The Bool indicates if it is to be rendered in infix notation -ppLDocName :: Qualification -> Notation -> Located DocName -> Html -ppLDocName qual notation (L _ d) = ppDocName qual notation True d - -ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html -ppDocName qual notation insertAnchors docName = - case docName of - Documented name mdl -> - linkIdOcc mdl (Just (nameOccName name)) insertAnchors - << ppQualifyName qual notation name mdl - Undocumented name - | isExternalName name || isWiredInName name -> - ppQualifyName qual notation name (nameModule name) - | otherwise -> ppName notation name - --- | Render a name depending on the selected qualification mode -ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html -ppQualifyName qual notation name mdl = - case qual of - NoQual -> ppName notation name - FullQual -> ppFullQualName notation mdl name - LocalQual localmdl -> - if moduleString mdl == moduleString localmdl - then ppName notation name - else ppFullQualName notation mdl name - RelativeQual localmdl -> - case List.stripPrefix (moduleString localmdl) (moduleString mdl) of - -- local, A.x -> x - Just [] -> ppName notation name - -- sub-module, A.B.x -> B.x - Just ('.':m) -> toHtml $ m ++ '.' : getOccString name - -- some module with same prefix, ABC.x -> ABC.x - Just _ -> ppFullQualName notation mdl name - -- some other module, D.x -> D.x - Nothing -> ppFullQualName notation mdl name - AliasedQual aliases localmdl -> - case (moduleString mdl == moduleString localmdl, - M.lookup mdl aliases) of - (False, Just alias) -> ppQualName notation alias name - _ -> ppName notation name - - -ppFullQualName :: Notation -> Module -> Name -> Html -ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname - where - qname = toHtml $ moduleString mdl ++ '.' : getOccString name - -ppQualName :: Notation -> ModuleName -> Name -> Html -ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname - where - qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name - -ppName :: Notation -> Name -> Html -ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name) - - -ppBinder :: Bool -> OccName -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n -ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Prefix n - -ppBinderInfix :: Bool -> OccName -> Html -ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n -ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] - << ppBinder' Infix n - -ppBinder' :: Notation -> OccName -> Html -ppBinder' notation n = wrapInfix notation n $ ppOccName n - -wrapInfix :: Notation -> OccName -> Html -> Html -wrapInfix notation n = case notation of - Infix | is_star_kind -> id - | not is_sym -> quote - Prefix | is_star_kind -> id - | is_sym -> parens - _ -> id - where - is_sym = isSymOcc n - is_star_kind = isTcOcc n && occNameString n == "*" - -linkId :: Module -> Maybe Name -> Html -> Html -linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True - - -linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html -linkIdOcc mdl mbName insertAnchors = - if insertAnchors - then anchor ! [href url] - else id - where - url = case mbName of - Nothing -> moduleUrl mdl - Just name -> moduleNameUrl mdl name - - -linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html -linkIdOcc' mdl mbName = anchor ! [href url] - where - url = case mbName of - Nothing -> moduleHtmlFile' mdl - Just name -> moduleNameUrl' mdl name - - -ppModule :: Module -> Html -ppModule mdl = anchor ! [href (moduleUrl mdl)] - << toHtml (moduleString mdl) - - -ppModuleRef :: ModuleName -> String -> Html -ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] - << toHtml (moduleNameString mdl) - -- NB: The ref parameter already includes the '#'. - -- This function is only called from markupModule expanding a - -- DocModule, which doesn't seem to be ever be used. diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/Themes.hs +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Themes --- Copyright : (c) Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Themes ( - Themes, - getThemes, - - cssFiles, styleSheet - ) - where - -import Haddock.Options - -import Control.Applicative -import Control.Monad (liftM) -import Data.Char (toLower) -import Data.Either (lefts, rights) -import Data.List (nub) -import Data.Maybe (isJust, listToMaybe) - -import System.Directory -import System.FilePath -import Text.XHtml hiding ( name, title, p, quote, () ) -import qualified Text.XHtml as XHtml - - --------------------------------------------------------------------------------- --- * CSS Themes --------------------------------------------------------------------------------- - -data Theme = Theme { - themeName :: String, - themeHref :: String, - themeFiles :: [FilePath] - } - -type Themes = [Theme] - -type PossibleTheme = Either String Theme -type PossibleThemes = Either String Themes - - --- | Find a theme by name (case insensitive match) -findTheme :: String -> Themes -> Maybe Theme -findTheme s = listToMaybe . filter ((== ls).lower.themeName) - where lower = map toLower - ls = lower s - - --- | Standard theme used by default -standardTheme :: FilePath -> IO PossibleThemes -standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) - - --- | Default themes that are part of Haddock; added with --default-themes --- The first theme in this list is considered the standard theme. --- Themes are "discovered" by scanning the html sub-dir of the libDir, --- and looking for directories with the extension .theme or .std-theme. --- The later is, obviously, the standard theme. -defaultThemes :: FilePath -> IO PossibleThemes -defaultThemes libDir = do - themeDirs <- getDirectoryItems (libDir "html") - themes <- mapM directoryTheme $ discoverThemes themeDirs - return $ sequenceEither themes - where - discoverThemes paths = - filterExt ".std-theme" paths ++ filterExt ".theme" paths - filterExt ext = filter ((== ext).takeExtension) - - --- | Build a theme from a single .css file -singleFileTheme :: FilePath -> IO PossibleTheme -singleFileTheme path = - if isCssFilePath path - then retRight $ Theme name file [path] - else errMessage "File extension isn't .css" path - where - name = takeBaseName path - file = takeFileName path - - --- | Build a theme from a directory -directoryTheme :: FilePath -> IO PossibleTheme -directoryTheme path = do - items <- getDirectoryItems path - case filter isCssFilePath items of - [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items - [] -> errMessage "No .css file in theme directory" path - _ -> errMessage "More than one .css file in theme directory" path - - --- | Check if we have a built in theme -doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool -doesBuiltInExist pts s = fmap (either (const False) test) pts - where test = isJust . findTheme s - - --- | Find a built in theme -builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme -builtInTheme pts s = either Left fetch <$> pts - where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s - - --------------------------------------------------------------------------------- --- * CSS Theme Arguments --------------------------------------------------------------------------------- - --- | Process input flags for CSS Theme arguments -getThemes :: FilePath -> [Flag] -> IO PossibleThemes -getThemes libDir flags = - liftM concatEither (mapM themeFlag flags) >>= someTheme - where - themeFlag :: Flag -> IO (Either String Themes) - themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) - themeFlag (Flag_BuiltInThemes) = builtIns - themeFlag _ = retRight [] - - theme :: FilePath -> IO PossibleTheme - theme path = pick path - [(doesFileExist, singleFileTheme), - (doesDirectoryExist, directoryTheme), - (doesBuiltInExist builtIns, builtInTheme builtIns)] - "Theme not found" - - pick :: FilePath - -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String - -> IO PossibleTheme - pick path [] msg = errMessage msg path - pick path ((test,build):opts) msg = do - pass <- test path - if pass then build path else pick path opts msg - - - someTheme :: Either String Themes -> IO (Either String Themes) - someTheme (Right []) = standardTheme libDir - someTheme est = return est - - builtIns = defaultThemes libDir - - -errMessage :: String -> FilePath -> IO (Either String a) -errMessage msg path = return (Left msg') - where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n" - - -retRight :: a -> IO (Either String a) -retRight = return . Right - - --------------------------------------------------------------------------------- --- * File Utilities --------------------------------------------------------------------------------- - - -getDirectoryItems :: FilePath -> IO [FilePath] -getDirectoryItems path = - map (combine path) . filter notDot <$> getDirectoryContents path - where notDot s = s /= "." && s /= ".." - - -isCssFilePath :: FilePath -> Bool -isCssFilePath path = takeExtension path == ".css" - - --------------------------------------------------------------------------------- --- * Style Sheet Utilities --------------------------------------------------------------------------------- - -cssFiles :: Themes -> [String] -cssFiles ts = nub $ concatMap themeFiles ts - - -styleSheet :: Themes -> Html -styleSheet ts = toHtml $ zipWith mkLink rels ts - where - rels = "stylesheet" : repeat "alternate stylesheet" - mkLink aRel t = - thelink - ! [ href (themeHref t), rel aRel, thetype "text/css", - XHtml.title (themeName t) - ] - << noHtml - --------------------------------------------------------------------------------- --- * Either Utilities --------------------------------------------------------------------------------- - --- These three routines are here because Haddock does not have access to the --- Control.Monad.Error module which supplies the Functor and Monad instances --- for Either String. - -sequenceEither :: [Either a b] -> Either a [b] -sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es)) - - -liftEither :: (b -> c) -> Either a b -> Either a c -liftEither f = either Left (Right . f) - - -concatEither :: [Either a [b]] -> Either a [b] -concatEither = liftEither concat . sequenceEither - diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/Types.hs +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Types --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Types ( - SourceURLs, WikiURLs, - LinksInfo, - Splice, - Unicode, -) where - - -import Data.Map -import GHC - - --- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath) -type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) - - --- The URL for source and wiki links -type LinksInfo = (SourceURLs, WikiURLs) - --- Whether something is a splice or not -type Splice = Bool - --- Whether unicode syntax is to be used -type Unicode = Bool diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs deleted file mode 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html.Util --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mark Lentczner 2010 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Xhtml.Utils ( - renderToString, - - namedAnchor, linkedAnchor, - spliceURL, - groupId, - - (<+>), (<=>), char, - keyword, punctuate, - - braces, brackets, pabrackets, parens, parenList, ubxParenList, - arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, - - hsep, vcat, - - collapseSection, collapseToggle, collapseControl, -) where - - -import Haddock.GhcUtils -import Haddock.Utils - -import Data.Maybe - -import Text.XHtml hiding ( name, title, p, quote ) -import qualified Text.XHtml as XHtml - -import GHC ( SrcSpan(..), srcSpanStartLine, Name ) -import Module ( Module ) -import Name ( getOccString, nameOccName, isValOcc ) - - -spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> - Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc = run - where - file = fromMaybe "" maybe_file - mdl = case maybe_mod of - Nothing -> "" - Just m -> moduleString m - - (name, kind) = - case maybe_name of - Nothing -> ("","") - Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") - | otherwise -> (escapeStr (getOccString n), "t") - - line = case maybe_loc of - Nothing -> "" - Just span_ -> - case span_ of - RealSrcSpan span__ -> - show $ srcSpanStartLine span__ - UnhelpfulSpan _ -> - error "spliceURL UnhelpfulSpan" - - run "" = "" - run ('%':'M':rest) = mdl ++ run rest - run ('%':'F':rest) = file ++ run rest - run ('%':'N':rest) = name ++ run rest - run ('%':'K':rest) = kind ++ run rest - run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = '%' : run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest - run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest - run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest - run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = - map (\x -> if x == '.' then c else x) mdl ++ run rest - - run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = - map (\x -> if x == '/' then c else x) file ++ run rest - - run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest - - run (c:rest) = c : run rest - - -renderToString :: Bool -> Html -> String -renderToString debug html - | debug = renderHtml html - | otherwise = showHtml html - - -hsep :: [Html] -> Html -hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls - --- | Concatenate a series of 'Html' values vertically, with linebreaks in between. -vcat :: [Html] -> Html -vcat [] = noHtml -vcat htmls = foldr1 (\a b -> a+++br+++b) htmls - - -infixr 8 <+> -(<+>) :: Html -> Html -> Html -a <+> b = a +++ sep +++ b - where - sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " - --- | Join two 'Html' values together with a linebreak in between. --- Has 'noHtml' as left identity. -infixr 8 <=> -(<=>) :: Html -> Html -> Html -a <=> b = a +++ sep +++ b - where - sep = if isNoHtml a then noHtml else br - - -keyword :: String -> Html -keyword s = thespan ! [theclass "keyword"] << toHtml s - - -equals, comma :: Html -equals = char '=' -comma = char ',' - - -char :: Char -> Html -char c = toHtml [c] - - -quote :: Html -> Html -quote h = char '`' +++ h +++ '`' - - -parens, brackets, pabrackets, braces :: Html -> Html -parens h = char '(' +++ h +++ char ')' -brackets h = char '[' +++ h +++ char ']' -pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" -braces h = char '{' +++ h +++ char '}' - - -punctuate :: Html -> [Html] -> [Html] -punctuate _ [] = [] -punctuate h (d0:ds) = go d0 ds - where - go d [] = [d] - go d (e:es) = (d +++ h) : go e es - - -parenList :: [Html] -> Html -parenList = parens . hsep . punctuate comma - - -ubxParenList :: [Html] -> Html -ubxParenList = ubxparens . hsep . punctuate comma - - -ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" - - -dcolon, arrow, darrow, forallSymbol :: Bool -> Html -dcolon unicode = toHtml (if unicode then "∷" else "::") -arrow unicode = toHtml (if unicode then "→" else "->") -darrow unicode = toHtml (if unicode then "⇒" else "=>") -forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" - - -dot :: Html -dot = toHtml "." - - --- | Generate a named anchor -namedAnchor :: String -> Html -> Html -namedAnchor n = anchor ! [XHtml.name n] - - -linkedAnchor :: String -> Html -> Html -linkedAnchor n = anchor ! [href ('#':n)] - - --- | generate an anchor identifier for a group -groupId :: String -> String -groupId g = makeAnchorId ("g:" ++ g) - --- --- A section of HTML which is collapsible. --- - --- | Attributes for an area that can be collapsed -collapseSection :: String -> Bool -> String -> [HtmlAttr] -collapseSection id_ state classes = [ identifier sid, theclass cs ] - where cs = unwords (words classes ++ [pick state "show" "hide"]) - sid = "section." ++ id_ - --- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> [HtmlAttr] -collapseToggle id_ = [ strAttr "onclick" js ] - where js = "toggleSection('" ++ id_ ++ "')"; - --- | Attributes for an area that toggles a collapsed area, --- and displays a control. -collapseControl :: String -> Bool -> String -> [HtmlAttr] -collapseControl id_ state classes = - [ identifier cid, theclass cs ] ++ collapseToggle id_ - where cs = unwords (words classes ++ [pick state "collapser" "expander"]) - cid = "control." ++ id_ - - -pick :: Bool -> a -> a -> a -pick True t _ = t -pick False _ f = f diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs deleted file mode 100644 --- a/src/Haddock/Convert.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Convert --- Copyright : (c) Isaac Dupree 2009, --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Conversion between TyThing and HsDecl. This functionality may be moved into --- GHC at some point. ------------------------------------------------------------------------------ -module Haddock.Convert where --- Some other functions turned out to be useful for converting --- instance heads, which aren't TyThings, so just export everything. - - -import HsSyn -import TcType ( tcSplitSigmaTy ) -import TypeRep -import Type(isStrLitTy) -import Kind ( splitKindFunTys, synTyConResKind, isKind ) -import Name -import Var -import Class -import TyCon -import CoAxiom -import ConLike -import DataCon -import PatSyn -import FamInstEnv -import BasicTypes ( TupleSort(..) ) -import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, eqTyCon ) -import PrelNames (ipClassName) -import Bag ( emptyBag ) -import Unique ( getUnique ) -import SrcLoc ( Located, noLoc, unLoc ) -import Data.List( partition ) -import Haddock.Types - - --- the main function here! yay! -tyThingToLHsDecl :: TyThing -> LHsDecl Name -tyThingToLHsDecl t = noLoc $ case t of - -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. - -- Including built-in functions like seq. - -- foreign-imported functions could be represented with ForD - -- instead of SigD if we wanted... - -- - -- in a future code version we could turn idVarDetails = foreign-call - -- into a ForD instead of a SigD if we wanted. Haddock doesn't - -- need to care. - AnId i -> SigD (synifyIdSig ImplicitizeForAll i) - - -- type-constructors (e.g. Maybe) are complicated, put the definition - -- later in the file (also it's used for class associated-types too.) - ATyCon tc - | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a - extractFamilyDecl (FamDecl d) = noLoc d - extractFamilyDecl _ = - error "tyThingToLHsDecl: impossible associated tycon" - - atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] - atFamDecls = map extractFamilyDecl atTyClDecls in - TyClD $ ClassDecl - { tcdCtxt = synifyCtx (classSCTheta cl) - , tcdLName = synifyName cl - , tcdTyVars = synifyTyVars (classTyVars cl) - , tcdFDs = map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ - snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) : - map (noLoc . synifyIdSig DeleteTopLevelQuantification) - (classMethods cl) - , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature - -- class associated-types are a subset of TyCon: - , tcdATs = atFamDecls - , tcdATDefs = [] --ignore associated type defaults - , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNames } - | otherwise - -> TyClD (synifyTyCon Nothing tc) - - -- type-constructors (e.g. Maybe) are complicated, put the definition - -- later in the file (also it's used for class associated-types too.) - ACoAxiom ax -> synifyAxiom ax - - -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc] - (synifyType ImplicitizeForAll (dataConUserType dc))) - - AConLike (PatSynCon ps) -> - let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps - in SigD $ PatSynSig (synifyName ps) - (fmap (synifyType WithinType) (patSynTyDetails ps)) - (synifyType WithinType res_ty) - (synifyCtx req_theta) - (synifyCtx prov_theta) - -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name -synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) - = let name = synifyName tc - typats = map (synifyType WithinType) args - hs_rhs = synifyType WithinType rhs - (kvs, tvs) = partition isKindVar tkvs - in TyFamInstEqn { tfie_tycon = name - , tfie_pats = HsWB { hswb_cts = typats - , hswb_kvs = map tyVarName kvs - , hswb_tvs = map tyVarName tvs } - , tfie_rhs = hs_rhs } - -synifyAxiom :: CoAxiom br -> HsDecl Name -synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) - | isOpenSynFamilyTyCon tc - , Just branch <- coAxiomSingleBranch_maybe ax - = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch - , tfid_fvs = placeHolderNames })) - - | Just ax' <- isClosedSynFamilyTyCon_maybe tc - , getUnique ax' == getUnique ax -- without the getUniques, type error - = TyClD (synifyTyCon (Just ax) tc) - - | otherwise - = error "synifyAxiom: closed/open family confusion" - -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name -synifyTyCon coax tc - | isFunTyCon tc || isPrimTyCon tc - = DataDecl { tcdLName = synifyName tc - , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: - let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (getName fakeTyVar) - (synifyKindSig realKind) - in HsQTvs { hsq_kvs = [] -- No kind polymorphism - , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) - alphaTyVars --a, b, c... which are unfortunately all kind * - } - - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither - -- algebraic data nor newtype: - , dd_ctxt = noLoc [] - , dd_cType = Nothing - , dd_kindSig = Just (synifyKindSig (tyConKind tc)) - -- we have their kind accurately: - , dd_cons = [] -- No constructors - , dd_derivs = Nothing } - , tcdFVs = placeHolderNames } - - | isSynFamilyTyCon tc - = case synTyConRhs_maybe tc of - Just rhs -> - let info = case rhs of - OpenSynFamilyTyCon -> OpenTypeFamily - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> - ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches) - _ -> error "synifyTyCon: type/data family confusion" - in FamDecl (FamilyDecl { fdInfo = info - , fdLName = synifyName tc - , fdTyVars = synifyTyVars (tyConTyVars tc) - , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) }) - Nothing -> error "synifyTyCon: impossible open type synonym?" - - | isDataFamilyTyCon tc - = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of - DataFamilyTyCon -> - FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - Nothing) --always kind '*' - _ -> error "synifyTyCon: impossible open data type?" - | isSynTyCon tc - = case synTyConRhs_maybe tc of - Just (SynonymTyCon ty) -> - SynDecl { tcdLName = synifyName tc - , tcdTyVars = synifyTyVars (tyConTyVars tc) - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNames } - _ -> error "synifyTyCon: impossible synTyCon" - | otherwise = - -- (closed) newtype and data - let - alg_nd = if isNewTyCon tc then NewType else DataType - alg_ctx = synifyCtx (tyConStupidTheta tc) - name = case coax of - Just a -> synifyName a -- Data families are named according to their - -- CoAxioms, not their TyCons - _ -> synifyName tc - tyvars = synifyTyVars (tyConTyVars tc) - kindSig = Just (tyConKind tc) - -- The data constructors. - -- - -- Any data-constructors not exported from the module that *defines* the - -- type will not (cannot) be included. - -- - -- Very simple constructors, Haskell98 with no existentials or anything, - -- probably look nicer in non-GADT syntax. In source code, all constructors - -- must be declared with the same (GADT vs. not) syntax, and it probably - -- is less confusing to follow that principle for the documentation as well. - -- - -- There is no sensible infix-representation for GADT-syntax constructor - -- declarations. They cannot be made in source code, but we could end up - -- with some here in the case where some constructors use existentials. - -- That seems like an acceptable compromise (they'll just be documented - -- in prefix position), since, otherwise, the logic (at best) gets much more - -- complicated. (would use dataConIsInfix.) - use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc) - cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc) - -- "deriving" doesn't affect the signature, no need to specify any. - alg_deriv = Nothing - defn = HsDataDefn { dd_ND = alg_nd - , dd_ctxt = alg_ctx - , dd_cType = Nothing - , dd_kindSig = fmap synifyKindSig kindSig - , dd_cons = cons - , dd_derivs = alg_deriv } - in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn - , tcdFVs = placeHolderNames } - --- User beware: it is your responsibility to pass True (use_gadt_syntax) --- for any constructor that would be misrepresented by omitting its --- result-type. --- But you might want pass False in simple enough cases, --- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> LConDecl Name -synifyDataCon use_gadt_syntax dc = noLoc $ - let - -- dataConIsInfix allegedly tells us whether it was declared with - -- infix *syntax*. - use_infix_syntax = dataConIsInfix dc - use_named_field_syntax = not (null field_tys) - name = synifyName dc - -- con_qvars means a different thing depending on gadt-syntax - (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc - - qvars = if use_gadt_syntax - then synifyTyVars (univ_tvs ++ ex_tvs) - else synifyTyVars ex_tvs - - -- skip any EqTheta, use 'orig'inal syntax - ctx = synifyCtx theta - - linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty - src_bang = case bang of - HsUnpack {} -> HsUserBang (Just True) True - HsStrict -> HsUserBang (Just False) True - _ -> bang - in case src_bang of - HsNoBang -> tySyn - _ -> noLoc $ HsBangTy bang tySyn - -- HsNoBang never appears, it's implied instead. - ) - arg_tys (dataConStrictMarks dc) - field_tys = zipWith (\field synTy -> ConDeclField - (synifyName field) synTy Nothing) - (dataConFieldLabels dc) linear_tys - hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of - (True,True) -> error "synifyDataCon: contradiction!" - (True,False) -> RecCon field_tys - (False,False) -> PrefixCon linear_tys - (False,True) -> case linear_tys of - [a,b] -> InfixCon a b - _ -> error "synifyDataCon: infix with non-2 args?" - hs_res_ty = if use_gadt_syntax - then ResTyGADT (synifyType WithinType res_ty) - else ResTyH98 - -- finally we get synifyDataCon's result! - in ConDecl name Implicit{-we don't know nor care-} - qvars ctx hs_arg_tys hs_res_ty Nothing - False --we don't want any "deprecated GADT syntax" warnings! - - -synifyName :: NamedThing n => n -> Located Name -synifyName = noLoc . getName - - -synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) - - -synifyCtx :: [PredType] -> LHsContext Name -synifyCtx = noLoc . map (synifyType WithinType) - - -synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name -synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs - , hsq_tvs = map synifyTyVar tvs } - where - (kvs, tvs) = partition isKindVar ktvs - synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) - | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) - where - kind = tyVarKind tv - name = getName tv - ---states of what to do with foralls: -data SynifyTypeState - = WithinType - -- ^ normal situation. This is the safe one to use if you don't - -- quite understand what's going on. - | ImplicitizeForAll - -- ^ beginning of a function definition, in which, to make it look - -- less ugly, those rank-1 foralls are made implicit. - | DeleteTopLevelQuantification - -- ^ because in class methods the context is added to the type - -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) - -- which is rather sensible, - -- but we want to restore things to the source-syntax situation where - -- the defining class gets to quantify all its functions for free! - - -synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) -synifyType _ (TyConApp tc tys) - -- Use non-prefix tuple syntax where possible, because it looks nicer. - | isTupleTyCon tc, tyConArity tc == length tys = - noLoc $ HsTupleTy (case tupleTyConSort tc of - BoxedTuple -> HsBoxedTuple - ConstraintTuple -> HsConstraintTuple - UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) tys) - -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy (synifyType WithinType ty) - -- ditto for implicit parameter tycons - | tyConName tc == ipClassName - , [name, ty] <- tys - , Just x <- isStrLitTy name - = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) - -- and equalities - | tc == eqTyCon - , [ty1, ty2] <- tys - = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) - -- Most TyCons: - | otherwise = - foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar (getName tc)) - (map (synifyType WithinType) tys) -synifyType _ (AppTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsAppTy s1 s2 -synifyType _ (FunTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 - in noLoc $ HsFunTy s1 s2 -synifyType s forallty@(ForAllTy _tv _ty) = - let (tvs, ctx, tau) = tcSplitSigmaTy forallty - in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau - _ -> let - forallPlicitness = case s of - WithinType -> Explicit - ImplicitizeForAll -> Implicit - _ -> error "synifyType: impossible case!!!" - sTvs = synifyTyVars tvs - sCtx = synifyCtx ctx - sTau = synifyType WithinType tau - in noLoc $ - HsForAllTy forallPlicitness sTvs sCtx sTau -synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t - -synifyTyLit :: TyLit -> HsTyLit -synifyTyLit (NumTyLit n) = HsNumTy n -synifyTyLit (StrTyLit s) = HsStrTy s - -synifyKindSig :: Kind -> LHsKind Name -synifyKindSig k = synifyType WithinType k - -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name -synifyInstHead (_, preds, cls, types) = - ( getName cls - , map (unLoc . synifyType WithinType) ks - , map (unLoc . synifyType WithinType) ts - , ClassInst $ map (unLoc . synifyType WithinType) preds - ) - where (ks,ts) = break (not . isKind) types - --- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> InstHead Name -synifyFamInst fi opaque = - ( fi_fam fi - , map (unLoc . synifyType WithinType) ks - , map (unLoc . synifyType WithinType) ts - , case fi_flavor fi of - SynFamilyInst | opaque -> TypeInst Nothing - SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi - DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c - ) - where (ks,ts) = break (not . isKind) $ fi_tys fi diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs deleted file mode 100644 --- a/src/Haddock/Doc.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Haddock.Doc ( - docAppend -, docParagraph -, combineDocumentation -) where - -import Data.Maybe -import Data.Monoid -import Haddock.Types -import Data.Char (isSpace) - --- We put it here so that we can avoid a circular import --- anything relevant imports this module anyway -instance Monoid (Doc id) where - mempty = DocEmpty - mappend = docAppend - -combineDocumentation :: Documentation name -> Maybe (Doc name) -combineDocumentation (Documentation Nothing Nothing) = Nothing -combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc) - -docAppend :: Doc id -> Doc id -> Doc id -docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2) -docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d -docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2) -docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2) -docAppend DocEmpty d = d -docAppend d DocEmpty = d -docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2) -docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2)) -docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d -docAppend d1 d2 = DocAppend d1 d2 - --- again to make parsing easier - we spot a paragraph whose only item --- is a DocMonospaced and make it into a DocCodeBlock -docParagraph :: Doc id -> Doc id -docParagraph (DocMonospaced p) - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocString s1) (DocMonospaced p)) - | all isSpace s1 - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocString s1) - (DocAppend (DocMonospaced p) (DocString s2))) - | all isSpace s1 && all isSpace s2 - = DocCodeBlock (docCodeBlock p) -docParagraph (DocAppend (DocMonospaced p) (DocString s2)) - | all isSpace s2 - = DocCodeBlock (docCodeBlock p) -docParagraph p - = DocParagraph p - - --- Drop trailing whitespace from @..@ code blocks. Otherwise this: --- --- -- @ --- -- foo --- -- @ --- --- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML --- gives an extra vertical space after the code block. The single space --- on the final line seems to trigger the extra vertical space. --- -docCodeBlock :: Doc id -> Doc id -docCodeBlock (DocString s) - = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) -docCodeBlock (DocAppend l r) - = DocAppend l (docCodeBlock r) -docCodeBlock d = d diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs deleted file mode 100644 --- a/src/Haddock/GhcUtils.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# LANGUAGE FlexibleInstances, ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.GhcUtils --- Copyright : (c) David Waern 2006-2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Utils for dealing with types from the GHC API ------------------------------------------------------------------------------ -module Haddock.GhcUtils where - - -import Data.Version -import Control.Applicative ( (<$>) ) -import Control.Arrow -import Data.Foldable hiding (concatMap) -import Data.Function -import Data.Traversable -import Distribution.Compat.ReadP -import Distribution.Text - -import Exception -import Outputable -import Name -import Packages -import Module -import RdrName (GlobalRdrEnv) -import GhcMonad (withSession) -import HscTypes -import UniqFM -import GHC -import Class - - -moduleString :: Module -> String -moduleString = moduleNameString . moduleName - - --- return the (name,version) of the package -modulePackageInfo :: Module -> (String, [Char]) -modulePackageInfo modu = case unpackPackageId pkg of - Nothing -> (packageIdString pkg, "") - Just x -> (display $ pkgName x, showVersion (pkgVersion x)) - where pkg = modulePackageId modu - - --- This was removed from GHC 6.11 --- XXX we shouldn't be using it, probably - --- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if --- we could not parse it as such an object. -unpackPackageId :: PackageId -> Maybe PackageIdentifier -unpackPackageId p - = case [ pid | (pid,"") <- readP_to_S parse str ] of - [] -> Nothing - (pid:_) -> Just pid - where str = packageIdString p - - -lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) -lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> - case lookupUFM (hsc_HPT hsc_env) mod_name of - Just mod_info -> return (mi_globals (hm_iface mod_info)) - _not_a_home_module -> return Nothing - - -isNameSym :: Name -> Bool -isNameSym = isSymOcc . nameOccName - - -isVarSym :: OccName -> Bool -isVarSym = isLexVarSym . occNameFS - -isConSym :: OccName -> Bool -isConSym = isLexConSym . occNameFS - - -getMainDeclBinder :: HsDecl name -> [name] -getMainDeclBinder (TyClD d) = [tcdName d] -getMainDeclBinder (ValD d) = - case collectHsBindBinders d of - [] -> [] - (name:_) -> [name] -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - --- Extract the source location where an instance is defined. This is used --- to correlate InstDecls with their Instance/CoAxiom Names, via the --- instanceMap. -getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l -getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l -getInstLoc (TyFamInstD (TyFamInstDecl - -- Since CoAxioms' Names refer to the whole line for type family instances - -- in particular, we need to dig a bit deeper to pull out the entire - -- equation. This does not happen for data family instances, for some reason. - { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l - --- Useful when there is a signature with multiple names, e.g. --- foo, bar :: Types.. --- but only one of the names is exported and we have to change the --- type signature to only include the exported names. -filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) -filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) - -filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) -filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig -filterSigNames _ orig@(MinimalSig _) = Just orig -filterSigNames p (TypeSig ns ty) = - case filter (p . unLoc) ns of - [] -> Nothing - filtered -> Just (TypeSig filtered ty) -filterSigNames _ _ = Nothing - -ifTrueJust :: Bool -> name -> Maybe name -ifTrueJust True = Just -ifTrueJust False = const Nothing - -sigName :: LSig name -> [name] -sigName (L _ sig) = sigNameNoLoc sig - -sigNameNoLoc :: Sig name -> [name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n] -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] -sigNameNoLoc _ = [] - - -isTyClD :: HsDecl a -> Bool -isTyClD (TyClD _) = True -isTyClD _ = False - - -isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d -isClassD _ = False - - -isDocD :: HsDecl a -> Bool -isDocD (DocD _) = True -isDocD _ = False - - -isInstD :: HsDecl a -> Bool -isInstD (InstD _) = True -isInstD _ = False - - -isValD :: HsDecl a -> Bool -isValD (ValD _) = True -isValD _ = False - - -declATs :: HsDecl a -> [a] -declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d -declATs _ = [] - - -pretty :: Outputable a => DynFlags -> a -> String -pretty = showPpr - - -trace_ppr :: Outputable a => DynFlags -> a -> b -> b -trace_ppr dflags x y = trace (pretty dflags x) y - - -------------------------------------------------------------------------------- --- * Located -------------------------------------------------------------------------------- - - -unL :: Located a -> a -unL (L _ x) = x - - -reL :: a -> Located a -reL = L undefined - - -before :: Located a -> Located a -> Bool -before = (<) `on` getLoc - - -instance Foldable (GenLocated l) where - foldMap f (L _ x) = f x - - -instance Traversable (GenLocated l) where - mapM f (L l x) = (return . L l) =<< f x - traverse f (L l x) = L l <$> f x - -------------------------------------------------------------------------------- --- * NamedThing instances -------------------------------------------------------------------------------- - - -instance NamedThing (TyClDecl Name) where - getName = tcdName - - -instance NamedThing (ConDecl Name) where - getName = unL . con_name - - -------------------------------------------------------------------------------- --- * Subordinates -------------------------------------------------------------------------------- - - -class Parent a where - children :: a -> [Name] - - -instance Parent (ConDecl Name) where - children con = - case con_details con of - RecCon fields -> map (unL . cd_fld_name) fields - _ -> [] - - -instance Parent (TyClDecl Name) where - children d - | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d - | isClassDecl d = - map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] - | otherwise = [] - - --- | A parent and its children -family :: (NamedThing a, Parent a) => a -> (Name, [Name]) -family = getName &&& children - - --- | A mapping from the parent (main-binder) to its children and from each --- child to its grand-children, recursively. -families :: TyClDecl Name -> [(Name, [Name])] -families d - | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d)) - | isClassDecl d = [family d] - | otherwise = [] - - --- | A mapping from child to parent -parentMap :: TyClDecl Name -> [(Name, Name)] -parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] - - --- | The parents of a subordinate in a declaration -parents :: Name -> HsDecl Name -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] -parents _ _ = [] - - -------------------------------------------------------------------------------- --- * Utils that work in monads defined by GHC -------------------------------------------------------------------------------- - - -modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () -modifySessionDynFlags f = do - dflags <- getSessionDynFlags - _ <- setSessionDynFlags (f dflags) - return () - - --- | A variant of 'gbracket' where the return value from the first computation --- is not required. -gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c -gbracket_ before_ after thing = gbracket before_ (const after) (const thing) - --- Extract the minimal complete definition of a Name, if one exists -minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) -minimalDef n = do - mty <- lookupGlobalName n - case mty of - Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c - _ -> return Nothing - -------------------------------------------------------------------------------- --- * DynFlags -------------------------------------------------------------------------------- - - -setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags -setObjectDir f d = d{ objectDir = Just f} -setHiDir f d = d{ hiDir = Just f} -setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. -setOutputDir f = setObjectDir f . setHiDir f . setStubDir f - diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs deleted file mode 100644 --- a/src/Haddock/Interface.hs +++ /dev/null @@ -1,244 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Interface --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2010, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- This module typechecks Haskell modules using the GHC API and processes --- the result to create 'Interface's. The typechecking and the 'Interface' --- creation is interleaved, so that when a module is processed, the --- 'Interface's of all previously processed modules are available. The --- creation of an 'Interface' from a typechecked module is delegated to --- "Haddock.Interface.Create". --- --- When all modules have been typechecked and processed, information about --- instances are attached to each 'Interface'. This task is delegated to --- "Haddock.Interface.AttachInstances". Note that this is done as a separate --- step because GHC can't know about all instances until all modules have been --- typechecked. --- --- As a last step a link environment is built which maps names to the \"best\" --- places to link to in the documentation, and all 'Interface's are \"renamed\" --- using this environment. ------------------------------------------------------------------------------ -module Haddock.Interface ( - processModules -) where - - -import Haddock.GhcUtils -import Haddock.InterfaceFile -import Haddock.Interface.Create -import Haddock.Interface.AttachInstances -import Haddock.Interface.Rename -import Haddock.Options hiding (verbosity) -import Haddock.Types -import Haddock.Utils - -import Control.Monad -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Distribution.Verbosity -import System.Directory -import System.FilePath -import Text.Printf - -import Digraph -import DynFlags hiding (verbosity) -import Exception -import GHC hiding (verbosity) -import HscTypes -import FastString (unpackFS) - --- | Create 'Interface's and a link environment by typechecking the list of --- modules using the GHC API and processing the resulting syntax trees. -processModules - :: Verbosity -- ^ Verbosity of logging to 'stdout' - -> [String] -- ^ A list of file or module names sorted by - -- module topology - -> [Flag] -- ^ Command-line flags - -> [InterfaceFile] -- ^ Interface files of package dependencies - -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming - -- environment -processModules verbosity modules flags extIfaces = do - - out verbosity verbose "Creating interfaces..." - let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces - , iface <- ifInstalledIfaces ext ] - interfaces <- createIfaces0 verbosity modules flags instIfaceMap - - let exportedNames = - Set.unions $ map (Set.fromList . ifaceExports) $ - filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces - mods = Set.fromList $ map ifaceMod interfaces - out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap - - out verbosity verbose "Building cross-linking environment..." - -- Combine the link envs of the external packages into one - let extLinks = Map.unions (map ifLinkEnv extIfaces) - homeLinks = buildHomeLinks interfaces -- Build the environment for the home - -- package - links = homeLinks `Map.union` extLinks - - out verbosity verbose "Renaming interfaces..." - let warnings = Flag_NoWarnings `notElem` flags - dflags <- getDynFlags - let (interfaces'', msgs) = - runWriter $ mapM (renameInterface dflags links warnings) interfaces' - liftIO $ mapM_ putStrLn msgs - - return (interfaces'', homeLinks) - - --------------------------------------------------------------------------------- --- * Module typechecking and Interface creation --------------------------------------------------------------------------------- - - -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] -createIfaces0 verbosity modules flags instIfaceMap = - -- Output dir needs to be set before calling depanal since depanal uses it to - -- compute output file names that are stored in the DynFlags of the - -- resulting ModSummaries. - (if useTempDir then withTempOutputDir else id) $ do - modGraph <- depAnalysis - if needsTemplateHaskell modGraph then do - modGraph' <- enableCompilation modGraph - createIfaces verbosity flags instIfaceMap modGraph' - else - createIfaces verbosity flags instIfaceMap modGraph - - where - useTempDir :: Bool - useTempDir = Flag_NoTmpCompDir `notElem` flags - - - withTempOutputDir :: Ghc a -> Ghc a - withTempOutputDir action = do - tmp <- liftIO getTemporaryDirectory - x <- liftIO getProcessID - let dir = tmp ".haddock-" ++ show x - modifySessionDynFlags (setOutputDir dir) - withTempDir dir action - - - depAnalysis :: Ghc ModuleGraph - depAnalysis = do - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - depanal [] False - - - enableCompilation :: ModuleGraph -> Ghc ModuleGraph - enableCompilation modGraph = do - let enableComp d = let platform = targetPlatform d - in d { hscTarget = defaultObjectTarget platform } - modifySessionDynFlags enableComp - -- We need to update the DynFlags of the ModSummaries as well. - let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } - let modGraph' = map upd modGraph - return modGraph' - - -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] -createIfaces verbosity flags instIfaceMap mods = do - let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing - out verbosity normal "Haddock coverage:" - (ifaces, _) <- foldM f ([], Map.empty) sortedMods - return (reverse ifaces) - where - f (ifaces, ifaceMap) modSummary = do - x <- processModule verbosity modSummary flags ifaceMap instIfaceMap - return $ case x of - Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) - Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. - - -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) -processModule verbosity modsum flags modMap instIfaceMap = do - out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." - tm <- loadModule =<< typecheckModule =<< parseModule modsum - if not $ isBootSummary modsum then do - out verbosity verbose "Creating interface..." - (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap - liftIO $ mapM_ putStrLn msg - dflags <- getDynFlags - let (haddockable, haddocked) = ifaceHaddockCoverage interface - percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int - modString = moduleString (ifaceMod interface) - coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString - header = case ifaceDoc interface of - Documentation Nothing _ -> False - _ -> True - undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n - , expItemMbDoc = (Documentation Nothing _, _) - } <- ifaceExportItems interface ] - where - formatName :: SrcSpan -> HsDecl Name -> String - formatName loc n = p (getMainDeclBinder n) ++ case loc of - RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" - _ -> "" - - p [] = "" - p (x:_) = let n = pretty dflags x - ms = modString ++ "." - in if ms `isPrefixOf` n - then drop (length ms) n - else n - - out verbosity normal coverageMsg - when (Flag_PrintMissingDocs `elem` flags - && not (null undocumentedExports && header)) $ do - out verbosity normal " Missing documentation for:" - unless header $ out verbosity normal " Module header" - mapM_ (out verbosity normal . (" " ++)) undocumentedExports - interface' <- liftIO $ evaluate interface - return (Just interface') - else - return Nothing - - --------------------------------------------------------------------------------- --- * Building of cross-linking environment --------------------------------------------------------------------------------- - - --- | Build a mapping which for each original name, points to the "best" --- place to link to in the documentation. For the definition of --- "best", we use "the module nearest the bottom of the dependency --- graph which exports this name", not including hidden modules. When --- there are multiple choices, we pick a random one. --- --- The interfaces are passed in in topologically sorted order, but we start --- by reversing the list so we can do a foldl. -buildHomeLinks :: [Interface] -> LinkEnv -buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) - where - upd old_env iface - | OptHide `elem` ifaceOptions iface = old_env - | OptNotHome `elem` ifaceOptions iface = - foldl' keep_old old_env exported_names - | otherwise = foldl' keep_new old_env exported_names - where - exported_names = ifaceVisibleExports iface - mdl = ifaceMod iface - keep_old env n = Map.insertWith (\_ old -> old) n mdl env - keep_new env n = Map.insert n mdl env - - --------------------------------------------------------------------------------- --- * Utils --------------------------------------------------------------------------------- - - -withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a -withTempDir dir = gbracket_ (liftIO $ createDirectory dir) - (liftIO $ removeDirectoryRecursive dir) diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs deleted file mode 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Interface.AttachInstances --- Copyright : (c) Simon Marlow 2006, --- David Waern 2006-2009, --- Isaac Dupree 2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.AttachInstances (attachInstances) where - - -import Haddock.Types -import Haddock.Convert -import Haddock.GhcUtils - -import Control.Arrow -import Data.List -import Data.Ord (comparing) -import Data.Function (on) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Class -import FamInstEnv -import FastString -import GHC -import GhcMonad (withSession) -import Id -import InstEnv -import MonadUtils (liftIO) -import Name -import PrelNames -import TcRnDriver (tcRnGetInfo) -import TcType (tcSplitSigmaTy) -import TyCon -import TypeRep -import TysPrim( funTyCon ) -import Var hiding (varName) -#define FSLIT(x) (mkFastString# (x#)) - -type ExportedNames = Set.Set Name -type Modules = Set.Set Module -type ExportInfo = (ExportedNames, Modules) - --- Also attaches fixities -attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] -attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces - where - -- TODO: take an IfaceMap as input - ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] - - attach iface = do - newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) - (ifaceExportItems iface) - return $ iface { ifaceExportItems = newItems } - - -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name) -attachToExportItem expInfo iface ifaceMap instIfaceMap export = - case attachFixities export of - e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do - mb_info <- getAllInfo (tcdName d) - let export' = - e { - expItemInstances = - case mb_info of - Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, n) - | i <- sortBy (comparing instFam) fam_instances - , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap - , not $ isNameHidden expInfo (fi_fam i) - , not $ any (isTypeHidden expInfo) (fi_tys i) - , let opaque = isTypeHidden expInfo (fi_rhs i) - ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap) - | let is = [ (instanceHead' i, getName i) | i <- cls_instances ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys - ] - in cls_insts ++ fam_insts - Nothing -> [] - } - return export' - e -> return e - where - attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = - nubBy ((==) `on` fst) $ expItemFixities e ++ - [ (n',f) | n <- getMainDeclBinder d - , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap] - , n' <- n : subs - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] - ] } - - attachFixities e = e - - -instLookup :: (InstalledInterface -> Map.Map Name a) -> Name - -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a -instLookup f name iface ifaceMap instIfaceMap = - case Map.lookup name (f $ toInstalledIface iface) of - res@(Just _) -> res - Nothing -> do - let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap - iface' <- Map.lookup (nameModule name) ifaceMaps - Map.lookup name (f iface') - --- | Like GHC's 'instanceHead' but drops "silent" arguments. -instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) -instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) - where - dfun = is_dfun ispec - (tvs, cls, tys) = instanceHead ispec - (_, theta, _) = tcSplitSigmaTy (idType dfun) - --- | Drop "silent" arguments. See GHC Note [Silent superclass --- arguments]. -dropSilentArgs :: DFunId -> ThetaType -> ThetaType -dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta - - --- | Like GHC's getInfo but doesn't cut things out depending on the --- interative context, which we don't set sufficiently anyway. -getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -getAllInfo name = withSession $ \hsc_env -> do - (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name - return r - - --------------------------------------------------------------------------------- --- Collecting and sorting instances --------------------------------------------------------------------------------- - - --- | Simplified type for sorting types, ignoring qualification (not visible --- in Haddock output) and unifying special tycons with normal ones. --- For the benefit of the user (looks nice and predictable) and the --- tests (which prefer output to be deterministic). -data SimpleType = SimpleType Name [SimpleType] - | SimpleTyLit TyLit - deriving (Eq,Ord) - - -instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) -instHead (_, _, cls, args) - = (map argCount args, className cls, map simplify args) - -argCount :: Type -> Int -argCount (AppTy t _) = argCount t + 1 -argCount (TyConApp _ ts) = length ts -argCount (FunTy _ _ ) = 2 -argCount (ForAllTy _ t) = argCount t -argCount _ = 0 - -simplify :: Type -> SimpleType -simplify (ForAllTy _ t) = simplify t -simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] -simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) - where (SimpleType s ts) = simplify t1 -simplify (TyVarTy v) = SimpleType (tyVarName v) [] -simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) -simplify (LitTy l) = SimpleTyLit l - --- Used for sorting -instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) -instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } - = (map argCount ts, n, map simplify ts, argCount t, simplify t) - - -funTyConName :: Name -funTyConName = mkWiredInName gHC_PRIM - (mkOccNameFS tcName FSLIT("(->)")) - funTyConKey - (ATyCon funTyCon) -- Relevant TyCon - BuiltInSyntax - --------------------------------------------------------------------------------- --- Filtering hidden instances --------------------------------------------------------------------------------- - --- | A class or data type is hidden iff --- --- * it is defined in one of the modules that are being processed --- --- * and it is not exported by any non-hidden module -isNameHidden :: ExportInfo -> Name -> Bool -isNameHidden (names, modules) name = - nameModule name `Set.member` modules && - not (name `Set.member` names) - --- | We say that an instance is «hidden» iff its class or any (part) --- of its type(s) is hidden. -isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool -isInstanceHidden expInfo cls tys = - instClassHidden || instTypeHidden - where - instClassHidden :: Bool - instClassHidden = isNameHidden expInfo $ getName cls - - instTypeHidden :: Bool - instTypeHidden = any (isTypeHidden expInfo) tys - -isTypeHidden :: ExportInfo -> Type -> Bool -isTypeHidden expInfo = typeHidden - where - typeHidden :: Type -> Bool - typeHidden t = - case t of - TyVarTy {} -> False - AppTy t1 t2 -> typeHidden t1 || typeHidden t2 - TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args - FunTy t1 t2 -> typeHidden t1 || typeHidden t2 - ForAllTy _ ty -> typeHidden ty - LitTy _ -> False - - nameHidden :: Name -> Bool - nameHidden = isNameHidden expInfo diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs deleted file mode 100644 --- a/src/Haddock/Interface/Create.hs +++ /dev/null @@ -1,867 +0,0 @@ -{-# LANGUAGE TupleSections, BangPatterns #-} -{-# OPTIONS_GHC -Wwarn #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Interface.Create --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.Create (createInterface) where - - -import Haddock.Types -import Haddock.Options -import Haddock.GhcUtils -import Haddock.Utils -import Haddock.Convert -import Haddock.Interface.LexParseRn - -import qualified Data.Map as M -import Data.Map (Map) -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Ord -import Control.Applicative -import Control.DeepSeq -import Control.Monad -import Data.Function (on) -import qualified Data.Foldable as F -import qualified Data.Traversable as T - -import qualified Packages -import qualified Module -import qualified SrcLoc -import GHC -import HscTypes -import Name -import Bag -import RdrName -import TcRnTypes -import FastString (unpackFS, concatFS) - - --- | Use a 'TypecheckedModule' to produce an 'Interface'. --- To do this, we need access to already processed modules in the topological --- sort. That's what's in the 'IfaceMap'. -createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface -createInterface tm flags modMap instIfaceMap = do - - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - L _ hsm = parsedSource tm - !safety = modInfoSafe mi - mdl = ms_mod ms - dflags = ms_hspp_opts ms - !instances = modInfoInstances mi - !fam_instances = md_fam_insts md - !exportedNames = modInfoExports mi - - (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm - - -- The renamed source should always be available to us, but it's best - -- to be on the safe side. - (group_, mayExports, mayDocHeader) <- - case renamedSource tm of - Nothing -> do - liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, Nothing, Nothing) - Just (x, _, y, z) -> return (x, y, z) - - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - let opts - | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 - | otherwise = opts0 - - (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader - - let declsWithDocs = topDecls group_ - fixMap = mkFixMap group_ - (decls, _) = unzip declsWithDocs - localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances - ++ map getName fam_instances - -- Locations of all TH splices - splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] - - maps@(!docMap, !argMap, !subMap, !declMap, _) <- - liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs - - let exports0 = fmap (reverse . map unLoc) mayExports - exports - | OptIgnoreExports `elem` opts = Nothing - | otherwise = exports0 - - warningMap <- liftErrMsg $ mkWarningMap dflags warnings gre exportedNames - - let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) - - exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls - maps fixMap splices exports instIfaceMap dflags - - let !visibleNames = mkVisibleNames maps exportItems opts - - -- Measure haddock documentation coverage. - let prunedExportItems0 = pruneExportItems exportItems - !haddockable = 1 + length exportItems -- module + exports - !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - !coverage = (haddockable, haddocked) - - -- Prune the export list to just those declarations that have - -- documentation, if the 'prune' option is on. - let prunedExportItems' - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems - !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - - let !aliases = - mkAliasMap dflags $ tm_renamed_source tm - - modWarn <- liftErrMsg $ moduleWarning dflags gre warnings - - return $! Interface { - ifaceMod = mdl - , ifaceOrigFilename = msHsFilePath ms - , ifaceInfo = info - , ifaceDoc = Documentation mbDoc modWarn - , ifaceRnDoc = Documentation Nothing Nothing - , ifaceOptions = opts - , ifaceDocMap = docMap - , ifaceArgMap = argMap - , ifaceRnDocMap = M.empty - , ifaceRnArgMap = M.empty - , ifaceExportItems = prunedExportItems - , ifaceRnExportItems = [] - , ifaceExports = exportedNames - , ifaceVisibleExports = visibleNames - , ifaceDeclMap = declMap - , ifaceSubMap = subMap - , ifaceFixMap = fixMap - , ifaceModuleAliases = aliases - , ifaceInstances = instances - , ifaceFamInstances = fam_instances - , ifaceHaddockCoverage = coverage - , ifaceWarningMap = warningMap - } - -mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName -mkAliasMap dflags mRenamedSource = - case mRenamedSource of - Nothing -> M.empty - Just (_,impDecls,_,_) -> - M.fromList $ - mapMaybe (\(SrcLoc.L _ impDecl) -> do - alias <- ideclAs impDecl - return $ - (lookupModuleDyn dflags - (fmap Module.fsToPackageId $ - ideclPkgQual impDecl) - (case ideclName impDecl of SrcLoc.L _ name -> name), - alias)) - impDecls - --- similar to GHC.lookupModule -lookupModuleDyn :: - DynFlags -> Maybe PackageId -> ModuleName -> Module -lookupModuleDyn _ (Just pkgId) mdlName = - Module.mkModule pkgId mdlName -lookupModuleDyn dflags Nothing mdlName = - flip Module.mkModule mdlName $ - case filter snd $ - Packages.lookupModuleInAllPackages dflags mdlName of - (pkgId,_):_ -> Packages.packageConfigId pkgId - [] -> Module.mainPackageId - - -------------------------------------------------------------------------------- --- Warnings -------------------------------------------------------------------------------- - -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap -mkWarningMap dflags warnings gre exps = case warnings of - NoWarnings -> return M.empty - WarnAll _ -> return M.empty - WarnSome ws -> do - let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ - , let n = gre_name elt, n `elem` exps ] - M.fromList <$> mapM parse ws' - where - parse (n, w) = (,) n <$> parseWarning dflags gre w - - -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name)) -moduleWarning dflags gre ws = - case ws of - NoWarnings -> return Nothing - WarnSome _ -> return Nothing - WarnAll w -> Just <$> parseWarning dflags gre w - -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) -parseWarning dflags gre w = do - r <- case w of - (DeprecatedTxt msg) -> format "Deprecated: " (concatFS msg) - (WarningTxt msg) -> format "Warning: " (concatFS msg) - r `deepseq` return r - where - format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - . fromMaybe (DocString . unpackFS $ xs) - <$> processDocString dflags gre (HsDocString xs) - - -------------------------------------------------------------------------------- --- Doc options --- --- Haddock options that are embedded in the source file -------------------------------------------------------------------------------- - - -mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] -mkDocOpts mbOpts flags mdl = do - opts <- case mbOpts of - Just opts -> case words $ replace ',' ' ' opts of - [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] - xs -> liftM catMaybes (mapM parseOption xs) - Nothing -> return [] - hm <- if Flag_HideModule (moduleString mdl) `elem` flags - then return $ OptHide : opts - else return opts - if Flag_ShowExtensions (moduleString mdl) `elem` flags - then return $ OptShowExtensions : hm - else return hm - - -parseOption :: String -> ErrMsgM (Maybe DocOption) -parseOption "hide" = return (Just OptHide) -parseOption "prune" = return (Just OptPrune) -parseOption "ignore-exports" = return (Just OptIgnoreExports) -parseOption "not-home" = return (Just OptNotHome) -parseOption "show-extensions" = return (Just OptShowExtensions) -parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing - - --------------------------------------------------------------------------------- --- Maps --------------------------------------------------------------------------------- - - -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) - --- | Create 'Maps' by looping through the declarations. For each declaration, --- find its names, its subordinates, and its doc strings. Process doc strings --- into 'Doc's. -mkMaps :: DynFlags - -> GlobalRdrEnv - -> [Name] - -> [(LHsDecl Name, [HsDocString])] - -> ErrMsgM Maps -mkMaps dflags gre instances decls = do - (a, b, c, d) <- unzip4 <$> mapM mappings decls - return (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) - where - f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - - mappings (ldecl, docStrs) = do - let L l decl = ldecl - let declDoc strs m = do - doc <- processDocStrings dflags gre strs - m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m - return (doc, m') - (doc, args) <- declDoc docStrs (typeDocs decl) - let subs = subordinates instanceMap decl - (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs - let ns = names l decl - subNs = [ n | (n, _, _) <- subs ] - dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] - am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - sm = [ (n, subNs) | n <- ns ] - cm = [ (n, [ldecl]) | n <- ns ++ subNs ] - seqList ns `seq` - seqList subNs `seq` - doc `seq` - seqList subDocs `seq` - seqList subArgs `seq` - return (dm, am, sm, cm) - - instanceMap :: Map SrcSpan Name - instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - - names :: SrcSpan -> HsDecl Name -> [Name] - names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. - where loc = case d of - TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs - _ -> getInstLoc d - names _ decl = getMainDeclBinder decl - --- Note [2]: ------------- --- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. --- That should work for normal user-written instances (from looking at GHC --- sources). We can assume that commented instances are user-written. --- This lets us relate Names (from ClsInsts) to comments (associated --- with InstDecls). - - --------------------------------------------------------------------------------- --- Declarations --------------------------------------------------------------------------------- - - --- | Get all subordinate declarations inside a declaration, and their docs. -subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] -subordinates instMap decl = case decl of - InstD (ClsInstD d) -> do - DataFamInstDecl { dfid_tycon = L l _ - , dfid_defn = def } <- unLoc <$> cid_datafam_insts d - [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def - - InstD (DataFamInstD d) -> dataSubs (dfid_defn d) - TyClD d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) - _ -> [] - where - classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) - ] - dataSubs dd = constrs ++ fields - where - cons = map unL $ (dd_cons dd) - constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) - | c <- cons ] - fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map con_details cons - , ConDeclField n _ doc <- flds ] - --- | Extract function argument docs from inside types. -typeDocs :: HsDecl Name -> Map Int HsDocString -typeDocs d = - let docs = go 0 in - case d of - SigD (TypeSig _ ty) -> docs (unLoc ty) - SigD (PatSynSig _ arg_tys ty req prov) -> - let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ] - in F.foldMap (docs . unLoc) allTys - ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) - _ -> M.empty - where - go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) - go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ (L _ doc)) = M.singleton n doc - go _ _ = M.empty - - --- | All the sub declarations of a class (that we handle), ordered by --- source location, with documentation attached if it exists. -classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ - - --- | The top-level declarations of a module that we care about, --- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup - --- | Extract a map of fixity declarations only -mkFixMap :: HsGroup Name -> FixMap -mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ] - - --- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup Name -> [LHsDecl Name] -ungroup group_ = - mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls hs_instds InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ - where - typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs - typesigs _ = error "expected ValBindsOut" - - valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds - valbinds _ = error "expected ValBindsOut" - - --- | Take a field of declarations from a data structure and create HsDecls --- using the given constructor -mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] -mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] - - --- | Sort by source location -sortByLoc :: [Located a] -> [Located a] -sortByLoc = sortBy (comparing getLoc) - - --------------------------------------------------------------------------------- --- Filtering of declarations --- --- We filter out declarations that we don't intend to handle later. --------------------------------------------------------------------------------- - - --- | Filter out declarations that we don't handle in Haddock -filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls = filter (isHandled . unL . fst) - where - isHandled (ForD (ForeignImport {})) = True - isHandled (TyClD {}) = True - isHandled (InstD {}) = True - isHandled (SigD d) = isVanillaLSig (reL d) - isHandled (ValD _) = True - -- we keep doc declarations to be able to get at named docs - isHandled (DocD _) = True - isHandled _ = False - - --- | Go through all class declarations and filter their sub-declarations -filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x - | x@(L loc d, doc) <- decls ] - where - filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } - filterClass _ = error "expected TyClD" - - --------------------------------------------------------------------------------- --- Collect docs --- --- To be able to attach the right Haddock comment to the right declaration, --- we sort the declarations by their SrcLoc and "collect" the docs for each --- declaration. --------------------------------------------------------------------------------- - - --- | Collect docs and attach them to the right declarations. -collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] -collectDocs = go Nothing [] - where - go Nothing _ [] = [] - go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD (DocCommentNext str)) : ds) - | Nothing <- prev = go Nothing (str:docs) ds - | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds - go Nothing docs (d:ds) = go (Just d) docs ds - go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) - - finished decl docs rest = (decl, reverse docs) : rest - - --- | Build the list of items that will become the documentation, from the --- export list. At this point, the list of ExportItems is in terms of --- original names. --- --- We create the export items even if the module is hidden, since they --- might be useful when creating the export items for other modules. -mkExportItems - :: IfaceMap - -> Module -- this module - -> WarningMap - -> GlobalRdrEnv - -> [Name] -- exported names (orig) - -> [LHsDecl Name] - -> Maps - -> FixMap - -> [SrcSpan] -- splice locations - -> Maybe [IE Name] - -> InstIfaceMap - -> DynFlags - -> ErrMsgGhc [ExportItem Name] -mkExportItems - modMap thisMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = - case optExports of - Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls - Just exports -> liftM concat $ mapM lookupExport exports - where - lookupExport (IEVar x) = declWith x - lookupExport (IEThingAbs t) = declWith t - lookupExport (IEThingAll t) = declWith t - lookupExport (IEThingWith t _) = declWith t - lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = liftErrMsg $ - ifDoc (processDocString dflags gre docStr) - (\doc -> return [ ExportGroup lev "" doc ]) - lookupExport (IEDoc docStr) = liftErrMsg $ - ifDoc (processDocStringParas dflags gre docStr) - (\doc -> return [ ExportDoc doc ]) - lookupExport (IEDocNamed str) = liftErrMsg $ - ifDoc (findNamedDoc str [ unL d | d <- decls ]) - (\docStr -> - ifDoc (processDocStringParas dflags gre docStr) - (\doc -> return [ ExportDoc doc ])) - - - ifDoc :: (Monad m) => m (Maybe a) -> (a -> m [b]) -> m [b] - ifDoc parse finish = do - mbDoc <- parse - case mbDoc of Nothing -> return []; Just doc -> finish doc - - - declWith :: Name -> ErrMsgGhc [ ExportItem Name ] - declWith t = - case findDecl t of - ([L l (ValD _)], (doc, _)) -> do - -- Top-level binding without type signature - export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap - return [export] - (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> - let declNames = getMainDeclBinder (unL decl) - in case () of - _ - -- temp hack: we filter out separately exported ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | t `elem` declATs (unL decl) -> return [] - - -- We should not show a subordinate by itself if any of its - -- parents is also exported. See note [1]. - | t `notElem` declNames, - Just p <- find isExported (parents t $ unL decl) -> - do liftErrMsg $ tell [ - "Warning: " ++ moduleString thisMod ++ ": " ++ - pretty dflags (nameOccName t) ++ " is exported separately but " ++ - "will be documented under " ++ pretty dflags (nameOccName p) ++ - ". Consider exporting it together with its parent(s)" ++ - " for code clarity." ] - return [] - - -- normal case - | otherwise -> case decl of - -- A single signature might refer to many names, but we - -- create an export item for a single name only. So we - -- modify the signature to contain only that single name. - L loc (SigD sig) -> - -- fromJust is safe since we already checked in guards - -- that 't' is a name declared in this declaration. - let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig - in return [ mkExportDecl t newDecl docs_ ] - - L loc (TyClD cl@ClassDecl{}) -> do - mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef - return [ mkExportDecl t - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] - - _ -> return [ mkExportDecl t decl docs_ ] - - -- Declaration from another package - ([], _) -> do - mayDecl <- hiDecl dflags t - case mayDecl of - Nothing -> return [ ExportNoDecl t [] ] - Just decl -> - -- We try to get the subs and docs - -- from the installed .haddock file for that package. - case M.lookup (nameModule t) instIfaceMap of - Nothing -> do - liftErrMsg $ tell - ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] - let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] - return [ mkExportDecl t decl (noDocForDecl, subs_) ] - Just iface -> - return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] - - _ -> return [] - - - mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name - mkExportDecl name decl (doc, subs) = decl' - where - decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False - mdl = nameModule name - subs' = filter (isExported . fst) subs - sub_names = map fst subs' - fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] - - - isExported = (`elem` exportedNames) - - - findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) - findDecl n - | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n warnings docMap argMap subMap) - | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) - | otherwise = ([], (noDocForDecl, [])) - where - m = nameModule n - - -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) -hiDecl dflags t = do - mayTyThing <- liftGhcToErrMsgGhc $ lookupName t - case mayTyThing of - Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] - return Nothing - Just x -> return (Just (tyThingToLHsDecl x)) - - -hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) -hiValExportItem dflags name doc splice fixity = do - mayDecl <- hiDecl dflags name - case mayDecl of - Nothing -> return (ExportNoDecl name []) - Just decl -> return (ExportDecl decl doc [] [] fixities splice) - where - fixities = case fixity of - Just f -> [(name, f)] - Nothing -> [] - - --- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings docMap argMap subMap = - let lookupArgDoc x = M.findWithDefault M.empty x argMap in - let doc = (lookupDoc n, lookupArgDoc n) in - let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in - (doc, subDocs) - where - lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) - - --- | Return all export items produced by an exported module. That is, we're --- interested in the exports produced by \"module B\" in such a scenario: --- --- > module A (module B) where --- > import B (...) hiding (...) --- --- There are three different cases to consider: --- --- 1) B is hidden, in which case we return all its exports that are in scope in A. --- 2) B is visible, but not all its exports are in scope in A, in which case we --- only return those that are. --- 3) B is visible and all its exports are in scope, in which case we return --- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A - -> ModuleName -- ^ The real name of B, the exported module - -> DynFlags -- ^ The flags used when typechecking A - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment used for A - -> [Name] -- ^ All the exports of A - -> [LHsDecl Name] -- ^ All the declarations in A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> Maps - -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls - | otherwise = - case M.lookup m ifaceMap of - Just iface - | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) - | otherwise -> return [ ExportModule m ] - - Nothing -> -- We have to try to find it in the installed interfaces - -- (external packages). - case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of - Just iface -> return [ ExportModule (instMod iface) ] - Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty dflags expMod] - return [] - where - m = mkModule packageId expMod - packageId = modulePackageId thisMod - - --- Note [1]: ------------- --- It is unnecessary to document a subordinate by itself at the top level if --- any of its parents is also documented. Furthermore, if the subordinate is a --- record field or a class method, documenting it under its parent --- indicates its special status. --- --- A user might expect that it should show up separately, so we issue a --- warning. It's a fine opportunity to also tell the user she might want to --- export the subordinate through the parent export item for clarity. --- --- The code removes top-level subordinates also when the parent is exported --- through a 'module' export. I think that is fine. --- --- (For more information, see Trac #69) - - -fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] - -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSig decls) - where - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- - -- We go through the list of declarations and expand type signatures, so - -- that every type signature has exactly one name! - expandSig :: [LHsDecl name] -> [LHsDecl name] - expandSig = foldr f [] - where - f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] - f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names - f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names - f x xs = x : xs - - mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) - mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - mbDoc <- liftErrMsg $ processDocString dflags gre docStr - return $ fmap (ExportGroup lev "") mbDoc - mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr - return $ fmap ExportDoc mbDoc - mkExportItem (L l (ValD d)) - | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = - -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) - | otherwise = return Nothing - mkExportItem decl@(L l (InstD d)) - | Just name <- M.lookup (getInstLoc d) instMap = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) - mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do - mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef - expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name - mkExportItem decl@(L l d) - | name:_ <- getMainDeclBinder d = expDecl decl l name - | otherwise = return Nothing - - fixities name subs = [ (n,f) | n <- name : map fst subs - , Just f <- [M.lookup n fixMap] ] - - expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) - where (doc, subs) = lookupDocs name warnings docMap argMap subMap - - --- | Sometimes the declaration we want to export is not the "main" declaration: --- it might be an individual record selector or a class method. In these --- cases we have to extract the required declaration (and somehow cobble --- together a type signature for it...). -extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name -extractDecl name mdl decl - | name `elem` getMainDeclBinder (unLoc decl) = decl - | otherwise = - case unLoc decl of - TyClD d@ClassDecl {} -> - let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, - isVanillaLSig sig ] -- TODO: document fixity - in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) - L pos sig = extractClassDecl n tyvar_names s0 - in L pos (SigD sig) - _ -> error "internal: extractDecl (ClassDecl)" - TyClD d@DataDecl {} -> - let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) - in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) - InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n - , dfid_pats = HsWB { hswb_cts = tys } - , dfid_defn = defn }) -> - SigD <$> extractRecSel name mdl n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> - let matches = [ d | L _ d <- insts - , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d) - , ConDeclField { cd_fld_name = L _ n } <- rec - , n == name - ] - in case matches of - [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) - _ -> error "internal: extractDecl (ClsInstD)" - _ -> error "internal: extractDecl" - where - getTyVars = hsLTyVarLocNames . tyClDeclTyVars - - -toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc - - -extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name -extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of - L _ (HsForAllTy expl tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) - where - lctxt = noLoc . ctxt - ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds -extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" - - -extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] - -> LSig Name -extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" - -extractRecSel nm mdl t tvs (L _ con : rest) = - case con_details con of - RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> - L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) - _ -> extractRecSel nm mdl t tvs rest - where - matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] - data_ty - | ResTyGADT ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs - - --- | Keep export items with docs. -pruneExportItems :: [ExportItem Name] -> [ExportItem Name] -pruneExportItems = filter hasDoc - where - hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d - hasDoc _ = True - - -mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts - | OptHide `elem` opts = [] - | otherwise = let ns = concatMap exportName exports - in seqList ns `seq` ns - where - exportName e@ExportDecl {} = name ++ subs - where subs = map fst (expItemSubDocs e) - name = case unLoc $ expItemDecl e of - InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap - decl -> getMainDeclBinder decl - exportName ExportNoDecl {} = [] -- we don't count these as visible, since - -- we don't want links to go to them. - exportName _ = [] - -seqList :: [a] -> () -seqList [] = () -seqList (x : xs) = x `seq` seqList xs - --- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) -findNamedDoc name = search - where - search [] = do - tell ["Cannot find documentation for: $" ++ name] - return Nothing - search (DocD (DocCommentNamed name' doc) : rest) - | name == name' = return (Just doc) - | otherwise = search rest - search (_other_decl : rest) = search rest diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs deleted file mode 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE BangPatterns #-} - ----------------------------------------------------------------------------- --- | --- Module : Haddock.Interface.LexParseRn --- Copyright : (c) Isaac Dupree 2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.LexParseRn - ( processDocString - , processDocStringParas - , processDocStrings - , processModuleHeader - ) where - -import qualified Data.IntSet as IS -import Haddock.Types -import Haddock.Parser -import Haddock.Interface.ParseModuleHeader -import Haddock.Doc - -import Control.Applicative -import Data.List -import Data.Maybe -import FastString -import GHC -import DynFlags (ExtensionFlag(..), languageExtensions) -import Name -import Outputable -import RdrName - -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) -processDocStrings dflags gre strs = do - docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs - let doc = foldl' docAppend DocEmpty docs - case doc of - DocEmpty -> return Nothing - _ -> return (Just doc) - - -processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) -processDocStringParas = process parseParasMaybe - - -processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) -processDocString = process parseStringMaybe - -process :: (DynFlags -> String -> Maybe (Doc RdrName)) - -> DynFlags - -> GlobalRdrEnv - -> HsDocString - -> ErrMsgM (Maybe (Doc Name)) -process parse dflags gre (HsDocString fs) = do - let str = unpackFS fs - case parse dflags str of - Nothing -> do - tell [ "doc comment parse failed: " ++ str ] - return Nothing - Just doc -> do - return (Just (rename dflags gre doc)) - - -processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString - -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) -processModuleHeader dflags gre safety mayStr = do - (hmi, doc) <- - case mayStr of - - Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs - case parseModuleHeader dflags str of - Left msg -> do - tell ["haddock module header parse failed: " ++ msg] - return failure - Right (hmi, doc) -> do - let !descr = rename dflags gre <$> hmi_description hmi - hmi' = hmi { hmi_description = descr } - doc' = rename dflags gre doc - return (hmi', Just doc') - - let flags :: [ExtensionFlag] - -- We remove the flags implied by the language setting and we display the language instead - flags = map toEnum (IS.toList $ extensionFlags dflags) \\ languageExtensions (language dflags) - return (hmi { hmi_safety = Just $ showPpr dflags safety - , hmi_language = language dflags - , hmi_extensions = flags - } , doc) - where - failure = (emptyHaddockModInfo, Nothing) - - -rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name -rename dflags gre = rn - where - rn d = case d of - DocAppend a b -> DocAppend (rn a) (rn b) - DocParagraph doc -> DocParagraph (rn doc) - DocIdentifier x -> do - let choices = dataTcOccs' x - let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices - case names of - [] -> - case choices of - [] -> DocMonospaced (DocString (showPpr dflags x)) - [a] -> outOfScope dflags a - a:b:_ | isRdrTc a -> outOfScope dflags a - | otherwise -> outOfScope dflags b - [a] -> DocIdentifier a - a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b - -- If an id can refer to multiple things, we give precedence to type - -- constructors. - - DocWarning doc -> DocWarning (rn doc) - DocEmphasis doc -> DocEmphasis (rn doc) - DocBold doc -> DocBold (rn doc) - DocMonospaced doc -> DocMonospaced (rn doc) - DocUnorderedList docs -> DocUnorderedList (map rn docs) - DocOrderedList docs -> DocOrderedList (map rn docs) - DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] - DocCodeBlock doc -> DocCodeBlock (rn doc) - DocIdentifierUnchecked x -> DocIdentifierUnchecked x - DocModule str -> DocModule str - DocHyperlink l -> DocHyperlink l - DocPic str -> DocPic str - DocAName str -> DocAName str - DocProperty p -> DocProperty p - DocExamples e -> DocExamples e - DocEmpty -> DocEmpty - DocString str -> DocString str - DocHeader (Header l t) -> DocHeader $ Header l (rn t) - -dataTcOccs' :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- We use this definition instead of the GHC's to provide proper linking to --- functions accross modules. See ticket #253 on Haddock Trac. -dataTcOccs' rdr_name - | isDataOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - - -outOfScope :: DynFlags -> RdrName -> Doc a -outOfScope dflags x = - case x of - Unqual occ -> monospaced occ - Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) - Orig _ occ -> monospaced occ - Exact name -> monospaced name -- Shouldn't happen since x is out of scope - where - monospaced a = DocMonospaced (DocString (showPpr dflags a)) diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs deleted file mode 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Interface.ParseModuleHeader --- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where - -import Haddock.Types -import Haddock.Parser - -import RdrName -import DynFlags - -import Data.Char -import Control.Monad (mplus) - --- ----------------------------------------------------------------------------- --- Parsing module headers - --- NB. The headers must be given in the order Module, Description, --- Copyright, License, Maintainer, Stability, Portability, except that --- any or all may be omitted. -parseModuleHeader :: DynFlags -> String -> Either String (HaddockModInfo RdrName, Doc RdrName) -parseModuleHeader dflags str0 = - let - getKey :: String -> String -> (Maybe String,String) - getKey key str = case parseKey key str of - Nothing -> (Nothing,str) - Just (value,rest) -> (Just value,rest) - - (_moduleOpt,str1) = getKey "Module" str0 - (descriptionOpt,str2) = getKey "Description" str1 - (copyrightOpt,str3) = getKey "Copyright" str2 - (licenseOpt,str4) = getKey "License" str3 - (licenceOpt,str5) = getKey "Licence" str4 - (maintainerOpt,str6) = getKey "Maintainer" str5 - (stabilityOpt,str7) = getKey "Stability" str6 - (portabilityOpt,str8) = getKey "Portability" str7 - - description1 :: Either String (Maybe (Doc RdrName)) - description1 = case descriptionOpt of - Nothing -> Right Nothing - Just description -> case parseStringMaybe dflags description of - Nothing -> Left ("Cannot parse Description: " ++ description) - Just doc -> Right (Just doc) - in - case description1 of - Left mess -> Left mess - Right docOpt -> case parseParasMaybe dflags str8 of - Nothing -> Left "Cannot parse header documentation paragraphs" - Just doc -> Right (HaddockModInfo { - hmi_description = docOpt, - hmi_copyright = copyrightOpt, - hmi_license = licenseOpt `mplus` licenceOpt, - hmi_maintainer = maintainerOpt, - hmi_stability = stabilityOpt, - hmi_portability = portabilityOpt, - hmi_safety = Nothing, - hmi_language = Nothing, -- set in LexParseRn - hmi_extensions = [] -- also set in LexParseRn - }, doc) - --- | This function is how we read keys. --- --- all fields in the header are optional and have the form --- --- [spaces1][field name][spaces] ":" --- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* --- where each [spaces2] should have [spaces1] as a prefix. --- --- Thus for the key "Description", --- --- > Description : this is a --- > rather long --- > --- > description --- > --- > The module comment starts here --- --- the value will be "this is a .. description" and the rest will begin --- at "The module comment". -parseKey :: String -> String -> Maybe (String,String) -parseKey key toParse0 = - do - let - (spaces0,toParse1) = extractLeadingSpaces toParse0 - - indentation = spaces0 - afterKey0 <- extractPrefix key toParse1 - let - afterKey1 = extractLeadingSpaces afterKey0 - afterColon0 <- case snd afterKey1 of - ':':afterColon -> return afterColon - _ -> Nothing - let - (_,afterColon1) = extractLeadingSpaces afterColon0 - - return (scanKey True indentation afterColon1) - where - scanKey :: Bool -> String -> String -> (String,String) - scanKey _ _ [] = ([],[]) - scanKey isFirst indentation str = - let - (nextLine,rest1) = extractNextLine str - - accept = isFirst || sufficientIndentation || allSpaces - - sufficientIndentation = case extractPrefix indentation nextLine of - Just (c:_) | isSpace c -> True - _ -> False - - allSpaces = case extractLeadingSpaces nextLine of - (_,[]) -> True - _ -> False - in - if accept - then - let - (scanned1,rest2) = scanKey False indentation rest1 - - scanned2 = case scanned1 of - "" -> if allSpaces then "" else nextLine - _ -> nextLine ++ "\n" ++ scanned1 - in - (scanned2,rest2) - else - ([],str) - - extractLeadingSpaces :: String -> (String,String) - extractLeadingSpaces [] = ([],[]) - extractLeadingSpaces (s@(c:cs)) - | isSpace c = - let - (spaces1,cs1) = extractLeadingSpaces cs - in - (c:spaces1,cs1) - | otherwise = ([],s) - - extractNextLine :: String -> (String,String) - extractNextLine [] = ([],[]) - extractNextLine (c:cs) - | c == '\n' = - ([],cs) - | otherwise = - let - (line,rest) = extractNextLine cs - in - (c:line,rest) - - -- comparison is case-insensitive. - extractPrefix :: String -> String -> Maybe String - extractPrefix [] s = Just s - extractPrefix _ [] = Nothing - extractPrefix (c1:cs1) (c2:cs2) - | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | otherwise = Nothing diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs deleted file mode 100644 --- a/src/Haddock/Interface/Rename.hs +++ /dev/null @@ -1,506 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : Haddock.Interface.Rename --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Interface.Rename (renameInterface) where - - -import Data.Traversable (traverse) - -import Haddock.GhcUtils -import Haddock.Types - -import Bag (emptyBag) -import GHC hiding (NoLink) -import Name - -import Control.Applicative -import Control.Monad hiding (mapM) -import Data.List -import qualified Data.Map as Map hiding ( Map ) -import Data.Traversable (mapM) -import Prelude hiding (mapM) - - -renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface dflags renamingEnv warnings iface = - - -- first create the local env, where every name exported by this module - -- is mapped to itself, and everything else comes from the global renaming - -- env - let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) - where fn env name = Map.insert name (ifaceMod iface) env - - -- rename names in the exported declarations to point to things that - -- are closer to, or maybe even exported by, the current module. - (renamedExportItems, missingNames1) - = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - - (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) - - (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) - - (finalModuleDoc, missingNames4) - = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) - - -- combine the missing names and filter out the built-ins, which would - -- otherwise allways be missing. - missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much - (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) - - -- filter out certain built in type constructors using their string - -- representation. TODO: use the Name constants from the GHC API. --- strings = filter (`notElem` ["()", "[]", "(->)"]) --- (map pretty missingNames) - strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames - - in do - -- report things that we couldn't link to. Only do this for non-hidden - -- modules. - unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ - tell ["Warning: " ++ moduleString (ifaceMod iface) ++ - ": could not find link destinations for:\n"++ - unwords (" " : strings) ] - - return $ iface { ifaceRnDoc = finalModuleDoc, - ifaceRnDocMap = rnDocMap, - ifaceRnArgMap = rnArgMap, - ifaceRnExportItems = renamedExportItems } - - --------------------------------------------------------------------------------- --- Monad for renaming --- --- The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. --------------------------------------------------------------------------------- - - -newtype RnM a = - RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function - -> (a,[Name]) - } - -instance Monad RnM where - (>>=) = thenRn - return = returnRn - -instance Functor RnM where - fmap f x = do a <- x; return (f a) - -instance Applicative RnM where - pure = return - (<*>) = ap - -returnRn :: a -> RnM a -returnRn a = RnM (const (a,[])) -thenRn :: RnM a -> (a -> RnM b) -> RnM b -m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of - (b,out2) -> (b,out1++out2)) - -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) - -outRn :: Name -> RnM () -outRn name = RnM (const ((),[name])) - -lookupRn :: Name -> RnM DocName -lookupRn name = do - lkp <- getLookupRn - case lkp name of - (False,maps_to) -> do outRn name; return maps_to - (True, maps_to) -> return maps_to - - -runRnFM :: LinkEnv -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp - where - lkp n = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mdl -> (True, Documented n mdl) - - --------------------------------------------------------------------------------- --- Renaming --------------------------------------------------------------------------------- - - -rename :: Name -> RnM DocName -rename = lookupRn - - -renameL :: Located Name -> RnM (Located DocName) -renameL = mapM rename - - -renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] -renameExportItems = mapM renameExportItem - - -renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) -renameDocForDecl (doc, fnArgsDoc) = - (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc - - -renameDocumentation :: Documentation Name -> RnM (Documentation DocName) -renameDocumentation (Documentation mDoc mWarning) = - Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning - - -renameLDocHsSyn :: LHsDocString -> RnM LHsDocString -renameLDocHsSyn = return - - -renameDoc :: Doc Name -> RnM (Doc DocName) -renameDoc = traverse rename - - -renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) -renameFnArgsDoc = mapM renameDoc - - -renameLType :: LHsType Name -> RnM (LHsType DocName) -renameLType = mapM renameType - -renameLKind :: LHsKind Name -> RnM (LHsKind DocName) -renameLKind = renameLType - -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) -renameMaybeLKind = traverse renameLKind - -renameType :: HsType Name -> RnM (HsType DocName) -renameType t = case t of - HsForAllTy expl tyvars lcontext ltype -> do - tyvars' <- renameLTyVarBndrs tyvars - lcontext' <- renameLContext lcontext - ltype' <- renameLType ltype - return (HsForAllTy expl tyvars' lcontext' ltype') - - HsTyVar n -> return . HsTyVar =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype - - HsAppTy a b -> do - a' <- renameLType a - b' <- renameLType b - return (HsAppTy a' b') - - HsFunTy a b -> do - a' <- renameLType a - b' <- renameLType b - return (HsFunTy a' b') - - HsListTy ty -> return . HsListTy =<< renameLType ty - HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) - HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) - - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - - HsOpTy a (w, L loc op) b -> do - op' <- rename op - a' <- renameLType a - b' <- renameLType b - return (HsOpTy a' (w, L loc op') b') - - HsParTy ty -> return . HsParTy =<< renameLType ty - - HsKindSig ty k -> do - ty' <- renameLType ty - k' <- renameLKind k - return (HsKindSig ty' k') - - HsDocTy ty doc -> do - ty' <- renameLType ty - doc' <- renameLDocHsSyn doc - return (HsDocTy ty' doc') - - HsTyLit x -> return (HsTyLit x) - - HsWrapTy a b -> HsWrapTy a <$> renameType b - HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a - HsCoreTy a -> pure (HsCoreTy a) - HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b - HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - -renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) -renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c - -renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) -renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) - = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } - -- This is rather bogus, but I'm not sure what else to do - -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) - = do { n' <- rename n - ; return (L loc (UserTyVar n')) } -renameLTyVarBndr (L loc (KindedTyVar n kind)) - = do { n' <- rename n - ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar n' kind')) } - -renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) -renameLContext (L loc context) = do - context' <- mapM renameLType context - return (L loc context') - - -renameInstHead :: InstHead Name -> RnM (InstHead DocName) -renameInstHead (className, k, types, rest) = do - className' <- rename className - k' <- mapM renameType k - types' <- mapM renameType types - rest' <- case rest of - ClassInst cs -> ClassInst <$> mapM renameType cs - TypeInst ts -> TypeInst <$> traverse renameType ts - DataInst dd -> DataInst <$> renameTyClD dd - return (className', k', types', rest') - - -renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) -renameLDecl (L loc d) = return . L loc =<< renameDecl d - - -renameDecl :: HsDecl Name -> RnM (HsDecl DocName) -renameDecl decl = case decl of - TyClD d -> do - d' <- renameTyClD d - return (TyClD d') - SigD s -> do - s' <- renameSig s - return (SigD s') - ForD d -> do - d' <- renameForD d - return (ForD d') - InstD d -> do - d' <- renameInstD d - return (InstD d') - _ -> error "renameDecl" - -renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) -renameLThing fn (L loc x) = return . L loc =<< fn x - -renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) -renameTyClD d = case d of - ForeignType lname b -> do - lname' <- renameL lname - return (ForeignType lname' b) - --- TyFamily flav lname ltyvars kind tckind -> do - FamDecl { tcdFam = decl } -> do - decl' <- renameFamilyDecl decl - return (FamDecl { tcdFam = decl' }) - - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do - lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars - rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs }) - - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do - lname' <- renameL lname - tyvars' <- renameLTyVarBndrs tyvars - defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs }) - - ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars - , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do - lcontext' <- renameLContext lcontext - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - lfundeps' <- mapM renameLFunDep lfundeps - lsigs' <- mapM renameLSig lsigs - ats' <- mapM (renameLThing renameFamilyDecl) ats - at_defs' <- mapM (mapM renameTyFamInstD) at_defs - -- we don't need the default methods or the already collected doc entities - return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' - , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) - - where - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - -renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) -renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname - , fdTyVars = ltyvars, fdKindSig = tckind }) = do - info' <- renameFamilyInfo info - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - tckind' <- renameMaybeLKind tckind - return (FamilyDecl { fdInfo = info', fdLName = lname' - , fdTyVars = ltyvars', fdKindSig = tckind' }) - -renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) -renameFamilyInfo DataFamily = return DataFamily -renameFamilyInfo OpenTypeFamily = return OpenTypeFamily -renameFamilyInfo (ClosedTypeFamily eqns) - = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns - ; return $ ClosedTypeFamily eqns' } - -renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) -renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType - , dd_kindSig = k, dd_cons = cons }) = do - lcontext' <- renameLContext lcontext - k' <- renameMaybeLKind k - cons' <- mapM (mapM renameCon) cons - -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType - , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) - -renameCon :: ConDecl Name -> RnM (ConDecl DocName) -renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do - lname' <- renameL lname - ltyvars' <- renameLTyVarBndrs ltyvars - lcontext' <- renameLContext lcontext - details' <- renameDetails details - restype' <- renameResType restype - mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_res = restype', con_doc = mbldoc' }) - where - renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') - - renameResType (ResTyH98) = return ResTyH98 - renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - - -renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) -renameConDeclFieldField (ConDeclField name t doc) = do - name' <- renameL name - t' <- renameLType t - doc' <- mapM renameLDocHsSyn doc - return (ConDeclField name' t' doc') - - -renameSig :: Sig Name -> RnM (Sig DocName) -renameSig sig = case sig of - TypeSig lnames ltype -> do - lnames' <- mapM renameL lnames - ltype' <- renameLType ltype - return (TypeSig lnames' ltype') - PatSynSig lname args ltype lreq lprov -> do - lname' <- renameL lname - args' <- case args of - PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs - InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright - ltype' <- renameLType ltype - lreq' <- renameLContext lreq - lprov' <- renameLContext lprov - return $ PatSynSig lname' args' ltype' lreq' lprov' - FixSig (FixitySig lname fixity) -> do - lname' <- renameL lname - return $ FixSig (FixitySig lname' fixity) - MinimalSig s -> MinimalSig <$> traverse renameL s - -- we have filtered out all other kinds of signatures in Interface.Create - _ -> error "expected TypeSig" - - -renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) -renameForD (ForeignImport lname ltype co x) = do - lname' <- renameL lname - ltype' <- renameLType ltype - return (ForeignImport lname' ltype' co x) -renameForD (ForeignExport lname ltype co x) = do - lname' <- renameL lname - ltype' <- renameLType ltype - return (ForeignExport lname' ltype' co x) - - -renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (ClsInstD { cid_inst = d }) = do - d' <- renameClsInstD d - return (ClsInstD { cid_inst = d' }) -renameInstD (TyFamInstD { tfid_inst = d }) = do - d' <- renameTyFamInstD d - return (TyFamInstD { tfid_inst = d' }) -renameInstD (DataFamInstD { dfid_inst = d }) = do - d' <- renameDataFamInstD d - return (DataFamInstD { dfid_inst = d' }) - -renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName) -renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do - ltype' <- renameLType ltype - lATs' <- mapM (mapM renameTyFamInstD) lATs - lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] - , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) - - -renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) -renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) - = do { eqn' <- renameLThing renameTyFamInstEqn eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' - , tfid_fvs = placeHolderNames }) } - -renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName) -renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs }) - = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) - ; rhs' <- renameLType rhs - ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' } - , tfie_rhs = rhs' }) } - -renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) -renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) - = do { tc' <- renameL tc - ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) - ; defn' <- renameDataDefn defn - ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' } - , dfid_defn = defn', dfid_fvs = placeHolderNames }) } - -renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) -renameExportItem item = case item of - ExportModule mdl -> return (ExportModule mdl) - ExportGroup lev id_ doc -> do - doc' <- renameDoc doc - return (ExportGroup lev id_ doc') - ExportDecl decl doc subs instances fixities splice -> do - decl' <- renameLDecl decl - doc' <- renameDocForDecl doc - subs' <- mapM renameSub subs - instances' <- forM instances $ \(inst, idoc) -> do - inst' <- renameInstHead inst - idoc' <- mapM renameDoc idoc - return (inst', idoc') - fixities' <- forM fixities $ \(name, fixity) -> do - name' <- lookupRn name - return (name', fixity) - return (ExportDecl decl' doc' subs' instances' fixities' splice) - ExportNoDecl x subs -> do - x' <- lookupRn x - subs' <- mapM lookupRn subs - return (ExportNoDecl x' subs') - ExportDoc doc -> do - doc' <- renameDoc doc - return (ExportDoc doc') - - -renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) -renameSub (n,doc) = do - n' <- rename n - doc' <- renameDocForDecl doc - return (n', doc') diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs deleted file mode 100644 --- a/src/Haddock/InterfaceFile.hs +++ /dev/null @@ -1,636 +0,0 @@ -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.InterfaceFile --- Copyright : (c) David Waern 2006-2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Reading and writing the .haddock interface file ------------------------------------------------------------------------------ -module Haddock.InterfaceFile ( - InterfaceFile(..), ifPackageId, - readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, - writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility -) where - - -import Haddock.Types -import Haddock.Utils hiding (out) - -import Control.Monad -import Data.Array -import Data.Functor ((<$>)) -import Data.IORef -import Data.List -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Word - -import BinIface (getSymtabName, getDictFastString) -import Binary -import FastMutInt -import FastString -import GHC hiding (NoLink) -import GhcMonad (withSession) -import HscTypes -import IfaceEnv -import Name -import UniqFM -import UniqSupply -import Unique - - -data InterfaceFile = InterfaceFile { - ifLinkEnv :: LinkEnv, - ifInstalledIfaces :: [InstalledInterface] -} - - -ifPackageId :: InterfaceFile -> PackageId -ifPackageId if_ = - case ifInstalledIfaces if_ of - [] -> error "empty InterfaceFile" - iface:_ -> modulePackageId $ instMod iface - - -binaryInterfaceMagic :: Word32 -binaryInterfaceMagic = 0xD0Cface - - --- IMPORTANT: Since datatypes in the GHC API might change between major --- versions, and because we store GHC datatypes in our interface files, we need --- to make sure we version our interface files accordingly. --- --- If you change the interface file format or adapt Haddock to work with a new --- major version of GHC (so that the format changes indirectly) *you* need to --- follow these steps: --- --- (1) increase `binaryInterfaceVersion` --- --- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] --- -binaryInterfaceVersion :: Word16 -#if __GLASGOW_HASKELL__ == 708 -binaryInterfaceVersion = 25 - -binaryInterfaceVersionCompatibility :: [Word16] -binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] -#else -#error Unsupported GHC version -#endif - - -initBinMemSize :: Int -initBinMemSize = 1024*1024 - - -writeInterfaceFile :: FilePath -> InterfaceFile -> IO () -writeInterfaceFile filename iface = do - bh0 <- openBinMem initBinMemSize - put_ bh0 binaryInterfaceMagic - put_ bh0 binaryInterfaceVersion - - -- remember where the dictionary pointer will go - dict_p_p <- tellBin bh0 - put_ bh0 dict_p_p - - -- remember where the symbol table pointer will go - symtab_p_p <- tellBin bh0 - put_ bh0 symtab_p_p - - -- Make some intial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let bin_symtab = BinSymbolTable { - bin_symtab_next = symtab_next, - bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } - - -- put the main thing - let bh = setUserData bh0 $ newWriteState (putName bin_symtab) - (putFastString bin_dict) - put_ bh iface - - -- write the symtab pointer at the front of the file - symtab_p <- tellBin bh - putAt bh symtab_p_p symtab_p - seekBin bh symtab_p - - -- write the symbol table itself - symtab_next' <- readFastMutInt symtab_next - symtab_map' <- readIORef symtab_map - putSymbolTable bh symtab_next' symtab_map' - - -- write the dictionary pointer at the fornt of the file - dict_p <- tellBin bh - putAt bh dict_p_p dict_p - seekBin bh dict_p - - -- write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - - -- and send the result to the file - writeBinMem bh filename - return () - - -type NameCacheAccessor m = (m NameCache, NameCache -> m ()) - - -nameCacheFromGhc :: NameCacheAccessor Ghc -nameCacheFromGhc = ( read_from_session , write_to_session ) - where - read_from_session = do - ref <- withSession (return . hsc_NC) - liftIO $ readIORef ref - write_to_session nc' = do - ref <- withSession (return . hsc_NC) - liftIO $ writeIORef ref nc' - - -freshNameCache :: NameCacheAccessor IO -freshNameCache = ( create_fresh_nc , \_ -> return () ) - where - create_fresh_nc = do - u <- mkSplitUniqSupply 'a' -- ?? - return (initNameCache u []) - - --- | Read a Haddock (@.haddock@) interface file. Return either an --- 'InterfaceFile' or an error message. --- --- This function can be called in two ways. Within a GHC session it will --- update the use and update the session's name cache. Outside a GHC session --- a new empty name cache is used. The function is therefore generic in the --- monad being used. The exact monad is whichever monad the first --- argument, the getter and setter of the name cache, requires. --- -readInterfaceFile :: forall m. - MonadIO m - => NameCacheAccessor m - -> FilePath - -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do - bh0 <- liftIO $ readBinMem filename - - magic <- liftIO $ get bh0 - version <- liftIO $ get bh0 - - case () of - _ | magic /= binaryInterfaceMagic -> return . Left $ - "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ - "Interface file is of wrong version: " ++ filename - | otherwise -> with_name_cache $ \update_nc -> do - - dict <- get_dictionary bh0 - - -- read the symbol table so we are capable of reading the actual data - bh1 <- do - let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab <- update_nc (get_symbol_table bh1) - return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) - (getDictFastString dict) - - -- load the actual data - iface <- liftIO $ get bh1 - return (Right iface) - where - with_name_cache :: forall a. - ((forall n b. MonadIO n - => (NameCache -> n (NameCache, b)) - -> n b) - -> m a) - -> m a - with_name_cache act = do - nc_var <- get_name_cache >>= (liftIO . newIORef) - x <- act $ \f -> do - nc <- liftIO $ readIORef nc_var - (nc', x) <- f nc - liftIO $ writeIORef nc_var nc' - return x - liftIO (readIORef nc_var) >>= set_name_cache - return x - - get_dictionary bin_handle = liftIO $ do - dict_p <- get bin_handle - data_p <- tellBin bin_handle - seekBin bin_handle dict_p - dict <- getDictionary bin_handle - seekBin bin_handle data_p - return dict - - get_symbol_table bh1 theNC = liftIO $ do - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 theNC - seekBin bh1 data_p' - return (nc', symtab) - - -------------------------------------------------------------------------------- --- * Symbol table -------------------------------------------------------------------------------- - - -putName :: BinSymbolTable -> BinHandle -> Name -> IO () -putName BinSymbolTable{ - bin_symtab_map = symtab_map_ref, - bin_symtab_next = symtab_next } bh name - = do - symtab_map <- readIORef symtab_map_ref - case lookupUFM symtab_map name of - Just (off,_) -> put_ bh (fromIntegral off :: Word32) - Nothing -> do - off <- readFastMutInt symtab_next - writeFastMutInt symtab_next (off+1) - writeIORef symtab_map_ref - $! addToUFM symtab_map name (off,name) - put_ bh (fromIntegral off :: Word32) - - -data BinSymbolTable = BinSymbolTable { - bin_symtab_next :: !FastMutInt, -- The next index to use - bin_symtab_map :: !(IORef (UniqFM (Int,Name))) - -- indexed by Name - } - - -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString BinDictionary { bin_dict_next = j_r, - bin_dict_map = out_r} bh f - = do - out <- readIORef out_r - let unique = getUnique f - case lookupUFM out unique of - Just (j, _) -> put_ bh (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - put_ bh (fromIntegral j :: Word32) - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) - - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM (Int,FastString))) - -- indexed by FastString - } - - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (eltsUFM symtab)) - mapM_ (\n -> serialiseName bh n symtab) names - - -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) -getSymbolTable bh namecache = do - sz <- get bh - od_names <- replicateM sz (get bh) - let arr = listArray (0,sz-1) names - (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names - return (namecache', arr) - - -type OnDiskName = (PackageId, ModuleName, OccName) - - -fromOnDiskName - :: Array Int Name - -> NameCache - -> OnDiskName - -> (NameCache, Name) -fromOnDiskName _ nc (pid, mod_name, occ) = - let - modu = mkModule pid mod_name - cache = nsNames nc - in - case lookupOrigNameCache cache modu occ of - Just name -> (nc, name) - Nothing -> - let - us = nsUniqs nc - u = uniqFromSupply us - name = mkExternalName u modu occ noSrcSpan - new_cache = extendNameCache cache modu occ name - in - case splitUniqSupply us of { (us',_) -> - ( nc{ nsUniqs = us', nsNames = new_cache }, name ) - } - - -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () -serialiseName bh name _ = do - let modu = nameModule name - put_ bh (modulePackageId modu, moduleName modu, nameOccName name) - - -------------------------------------------------------------------------------- --- * GhcBinary instances -------------------------------------------------------------------------------- - - -instance (Ord k, Binary k, Binary v) => Binary (Map k v) where - put_ bh m = put_ bh (Map.toList m) - get bh = fmap (Map.fromList) (get bh) - - -instance Binary InterfaceFile where - put_ bh (InterfaceFile env ifaces) = do - put_ bh env - put_ bh ifaces - - get bh = do - env <- get bh - ifaces <- get bh - return (InterfaceFile env ifaces) - - -instance Binary InstalledInterface where - put_ bh (InstalledInterface modu info docMap argMap - exps visExps opts subMap fixMap) = do - put_ bh modu - put_ bh info - put_ bh docMap - put_ bh argMap - put_ bh exps - put_ bh visExps - put_ bh opts - put_ bh subMap - put_ bh fixMap - - get bh = do - modu <- get bh - info <- get bh - docMap <- get bh - argMap <- get bh - exps <- get bh - visExps <- get bh - opts <- get bh - subMap <- get bh - fixMap <- get bh - - return (InstalledInterface modu info docMap argMap - exps visExps opts subMap fixMap) - - -instance Binary DocOption where - put_ bh OptHide = do - putByte bh 0 - put_ bh OptPrune = do - putByte bh 1 - put_ bh OptIgnoreExports = do - putByte bh 2 - put_ bh OptNotHome = do - putByte bh 3 - put_ bh OptShowExtensions = do - putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> do - return OptHide - 1 -> do - return OptPrune - 2 -> do - return OptIgnoreExports - 3 -> do - return OptNotHome - 4 -> do - return OptShowExtensions - _ -> fail "invalid binary data found" - - -instance Binary Example where - put_ bh (Example expression result) = do - put_ bh expression - put_ bh result - get bh = do - expression <- get bh - result <- get bh - return (Example expression result) - -instance Binary Hyperlink where - put_ bh (Hyperlink url label) = do - put_ bh url - put_ bh label - get bh = do - url <- get bh - label <- get bh - return (Hyperlink url label) - -instance Binary Picture where - put_ bh (Picture uri title) = do - put_ bh uri - put_ bh title - get bh = do - uri <- get bh - title <- get bh - return (Picture uri title) - -instance Binary a => Binary (Header a) where - put_ bh (Header l t) = do - put_ bh l - put_ bh t - get bh = do - l <- get bh - t <- get bh - return (Header l t) - -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance (Binary id) => Binary (Doc id) where - put_ bh DocEmpty = do - putByte bh 0 - put_ bh (DocAppend aa ab) = do - putByte bh 1 - put_ bh aa - put_ bh ab - put_ bh (DocString ac) = do - putByte bh 2 - put_ bh ac - put_ bh (DocParagraph ad) = do - putByte bh 3 - put_ bh ad - put_ bh (DocIdentifier ae) = do - putByte bh 4 - put_ bh ae - put_ bh (DocModule af) = do - putByte bh 5 - put_ bh af - put_ bh (DocEmphasis ag) = do - putByte bh 6 - put_ bh ag - put_ bh (DocMonospaced ah) = do - putByte bh 7 - put_ bh ah - put_ bh (DocUnorderedList ai) = do - putByte bh 8 - put_ bh ai - put_ bh (DocOrderedList aj) = do - putByte bh 9 - put_ bh aj - put_ bh (DocDefList ak) = do - putByte bh 10 - put_ bh ak - put_ bh (DocCodeBlock al) = do - putByte bh 11 - put_ bh al - put_ bh (DocHyperlink am) = do - putByte bh 12 - put_ bh am - put_ bh (DocPic x) = do - putByte bh 13 - put_ bh x - put_ bh (DocAName an) = do - putByte bh 14 - put_ bh an - put_ bh (DocExamples ao) = do - putByte bh 15 - put_ bh ao - put_ bh (DocIdentifierUnchecked x) = do - putByte bh 16 - put_ bh x - put_ bh (DocWarning ag) = do - putByte bh 17 - put_ bh ag - put_ bh (DocProperty x) = do - putByte bh 18 - put_ bh x - put_ bh (DocBold x) = do - putByte bh 19 - put_ bh x - put_ bh (DocHeader aa) = do - putByte bh 20 - put_ bh aa - - get bh = do - h <- getByte bh - case h of - 0 -> do - return DocEmpty - 1 -> do - aa <- get bh - ab <- get bh - return (DocAppend aa ab) - 2 -> do - ac <- get bh - return (DocString ac) - 3 -> do - ad <- get bh - return (DocParagraph ad) - 4 -> do - ae <- get bh - return (DocIdentifier ae) - 5 -> do - af <- get bh - return (DocModule af) - 6 -> do - ag <- get bh - return (DocEmphasis ag) - 7 -> do - ah <- get bh - return (DocMonospaced ah) - 8 -> do - ai <- get bh - return (DocUnorderedList ai) - 9 -> do - aj <- get bh - return (DocOrderedList aj) - 10 -> do - ak <- get bh - return (DocDefList ak) - 11 -> do - al <- get bh - return (DocCodeBlock al) - 12 -> do - am <- get bh - return (DocHyperlink am) - 13 -> do - x <- get bh - return (DocPic x) - 14 -> do - an <- get bh - return (DocAName an) - 15 -> do - ao <- get bh - return (DocExamples ao) - 16 -> do - x <- get bh - return (DocIdentifierUnchecked x) - 17 -> do - ag <- get bh - return (DocWarning ag) - 18 -> do - x <- get bh - return (DocProperty x) - 19 -> do - x <- get bh - return (DocBold x) - 20 -> do - aa <- get bh - return (DocHeader aa) - _ -> error "invalid binary data found in the interface file" - - -instance Binary name => Binary (HaddockModInfo name) where - put_ bh hmi = do - put_ bh (hmi_description hmi) - put_ bh (hmi_copyright hmi) - put_ bh (hmi_license hmi) - put_ bh (hmi_maintainer hmi) - put_ bh (hmi_stability hmi) - put_ bh (hmi_portability hmi) - put_ bh (hmi_safety hmi) - put_ bh (fromEnum <$> hmi_language hmi) - put_ bh (map fromEnum $ hmi_extensions hmi) - - get bh = do - descr <- get bh - copyr <- get bh - licen <- get bh - maint <- get bh - stabi <- get bh - porta <- get bh - safet <- get bh - langu <- fmap toEnum <$> get bh - exten <- map toEnum <$> get bh - return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten) - -instance Binary DocName where - put_ bh (Documented name modu) = do - putByte bh 0 - put_ bh name - put_ bh modu - put_ bh (Undocumented name) = do - putByte bh 1 - put_ bh name - - get bh = do - h <- getByte bh - case h of - 0 -> do - name <- get bh - modu <- get bh - return (Documented name modu) - 1 -> do - name <- get bh - return (Undocumented name) - _ -> error "get DocName: Bad h" diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs deleted file mode 100644 --- a/src/Haddock/ModuleTree.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.ModuleTree --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where - - -import Haddock.Types ( Doc ) - -import GHC ( Name ) -import Module ( Module, moduleNameString, moduleName, modulePackageId, - packageIdString ) - - -data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] - - -mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] -mkModuleTree showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] - where - modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) - | otherwise = Nothing - fn (mod_,pkg,short) = addToTrees mod_ pkg short - - -addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ ts = ts -addToTrees ss pkg short [] = mkSubTree ss pkg short -addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts - where - this_pkg = if null ss then pkg else node_pkg - this_short = if null ss then short else node_short - - -mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -mkSubTree [] _ _ = [] -mkSubTree [s] pkg short = [Node s True pkg short []] -mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)] - - -splitModule :: Module -> [String] -splitModule mdl = split (moduleNameString (moduleName mdl)) - where split mod0 = case break (== '.') mod0 of - (s1, '.':s2) -> s1 : split s2 - (s1, _) -> [s1] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs deleted file mode 100644 --- a/src/Haddock/Options.hs +++ /dev/null @@ -1,287 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Options --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable --- --- Definition of the command line interface of Haddock. ------------------------------------------------------------------------------ -module Haddock.Options ( - parseHaddockOpts, - Flag(..), - getUsage, - optTitle, - outputDir, - optContentsUrl, - optIndexUrl, - optCssFile, - sourceUrls, - wikiUrls, - optDumpInterfaceFile, - optLaTeXStyle, - qualification, - verbosity, - ghcFlags, - readIfaceArgs -) where - - -import Distribution.Verbosity -import Haddock.Utils -import Haddock.Types -import System.Console.GetOpt -import qualified Data.Char as Char - - -data Flag - = Flag_BuiltInThemes - | Flag_CSS String --- | Flag_DocBook - | Flag_ReadInterface String - | Flag_DumpInterface String - | Flag_Heading String - | Flag_Html - | Flag_Hoogle - | Flag_Lib String - | Flag_OutputDir FilePath - | Flag_Prologue FilePath - | Flag_SourceBaseURL String - | Flag_SourceModuleURL String - | Flag_SourceEntityURL String - | Flag_SourceLEntityURL String - | Flag_WikiBaseURL String - | Flag_WikiModuleURL String - | Flag_WikiEntityURL String - | Flag_LaTeX - | Flag_LaTeXStyle String - | Flag_Help - | Flag_Verbosity String - | Flag_Version - | Flag_CompatibleInterfaceVersions - | Flag_InterfaceVersion - | Flag_UseContents String - | Flag_GenContents - | Flag_UseIndex String - | Flag_GenIndex - | Flag_IgnoreAllExports - | Flag_HideModule String - | Flag_ShowExtensions String - | Flag_OptGhc String - | Flag_GhcLibDir String - | Flag_GhcVersion - | Flag_PrintGhcPath - | Flag_PrintGhcLibDir - | Flag_NoWarnings - | Flag_UseUnicode - | Flag_NoTmpCompDir - | Flag_Qualification String - | Flag_PrettyHtml - | Flag_PrintMissingDocs - deriving (Eq) - - -options :: Bool -> [OptDescr Flag] -options backwardsCompat = - [ - Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR") - "path to a GHC lib dir, to override the default path", - Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") - "directory in which to put the output files", - Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") - "location of Haddock's auxiliary files", - Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") - "read an interface from FILE", - Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") - "write the resulting interface to FILE", --- Option ['S'] ["docbook"] (NoArg Flag_DocBook) --- "output in DocBook XML", - Option ['h'] ["html"] (NoArg Flag_Html) - "output in HTML (XHTML 1.0)", - Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", - Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", - Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", - Option [] ["hoogle"] (NoArg Flag_Hoogle) - "output for Hoogle", - Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") - "URL for a source code link on the contents\nand index pages", - Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"]) - (ReqArg Flag_SourceModuleURL "URL") - "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)", - Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL") - "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", - Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL") - "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", - Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") - "URL for a comments link on the contents\nand index pages", - Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") - "URL for a comments link for each module\n(using the %{MODULE} var)", - Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") - "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", - Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH") - "the CSS file or theme directory to use for HTML output", - Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes) - "include all the built-in haddock themes", - Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE") - "file containing prologue text", - Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") - "page heading", - Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL") - "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'", - Option ['?'] ["help"] (NoArg Flag_Help) - "display this help and exit", - Option ['V'] ["version"] (NoArg Flag_Version) - "output version information and exit", - Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions) - "output compatible interface file versions and exit", - Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) - "output interface file version and exit", - Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") - "set verbosity level", - Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") - "use a separately-generated HTML contents page", - Option [] ["gen-contents"] (NoArg Flag_GenContents) - "generate an HTML contents from specified\ninterfaces", - Option [] ["use-index"] (ReqArg Flag_UseIndex "URL") - "use a separately-generated HTML index", - Option [] ["gen-index"] (NoArg Flag_GenIndex) - "generate an HTML index from specified\ninterfaces", - Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", - Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") - "behave as if MODULE has the hide attribute", - Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE") - "behave as if MODULE has the show-extensions attribute", - Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") - "option to be forwarded to GHC", - Option [] ["ghc-version"] (NoArg Flag_GhcVersion) - "output GHC version in numeric format", - Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath) - "output path to GHC binary", - Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) - "output GHC lib dir", - Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", - Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir) - "do not re-direct compilation output to a temporary directory", - Option [] ["pretty-html"] (NoArg Flag_PrettyHtml) - "generate html with newlines and indenting (for use with --html)", - Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs) - "print information about any undocumented entities" - ] - - -getUsage :: IO String -getUsage = do - prog <- getProgramName - return $ usageInfo (usageHeader prog) (options False) - where - usageHeader :: String -> String - usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" - - -parseHaddockOpts :: [String] -> IO ([Flag], [String]) -parseHaddockOpts params = - case getOpt Permute (options True) params of - (flags, args, []) -> return (flags, args) - (_, _, errors) -> do - usage <- getUsage - throwE (concat errors ++ usage) - - -optTitle :: [Flag] -> Maybe String -optTitle flags = - case [str | Flag_Heading str <- flags] of - [] -> Nothing - (t:_) -> Just t - - -outputDir :: [Flag] -> FilePath -outputDir flags = - case [ path | Flag_OutputDir path <- flags ] of - [] -> "." - paths -> last paths - - -optContentsUrl :: [Flag] -> Maybe String -optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ] - - -optIndexUrl :: [Flag] -> Maybe String -optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] - - -optCssFile :: [Flag] -> Maybe FilePath -optCssFile flags = optLast [ str | Flag_CSS str <- flags ] - - -sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) -sourceUrls flags = - (optLast [str | Flag_SourceBaseURL str <- flags] - ,optLast [str | Flag_SourceModuleURL str <- flags] - ,optLast [str | Flag_SourceEntityURL str <- flags] - ,optLast [str | Flag_SourceLEntityURL str <- flags]) - - -wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String) -wikiUrls flags = - (optLast [str | Flag_WikiBaseURL str <- flags] - ,optLast [str | Flag_WikiModuleURL str <- flags] - ,optLast [str | Flag_WikiEntityURL str <- flags]) - - -optDumpInterfaceFile :: [Flag] -> Maybe FilePath -optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] - - -optLaTeXStyle :: [Flag] -> Maybe String -optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] - - -qualification :: [Flag] -> Either String QualOption -qualification flags = - case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - [] -> Right OptNoQual - ["none"] -> Right OptNoQual - ["full"] -> Right OptFullQual - ["local"] -> Right OptLocalQual - ["relative"] -> Right OptRelativeQual - ["aliased"] -> Right OptAliasedQual - [arg] -> Left $ "unknown qualification type " ++ show arg - _:_ -> Left "qualification option given multiple times" - - -verbosity :: [Flag] -> Verbosity -verbosity flags = - case [ str | Flag_Verbosity str <- flags ] of - [] -> normal - x:_ -> case parseVerbosity x of - Left e -> throwE e - Right v -> v - - -ghcFlags :: [Flag] -> [String] -ghcFlags flags = [ option | Flag_OptGhc option <- flags ] - - -readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] -readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] - where - parseIfaceOption :: String -> (DocPaths, FilePath) - parseIfaceOption str = - case break (==',') str of - (fpath, ',':rest) -> - case break (==',') rest of - (src, ',':file) -> ((fpath, Just src), file) - (file, _) -> ((fpath, Nothing), file) - (file, _) -> (("", Nothing), file) - - --- | Like 'listToMaybe' but returns the last element instead of the first. -optLast :: [a] -> Maybe a -optLast [] = Nothing -optLast xs = Just (last xs) diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs deleted file mode 100644 --- a/src/Haddock/Parser.hs +++ /dev/null @@ -1,487 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving - , FlexibleInstances, UndecidableInstances - , IncoherentInstances #-} -{-# LANGUAGE LambdaCase #-} --- | --- Module : Haddock.Parser --- Copyright : (c) Mateusz Kowalczyk 2013, --- Simon Hengel 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable - -module Haddock.Parser (parseString, parseParas, parseStringMaybe, parseParasMaybe) where - -import Prelude hiding (takeWhile) -import Control.Arrow (first) -import Control.Monad (void, mfilter) -import Control.Applicative -import Data.Attoparsec.ByteString.Char8 hiding (parse, take, endOfLine) -import qualified Data.ByteString.Char8 as BS -import Data.Char (chr, isAsciiUpper) -import Data.List (stripPrefix, intercalate, unfoldr) -import Data.Maybe (fromMaybe) -import Data.Monoid -import DynFlags -import FastString (mkFastString) -import Haddock.Doc -import Haddock.Types -import Lexer (mkPState, unP, ParseResult(POk)) -import Parser (parseIdentifier) -import RdrName -import SrcLoc (mkRealSrcLoc, unLoc) -import StringBuffer (stringToStringBuffer) -import Haddock.Utf8 -import Haddock.Parser.Util - -{-# DEPRECATED parseParasMaybe "use `parseParas` instead" #-} -parseParasMaybe :: DynFlags -> String -> Maybe (Doc RdrName) -parseParasMaybe d = Just . parseParas d - -{-# DEPRECATED parseStringMaybe "use `parseString` instead" #-} -parseStringMaybe :: DynFlags -> String -> Maybe (Doc RdrName) -parseStringMaybe d = Just . parseString d - -parse :: Parser a -> BS.ByteString -> a -parse p = either err id . parseOnly (p <* endOfInput) - where - err = error . ("Haddock.Parser.parse: " ++) - --- | Main entry point to the parser. Appends the newline character --- to the input string. -parseParas :: DynFlags - -> String -- ^ String to parse - -> Doc RdrName -parseParas d = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") - where - p :: Parser (Doc RdrName) - p = mconcat <$> paragraph d `sepBy` many (skipHorizontalSpace *> "\n") - --- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which --- drops leading whitespace and encodes the string to UTF8 first. -parseString :: DynFlags -> String -> Doc RdrName -parseString d = parseStringBS d . encodeUtf8 . dropWhile isSpace - -parseStringBS :: DynFlags -> BS.ByteString -> Doc RdrName -parseStringBS d = parse p - where - p :: Parser (Doc RdrName) - p = mconcat <$> many (monospace d <|> anchor <|> identifier d - <|> moduleName <|> picture <|> hyperlink <|> autoUrl <|> bold d - <|> emphasis d <|> encodedChar <|> string' <|> skipSpecialChar) - --- | Parses and processes --- --- --- >>> parseOnly encodedChar "ABC" --- Right (DocString "ABC") -encodedChar :: Parser (Doc a) -encodedChar = "&#" *> c <* ";" - where - c = DocString . return . chr <$> num - num = hex <|> decimal - hex = ("x" <|> "X") *> hexadecimal - --- | List of characters that we use to delimit any special markup. --- Once we have checked for any of these and tried to parse the --- relevant markup, we can assume they are used as regular text. -specialChar :: [Char] -specialChar = "_/<@\"&'`#" - --- | Plain, regular parser for text. Called as one of the last parsers --- to ensure that we have already given a chance to more meaningful parsers --- before capturing their characers. -string' :: Parser (Doc a) -string' = DocString . unescape . decodeUtf8 <$> takeWhile1_ (`notElem` specialChar) - where - unescape "" = "" - unescape ('\\':x:xs) = x : unescape xs - unescape (x:xs) = x : unescape xs - --- | Skips a single special character and treats it as a plain string. --- This is done to skip over any special characters belonging to other --- elements but which were not deemed meaningful at their positions. -skipSpecialChar :: Parser (Doc a) -skipSpecialChar = DocString . return <$> satisfy (`elem` specialChar) - --- | Emphasis parser. --- --- >>> parseOnly emphasis "/Hello world/" --- Right (DocEmphasis (DocString "Hello world")) -emphasis :: DynFlags -> Parser (Doc RdrName) -emphasis d = DocEmphasis . parseStringBS d <$> - mfilter ('\n' `BS.notElem`) ("/" *> takeWhile1_ (/= '/') <* "/") - --- | Bold parser. --- --- >>> parseOnly bold "__Hello world__" --- Right (DocBold (DocString "Hello world")) -bold :: DynFlags -> Parser (Doc RdrName) -bold d = DocBold . parseStringBS d <$> disallowNewline ("__" *> takeUntil "__") - -disallowNewline :: Parser BS.ByteString -> Parser BS.ByteString -disallowNewline = mfilter ('\n' `BS.notElem`) - --- | Like `takeWhile`, but unconditionally take escaped characters. -takeWhile_ :: (Char -> Bool) -> Parser BS.ByteString -takeWhile_ p = scan False p_ - where - p_ escaped c - | escaped = Just False - | not $ p c = Nothing - | otherwise = Just (c == '\\') - --- | Like `takeWhile1`, but unconditionally take escaped characters. -takeWhile1_ :: (Char -> Bool) -> Parser BS.ByteString -takeWhile1_ = mfilter (not . BS.null) . takeWhile_ - --- | Text anchors to allow for jumping around the generated documentation. --- --- >>> parseOnly anchor "#Hello world#" --- Right (DocAName "Hello world") -anchor :: Parser (Doc a) -anchor = DocAName . decodeUtf8 <$> - disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#") - --- | Monospaced strings. --- --- >>> parseOnly (monospace dynflags) "@cruel@" --- Right (DocMonospaced (DocString "cruel")) -monospace :: DynFlags -> Parser (Doc RdrName) -monospace d = DocMonospaced . parseStringBS d <$> ("@" *> takeWhile1_ (/= '@') <* "@") - -moduleName :: Parser (Doc a) -moduleName = DocModule <$> (char '"' *> modid <* char '"') - where - modid = intercalate "." <$> conid `sepBy1` "." - conid = (:) - <$> satisfy isAsciiUpper - -- NOTE: According to Haskell 2010 we shouldd actually only - -- accept {small | large | digit | ' } here. But as we can't - -- match on unicode characters, this is currently not possible. - -- Note that we allow ‘#’ to suport anchors. - <*> (decodeUtf8 <$> takeWhile (`notElem` " .&[{}(=*)+]!|@/;,^?\"\n")) - --- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify --- a title for the picture. --- --- >>> parseOnly picture "<>" --- Right (DocPic (Picture "hello.png" Nothing)) --- >>> parseOnly picture "<>" --- Right (DocPic (Picture "hello.png" (Just "world"))) -picture :: Parser (Doc a) -picture = DocPic . makeLabeled Picture . decodeUtf8 - <$> disallowNewline ("<<" *> takeUntil ">>") - --- | Paragraph parser, called by 'parseParas'. -paragraph :: DynFlags -> Parser (Doc RdrName) -paragraph d = examples <|> skipSpace *> (list d <|> birdtracks <|> codeblock d - <|> property <|> header d - <|> textParagraph d) - -header :: DynFlags -> Parser (Doc RdrName) -header d = do - let psers = map (string . encodeUtf8 . concat . flip replicate "=") [6, 5 .. 1] - pser = foldl1 (<|>) psers - delim <- decodeUtf8 <$> pser - line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString d - rest <- paragraph d <|> return mempty - return $ docAppend (DocParagraph (DocHeader (Header (length delim) line))) rest - -textParagraph :: DynFlags -> Parser (Doc RdrName) -textParagraph d = docParagraph . parseString d . intercalate "\n" <$> many1 nonEmptyLine - --- | List parser, called by 'paragraph'. -list :: DynFlags -> Parser (Doc RdrName) -list d = DocUnorderedList <$> unorderedList d - <|> DocOrderedList <$> orderedList d - <|> DocDefList <$> definitionList d - --- | Parses unordered (bullet) lists. -unorderedList :: DynFlags -> Parser [Doc RdrName] -unorderedList d = ("*" <|> "-") *> innerList (unorderedList d) d - --- | Parses ordered lists (numbered or dashed). -orderedList :: DynFlags -> Parser [Doc RdrName] -orderedList d = (paren <|> dot) *> innerList (orderedList d) d - where - dot = (decimal :: Parser Int) <* "." - paren = "(" *> decimal <* ")" - --- | Generic function collecting any further lines belonging to the --- list entry and recursively collecting any further lists in the --- same paragraph. Usually used as --- --- > someListFunction dynflags = listBeginning *> innerList someListFunction dynflags -innerList :: Parser [Doc RdrName] -> DynFlags -> Parser [Doc RdrName] -innerList item d = do - c <- takeLine - (cs, items) <- more item d - let contents = docParagraph . parseString d . dropNLs . unlines $ c : cs - return $ case items of - Left p -> [contents `joinPara` p] - Right i -> contents : i - --- | Parses definition lists. -definitionList :: DynFlags -> Parser [(Doc RdrName, Doc RdrName)] -definitionList d = do - label <- "[" *> (parseStringBS d <$> takeWhile1 (`notElem` "]\n")) <* "]" - c <- takeLine - (cs, items) <- more (definitionList d) d - let contents = parseString d . dropNLs . unlines $ c : cs - return $ case items of - Left p -> [(label, contents `joinPara` p)] - Right i -> (label, contents) : i - --- | If possible, appends two 'Doc's under a 'DocParagraph' rather than --- outside of it. This allows to get structures like --- --- @DocParagraph (DocAppend … …)@ --- --- rather than --- --- @DocAppend (DocParagraph …) …@ -joinPara :: Doc id -> Doc id -> Doc id -joinPara (DocParagraph p) c = docParagraph $ docAppend p c -joinPara d p = docAppend d p - --- | Drops all trailing newlines. -dropNLs :: String -> String -dropNLs = reverse . dropWhile (== '\n') . reverse - --- | Main worker for 'innerList' and 'definitionList'. --- We need the 'Either' here to be able to tell in the respective functions --- whether we're dealing with the next list or a nested paragraph. -more :: Monoid a => Parser a -> DynFlags - -> Parser ([String], Either (Doc RdrName) a) -more item d = innerParagraphs d <|> moreListItems item - <|> moreContent item d <|> pure ([], Right mempty) - --- | Use by 'innerList' and 'definitionList' to parse any nested paragraphs. -innerParagraphs :: DynFlags - -> Parser ([String], Either (Doc RdrName) a) -innerParagraphs d = (,) [] . Left <$> ("\n" *> indentedParagraphs d) - --- | Attemps to fetch the next list if possibly. Used by 'innerList' and --- 'definitionList' to recursivly grab lists that aren't separated by a whole --- paragraph. -moreListItems :: Parser a - -> Parser ([String], Either (Doc RdrName) a) -moreListItems item = (,) [] . Right <$> (skipSpace *> item) - --- | Helper for 'innerList' and 'definitionList' which simply takes --- a line of text and attempts to parse more list content with 'more'. -moreContent :: Monoid a => Parser a -> DynFlags - -> Parser ([String], Either (Doc RdrName) a) -moreContent item d = first . (:) <$> nonEmptyLine <*> more item d - --- | Runs the 'parseParas' parser on an indented paragraph. --- The indentation is 4 spaces. -indentedParagraphs :: DynFlags -> Parser (Doc RdrName) -indentedParagraphs d = parseParas d . concat <$> dropFrontOfPara " " - --- | Grab as many fully indented paragraphs as we can. -dropFrontOfPara :: Parser BS.ByteString -> Parser [String] -dropFrontOfPara sp = do - currentParagraph <- some (sp *> takeNonEmptyLine) - followingParagraphs <- - skipHorizontalSpace *> nextPar -- we have more paragraphs to take - <|> skipHorizontalSpace *> nlList -- end of the ride, remember the newline - <|> endOfInput *> return [] -- nothing more to take at all - return (currentParagraph ++ followingParagraphs) - where - nextPar = (++) <$> nlList <*> dropFrontOfPara sp - nlList = "\n" *> return ["\n"] - -nonSpace :: BS.ByteString -> Parser BS.ByteString -nonSpace xs - | not $ any (not . isSpace) $ decodeUtf8 xs = fail "empty line" - | otherwise = return xs - --- | Takes a non-empty, not fully whitespace line. --- --- Doesn't discard the trailing newline. -takeNonEmptyLine :: Parser String -takeNonEmptyLine = do - (++ "\n") . decodeUtf8 <$> (takeWhile1 (/= '\n') >>= nonSpace) <* "\n" - -birdtracks :: Parser (Doc a) -birdtracks = DocCodeBlock . DocString . intercalate "\n" . stripSpace <$> many1 line - where - line = skipHorizontalSpace *> ">" *> takeLine - -stripSpace :: [String] -> [String] -stripSpace = fromMaybe <*> mapM strip' - where - strip' (' ':xs') = Just xs' - strip' "" = Just "" - strip' _ = Nothing - --- | Parses examples. Examples are a paragraph level entitity (separated by an empty line). --- Consecutive examples are accepted. -examples :: Parser (Doc a) -examples = DocExamples <$> (many (skipHorizontalSpace *> "\n") *> go) - where - go :: Parser [Example] - go = do - prefix <- decodeUtf8 <$> takeHorizontalSpace <* ">>>" - expr <- takeLine - (rs, es) <- resultAndMoreExamples - return (makeExample prefix expr rs : es) - where - resultAndMoreExamples :: Parser ([String], [Example]) - resultAndMoreExamples = moreExamples <|> result <|> pure ([], []) - where - moreExamples :: Parser ([String], [Example]) - moreExamples = (,) [] <$> go - - result :: Parser ([String], [Example]) - result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples - - makeExample :: String -> String -> [String] -> Example - makeExample prefix expression res = - Example (strip expression) result - where - result = map (substituteBlankLine . tryStripPrefix) res - - tryStripPrefix xs = fromMaybe xs (stripPrefix prefix xs) - - substituteBlankLine "" = "" - substituteBlankLine xs = xs - -nonEmptyLine :: Parser String -nonEmptyLine = mfilter (any (not . isSpace)) takeLine - -takeLine :: Parser String -takeLine = decodeUtf8 <$> takeWhile (/= '\n') <* endOfLine - -endOfLine :: Parser () -endOfLine = void "\n" <|> endOfInput - --- | Property parser. --- --- >>> parseOnly property "prop> hello world" --- Right (DocProperty "hello world") -property :: Parser (Doc a) -property = DocProperty . strip . decodeUtf8 <$> ("prop>" *> takeWhile1 (/= '\n')) - --- | --- Paragraph level codeblock. Anything between the two delimiting @ is parsed --- for markup. -codeblock :: DynFlags -> Parser (Doc RdrName) -codeblock d = - DocCodeBlock . parseStringBS d . dropSpaces - <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@") - where - dropSpaces xs = - let rs = decodeUtf8 xs - in case splitByNl rs of - [] -> xs - ys -> case last ys of - ' ':_ -> case mapM dropSpace ys of - Nothing -> xs - Just zs -> encodeUtf8 $ intercalate "\n" zs - _ -> xs - - -- This is necessary because ‘lines’ swallows up a trailing newline - -- and we lose information about whether the last line belongs to @ or to - -- text which we need to decide whether we actually want to be dropping - -- anything at all. - splitByNl = unfoldr (\case '\n':s -> Just (span (/= '\n') s) - _ -> Nothing) - . ('\n' :) - - dropSpace "" = Just "" - dropSpace (' ':xs) = Just xs - dropSpace _ = Nothing - - block' = scan False p - where - p isNewline c - | isNewline && c == '@' = Nothing - | isNewline && isSpace c = Just isNewline - | otherwise = Just $ c == '\n' - -hyperlink :: Parser (Doc a) -hyperlink = DocHyperlink . makeLabeled Hyperlink . decodeUtf8 - <$> disallowNewline ("<" *> takeUntil ">") - <|> autoUrl - -autoUrl :: Parser (Doc a) -autoUrl = mkLink <$> url - where - url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace) - mkLink :: BS.ByteString -> Doc a - mkLink s = case BS.unsnoc s of - Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) <> DocString [x] - _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing) - --- | Parses strings between identifier delimiters. Consumes all input that it --- deems to be valid in an identifier. Note that it simply blindly consumes --- characters and does no actual validation itself. -parseValid :: Parser String -parseValid = do - vs' <- many' $ utf8String "⋆" <|> return <$> idChar - let vs = concat vs' - c <- peekChar - case c of - Just '`' -> return vs - Just '\'' -> (\x -> vs ++ "'" ++ x) <$> ("'" *> parseValid) - <|> return vs - _ -> fail "outofvalid" - where - idChar = satisfy (`elem` "_.!#$%&*+/<=>?@\\|-~:^") - <|> digit <|> letter_ascii - --- | Parses UTF8 strings from ByteString streams. -utf8String :: String -> Parser String -utf8String x = decodeUtf8 <$> string (encodeUtf8 x) - --- | Parses identifiers with help of 'parseValid'. Asks GHC for 'RdrName' from the --- string it deems valid. -identifier :: DynFlags -> Parser (Doc RdrName) -identifier dflags = do - o <- idDelim - vid <- parseValid - e <- idDelim - return $ validIdentifier o vid e - where - idDelim = char '\'' <|> char '`' - validIdentifier o ident e = case parseIdent ident of - Just identName -> DocIdentifier identName - Nothing -> DocString $ o : ident ++ [e] - - parseIdent :: String -> Maybe RdrName - parseIdent str0 = - let buffer = stringToStringBuffer str0 - realSrcLc = mkRealSrcLoc (mkFastString "") 0 0 - pstate = mkPState dflags buffer realSrcLc - in case unP parseIdentifier pstate of - POk _ name -> Just (unLoc name) - _ -> Nothing - --- | Remove all leading and trailing whitespace -strip :: String -> String -strip = (\f -> f . f) $ dropWhile isSpace . reverse - -skipHorizontalSpace :: Parser () -skipHorizontalSpace = skipWhile (`elem` " \t\f\v\r") - -takeHorizontalSpace :: Parser BS.ByteString -takeHorizontalSpace = takeWhile (`elem` " \t\f\v\r") - -makeLabeled :: (String -> Maybe String -> a) -> String -> a -makeLabeled f input = case break isSpace $ removeEscapes $ strip input of - (uri, "") -> f uri Nothing - (uri, label) -> f uri (Just $ dropWhile isSpace label) - where - -- As we don't parse these any further, we don't do any processing to the - -- string so we at least remove escape character here. Perhaps we should - -- actually be parsing the label at the very least? - removeEscapes "" = "" - removeEscapes ('\\':'\\':xs) = '\\' : removeEscapes xs - removeEscapes ('\\':xs) = removeEscapes xs - removeEscapes (x:xs) = x : removeEscapes xs diff --git a/src/Haddock/Parser/Util.hs b/src/Haddock/Parser/Util.hs deleted file mode 100644 --- a/src/Haddock/Parser/Util.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Haddock.Parser.Util where - -import Control.Applicative -import Control.Monad -import Data.Attoparsec.ByteString.Char8 -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS - -takeUntil :: ByteString -> Parser ByteString -takeUntil end_ = dropEnd <$> requireEnd (scan (False, end) p) >>= gotSome - where - end = BS.unpack end_ - - p :: (Bool, String) -> Char -> Maybe (Bool, String) - p acc c = case acc of - (True, _) -> Just (False, end) - (_, []) -> Nothing - (_, x:xs) | x == c -> Just (False, xs) - _ -> Just (c == '\\', end) - - dropEnd = BS.reverse . BS.drop (length end) . BS.reverse - requireEnd = mfilter (BS.isSuffixOf end_) - - gotSome xs - | BS.null xs = fail "didn't get any content" - | otherwise = return xs diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs deleted file mode 100644 --- a/src/Haddock/Types.hs +++ /dev/null @@ -1,604 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Types --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009, --- Mateusz Kowalczyk 2013 --- License : BSD-like --- --- Maintainer : haddock@projects.haskellorg --- Stability : experimental --- Portability : portable --- --- Types that are commonly used through-out Haddock. Some of the most --- important types are defined here, like 'Interface' and 'DocName'. ------------------------------------------------------------------------------ -module Haddock.Types ( - module Haddock.Types - , HsDocString, LHsDocString - , Fixity(..) - ) where - -import Data.Foldable -import Data.Traversable -import Control.Exception -import Control.Arrow hiding ((<+>)) -import Control.DeepSeq -import Data.Typeable -import Data.Map (Map) -import qualified Data.Map as Map -import BasicTypes (Fixity(..)) -import GHC hiding (NoLink) -import DynFlags (ExtensionFlag, Language) -import OccName -import Outputable -import Control.Applicative (Applicative(..)) -import Control.Monad (ap) - ------------------------------------------------------------------------------ --- * Convenient synonyms ------------------------------------------------------------------------------ - - -type IfaceMap = Map Module Interface -type InstIfaceMap = Map Module InstalledInterface -- TODO: rename -type DocMap a = Map Name (Doc a) -type ArgMap a = Map Name (Map Int (Doc a)) -type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl Name] -type InstMap = Map SrcSpan Name -type FixMap = Map Name Fixity -type SrcMap = Map PackageId FilePath -type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources - - ------------------------------------------------------------------------------ --- * Interface ------------------------------------------------------------------------------ - - --- | 'Interface' holds all information used to render a single Haddock page. --- It represents the /interface/ of a module. The core business of Haddock --- lies in creating this structure. Note that the record contains some fields --- that are only used to create the final record, and that are not used by the --- backends. -data Interface = Interface - { - -- | The module behind this interface. - ifaceMod :: !Module - - -- | Original file name of the module. - , ifaceOrigFilename :: !FilePath - - -- | Textual information about the module. - , ifaceInfo :: !(HaddockModInfo Name) - - -- | Documentation header. - , ifaceDoc :: !(Documentation Name) - - -- | Documentation header with cross-reference information. - , ifaceRnDoc :: !(Documentation DocName) - - -- | Haddock options for this module (prune, ignore-exports, etc). - , ifaceOptions :: ![DocOption] - - -- | Declarations originating from the module. Excludes declarations without - -- names (instances and stand-alone documentation comments). Includes - -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl Name]) - - -- | Documentation of declarations originating from the module (including - -- subordinates). - , ifaceDocMap :: !(DocMap Name) - , ifaceArgMap :: !(ArgMap Name) - - -- | Documentation of declarations originating from the module (including - -- subordinates). - , ifaceRnDocMap :: !(DocMap DocName) - , ifaceRnArgMap :: !(ArgMap DocName) - - , ifaceSubMap :: !(Map Name [Name]) - , ifaceFixMap :: !(Map Name Fixity) - - , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: ![ExportItem DocName] - - -- | All names exported by the module. - , ifaceExports :: ![Name] - - -- | All \"visible\" names exported by the module. - -- A visible name is a name that will show up in the documentation of the - -- module. - , ifaceVisibleExports :: ![Name] - - -- | Aliases of module imports as in @import A.B.C as C@. - , ifaceModuleAliases :: !AliasMap - - -- | Instances exported by the module. - , ifaceInstances :: ![ClsInst] - , ifaceFamInstances :: ![FamInst] - - -- | The number of haddockable and haddocked items in the module, as a - -- tuple. Haddockable items are the exports and the module itself. - , ifaceHaddockCoverage :: !(Int, Int) - - -- | Warnings for things defined in this module. - , ifaceWarningMap :: !WarningMap - } - -type WarningMap = DocMap Name - - --- | A subset of the fields of 'Interface' that we store in the interface --- files. -data InstalledInterface = InstalledInterface - { - -- | The module represented by this interface. - instMod :: Module - - -- | Textual information about the module. - , instInfo :: HaddockModInfo Name - - -- | Documentation of declarations originating from the module (including - -- subordinates). - , instDocMap :: DocMap Name - - , instArgMap :: ArgMap Name - - -- | All names exported by this module. - , instExports :: [Name] - - -- | All \"visible\" names exported by the module. - -- A visible name is a name that will show up in the documentation of the - -- module. - , instVisibleExports :: [Name] - - -- | Haddock options for this module (prune, ignore-exports, etc). - , instOptions :: [DocOption] - - , instSubMap :: Map Name [Name] - , instFixMap :: Map Name Fixity - } - - --- | Convert an 'Interface' to an 'InstalledInterface' -toInstalledIface :: Interface -> InstalledInterface -toInstalledIface interface = InstalledInterface - { instMod = ifaceMod interface - , instInfo = ifaceInfo interface - , instDocMap = ifaceDocMap interface - , instArgMap = ifaceArgMap interface - , instExports = ifaceExports interface - , instVisibleExports = ifaceVisibleExports interface - , instOptions = ifaceOptions interface - , instSubMap = ifaceSubMap interface - , instFixMap = ifaceFixMap interface - } - - ------------------------------------------------------------------------------ --- * Export items & declarations ------------------------------------------------------------------------------ - - -data ExportItem name - - -- | An exported declaration. - = ExportDecl - { - -- | A declaration. - expItemDecl :: !(LHsDecl name) - - -- | Maybe a doc comment, and possibly docs for arguments (if this - -- decl is a function or type-synonym). - , expItemMbDoc :: !(DocForDecl name) - - -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: ![(name, DocForDecl name)] - - -- | Instances relevant to this declaration, possibly with - -- documentation. - , expItemInstances :: ![DocInstance name] - - -- | Fixity decls relevant to this declaration (including subordinates). - , expItemFixities :: ![(name, Fixity)] - - -- | Whether the ExportItem is from a TH splice or not, for generating - -- the appropriate type of Source link. - , expItemSpliced :: !Bool - } - - -- | An exported entity for which we have no documentation (perhaps because it - -- resides in another package). - | ExportNoDecl - { expItemName :: !name - - -- | Subordinate names. - , expItemSubs :: ![name] - } - - -- | A section heading. - | ExportGroup - { - -- | Section level (1, 2, 3, ...). - expItemSectionLevel :: !Int - - -- | Section id (for hyperlinks). - , expItemSectionId :: !String - - -- | Section heading text. - , expItemSectionText :: !(Doc name) - } - - -- | Some documentation. - | ExportDoc !(Doc name) - - -- | A cross-reference to another module. - | ExportModule !Module - -data Documentation name = Documentation - { documentationDoc :: Maybe (Doc name) - , documentationWarning :: !(Maybe (Doc name)) - } deriving Functor - - --- | Arguments and result are indexed by Int, zero-based from the left, --- because that's the easiest to use when recursing over types. -type FnArgsDoc name = Map Int (Doc name) -type DocForDecl name = (Documentation name, FnArgsDoc name) - - -noDocForDecl :: DocForDecl name -noDocForDecl = (Documentation Nothing Nothing, Map.empty) - - -unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -unrenameDocForDecl (doc, fnArgsDoc) = - (fmap getName doc, (fmap . fmap) getName fnArgsDoc) - - ------------------------------------------------------------------------------ --- * Cross-referencing ------------------------------------------------------------------------------ - - --- | Type of environment used to cross-reference identifiers in the syntax. -type LinkEnv = Map Name Module - - --- | Extends 'Name' with cross-reference information. -data DocName - = Documented Name Module - -- ^ This thing is part of the (existing or resulting) - -- documentation. The 'Module' is the preferred place - -- in the documentation to refer to. - | Undocumented Name - -- ^ This thing is not part of the (existing or resulting) - -- documentation, as far as Haddock knows. - deriving Eq - - -instance NamedThing DocName where - getName (Documented name _) = name - getName (Undocumented name) = name - - ------------------------------------------------------------------------------ --- * Instances ------------------------------------------------------------------------------ - --- | The three types of instances -data InstType name - = ClassInst [HsType name] -- ^ Context - | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) - | DataInst (TyClDecl name) -- ^ Data constructors - -instance OutputableBndr a => Outputable (InstType a) where - ppr (ClassInst a) = text "ClassInst" <+> ppr a - ppr (TypeInst a) = text "TypeInst" <+> ppr a - ppr (DataInst a) = text "DataInst" <+> ppr a - --- | An instance head that may have documentation. -type DocInstance name = (InstHead name, Maybe (Doc name)) - --- | The head of an instance. Consists of a class name, a list of kind --- parameters, a list of type parameters and an instance type -type InstHead name = (name, [HsType name], [HsType name], InstType name) - ------------------------------------------------------------------------------ --- * Documentation comments ------------------------------------------------------------------------------ - - -type LDoc id = Located (Doc id) - - -data Doc id - = DocEmpty - | DocAppend (Doc id) (Doc id) - | DocString String - | DocParagraph (Doc id) - | DocIdentifier id - | DocIdentifierUnchecked (ModuleName, OccName) - | DocModule String - | DocWarning (Doc id) - | DocEmphasis (Doc id) - | DocMonospaced (Doc id) - | DocBold (Doc id) - | DocUnorderedList [Doc id] - | DocOrderedList [Doc id] - | DocDefList [(Doc id, Doc id)] - | DocCodeBlock (Doc id) - | DocHyperlink Hyperlink - | DocPic Picture - | DocAName String - | DocProperty String - | DocExamples [Example] - | DocHeader (Header (Doc id)) - deriving (Functor, Foldable, Traversable) - -instance Foldable Header where - foldMap f (Header _ a) = f a - -instance Traversable Header where - traverse f (Header l a) = Header l `fmap` f a - -instance NFData a => NFData (Doc a) where - rnf doc = case doc of - DocEmpty -> () - DocAppend a b -> a `deepseq` b `deepseq` () - DocString a -> a `deepseq` () - DocParagraph a -> a `deepseq` () - DocIdentifier a -> a `deepseq` () - DocIdentifierUnchecked a -> a `deepseq` () - DocModule a -> a `deepseq` () - DocWarning a -> a `deepseq` () - DocEmphasis a -> a `deepseq` () - DocBold a -> a `deepseq` () - DocMonospaced a -> a `deepseq` () - DocUnorderedList a -> a `deepseq` () - DocOrderedList a -> a `deepseq` () - DocDefList a -> a `deepseq` () - DocCodeBlock a -> a `deepseq` () - DocHyperlink a -> a `deepseq` () - DocPic a -> a `deepseq` () - DocAName a -> a `deepseq` () - DocProperty a -> a `deepseq` () - DocExamples a -> a `deepseq` () - DocHeader a -> a `deepseq` () - - -instance NFData Name -instance NFData OccName -instance NFData ModuleName - - -data Hyperlink = Hyperlink - { hyperlinkUrl :: String - , hyperlinkLabel :: Maybe String - } deriving (Eq, Show) - - -data Picture = Picture - { pictureUri :: String - , pictureTitle :: Maybe String - } deriving (Eq, Show) - -data Header id = Header - { headerLevel :: Int - , headerTitle :: id - } deriving Functor - -instance NFData id => NFData (Header id) where - rnf (Header a b) = a `deepseq` b `deepseq` () - -instance NFData Hyperlink where - rnf (Hyperlink a b) = a `deepseq` b `deepseq` () - -instance NFData Picture where - rnf (Picture a b) = a `deepseq` b `deepseq` () - - -data Example = Example - { exampleExpression :: String - , exampleResult :: [String] - } deriving (Eq, Show) - - -instance NFData Example where - rnf (Example a b) = a `deepseq` b `deepseq` () - - -exampleToString :: Example -> String -exampleToString (Example expression result) = - ">>> " ++ expression ++ "\n" ++ unlines result - - -data DocMarkup id a = Markup - { markupEmpty :: a - , markupString :: String -> a - , markupParagraph :: a -> a - , markupAppend :: a -> a -> a - , markupIdentifier :: id -> a - , markupIdentifierUnchecked :: (ModuleName, OccName) -> a - , markupModule :: String -> a - , markupWarning :: a -> a - , markupEmphasis :: a -> a - , markupBold :: a -> a - , markupMonospaced :: a -> a - , markupUnorderedList :: [a] -> a - , markupOrderedList :: [a] -> a - , markupDefList :: [(a,a)] -> a - , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a - , markupAName :: String -> a - , markupPic :: Picture -> a - , markupProperty :: String -> a - , markupExample :: [Example] -> a - , markupHeader :: Header a -> a - } - - -data HaddockModInfo name = HaddockModInfo - { hmi_description :: Maybe (Doc name) - , hmi_copyright :: Maybe String - , hmi_license :: Maybe String - , hmi_maintainer :: Maybe String - , hmi_stability :: Maybe String - , hmi_portability :: Maybe String - , hmi_safety :: Maybe String - , hmi_language :: Maybe Language - , hmi_extensions :: [ExtensionFlag] - } - - -emptyHaddockModInfo :: HaddockModInfo a -emptyHaddockModInfo = HaddockModInfo - { hmi_description = Nothing - , hmi_copyright = Nothing - , hmi_license = Nothing - , hmi_maintainer = Nothing - , hmi_stability = Nothing - , hmi_portability = Nothing - , hmi_safety = Nothing - , hmi_language = Nothing - , hmi_extensions = [] - } - - ------------------------------------------------------------------------------ --- * Options ------------------------------------------------------------------------------ - - -{-! for DocOption derive: Binary !-} --- | Source-level options for controlling the documentation. -data DocOption - = OptHide -- ^ This module should not appear in the docs. - | OptPrune - | OptIgnoreExports -- ^ Pretend everything is exported. - | OptNotHome -- ^ Not the best place to get docs for things - -- exported by this module. - | OptShowExtensions -- ^ Render enabled extensions for this module. - deriving (Eq, Show) - - --- | Option controlling how to qualify names -data QualOption - = OptNoQual -- ^ Never qualify any names. - | OptFullQual -- ^ Qualify all names fully. - | OptLocalQual -- ^ Qualify all imported names fully. - | OptRelativeQual -- ^ Like local, but strip module prefix - -- from modules in the same hierarchy. - | OptAliasedQual -- ^ Uses aliases of module names - -- as suggested by module import renamings. - -- However, we are unfortunately not able - -- to maintain the original qualifications. - -- Image a re-export of a whole module, - -- how could the re-exported identifiers be qualified? - -type AliasMap = Map Module ModuleName - -data Qualification - = NoQual - | FullQual - | LocalQual Module - | RelativeQual Module - | AliasedQual AliasMap Module - -- ^ @Module@ contains the current module. - -- This way we can distinguish imported and local identifiers. - -makeContentsQual :: QualOption -> Qualification -makeContentsQual qual = - case qual of - OptNoQual -> NoQual - _ -> FullQual - -makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification -makeModuleQual qual aliases mdl = - case qual of - OptLocalQual -> LocalQual mdl - OptRelativeQual -> RelativeQual mdl - OptAliasedQual -> AliasedQual aliases mdl - OptFullQual -> FullQual - OptNoQual -> NoQual - - ------------------------------------------------------------------------------ --- * Error handling ------------------------------------------------------------------------------ - - --- A monad which collects error messages, locally defined to avoid a dep on mtl - - -type ErrMsg = String -newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } - - -instance Functor ErrMsgM where - fmap f (Writer (a, msgs)) = Writer (f a, msgs) - -instance Applicative ErrMsgM where - pure = return - (<*>) = ap - -instance Monad ErrMsgM where - return a = Writer (a, []) - m >>= k = Writer $ let - (a, w) = runWriter m - (b, w') = runWriter (k a) - in (b, w ++ w') - - -tell :: [ErrMsg] -> ErrMsgM () -tell w = Writer ((), w) - - --- Exceptions - - --- | Haddock's own exception type. -data HaddockException = HaddockException String deriving Typeable - - -instance Show HaddockException where - show (HaddockException str) = str - - -throwE :: String -> a -instance Exception HaddockException -throwE str = throw (HaddockException str) - - --- In "Haddock.Interface.Create", we need to gather --- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, --- but we can't just use @GhcT ErrMsgM@ because GhcT requires the --- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } ---instance MonadIO ErrMsgGhc where --- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO ---er, implementing GhcMonad involves annoying ExceptionMonad and ---WarnLogMonad classes, so don't bother. -liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a -liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) -liftErrMsg :: ErrMsgM a -> ErrMsgGhc a -liftErrMsg = WriterGhc . return . runWriter --- for now, use (liftErrMsg . tell) for this ---tell :: [ErrMsg] -> ErrMsgGhc () ---tell msgs = WriterGhc $ return ( (), msgs ) - - -instance Functor ErrMsgGhc where - fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) - -instance Applicative ErrMsgGhc where - pure = return - (<*>) = ap - -instance Monad ErrMsgGhc where - return a = WriterGhc (return (a, [])) - m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> - fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/src/Haddock/Utf8.hs b/src/Haddock/Utf8.hs deleted file mode 100644 --- a/src/Haddock/Utf8.hs +++ /dev/null @@ -1,74 +0,0 @@ -module Haddock.Utf8 (encodeUtf8, decodeUtf8) where -import Data.Bits ((.|.), (.&.), shiftL, shiftR) -import qualified Data.ByteString as BS -import Data.Char (chr, ord) -import Data.Word (Word8) - --- | Helper that encodes and packs a 'String' into a 'BS.ByteString' -encodeUtf8 :: String -> BS.ByteString -encodeUtf8 = BS.pack . encode - --- | Helper that unpacks and decodes a 'BS.ByteString' into a 'String' -decodeUtf8 :: BS.ByteString -> String -decodeUtf8 = decode . BS.unpack - --- Copy/pasted functions from Codec.Binary.UTF8.String for encoding/decoding --- | Character to use when 'encode' or 'decode' fail for a byte. -replacementCharacter :: Char -replacementCharacter = '\xfffd' - --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. -encode :: String -> [Word8] -encode = concatMap (map fromIntegral . go . ord) - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- | Decode a UTF8 string packed into a list of Word8 values, directly to String -decode :: [Word8] -> String -decode [ ] = "" -decode (c:cs) - | c < 0x80 = chr (fromEnum c) : decode cs - | c < 0xc0 = replacementCharacter : decode cs - | c < 0xe0 = multi1 - | c < 0xf0 = multi_byte 2 0xf 0x800 - | c < 0xf8 = multi_byte 3 0x7 0x10000 - | c < 0xfc = multi_byte 4 0x3 0x200000 - | c < 0xfe = multi_byte 5 0x1 0x4000000 - | otherwise = replacementCharacter : decode cs - where - multi1 = case cs of - c1 : ds | c1 .&. 0xc0 == 0x80 -> - let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) - in if d >= 0x000080 then toEnum d : decode ds - else replacementCharacter : decode ds - _ -> replacementCharacter : decode cs - - multi_byte :: Int -> Word8 -> Int -> String - multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) - where - aux 0 rs acc - | overlong <= acc && acc <= 0x10ffff && - (acc < 0xd800 || 0xdfff < acc) && - (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs - | otherwise = replacementCharacter : decode rs - - aux n (r:rs) acc - | r .&. 0xc0 == 0x80 = aux (n-1) rs - $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) - - aux _ rs _ = replacementCharacter : decode rs diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs deleted file mode 100644 --- a/src/Haddock/Utils.hs +++ /dev/null @@ -1,480 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Haddock.Utils --- Copyright : (c) The University of Glasgow 2001-2002, --- Simon Marlow 2003-2006, --- David Waern 2006-2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Utils ( - - -- * Misc utilities - restrictTo, emptyHsQTvs, - toDescription, toInstalledDescription, - - -- * Filename utilities - moduleHtmlFile, moduleHtmlFile', - contentsHtmlFile, indexHtmlFile, - frameIndexHtmlFile, - moduleIndexFrameName, mainFrameName, synopsisFrameName, - subIndexHtmlFile, - jsFile, framesFile, - - -- * Anchor and URL utilities - moduleNameUrl, moduleNameUrl', moduleUrl, - nameAnchorId, - makeAnchorId, - - -- * Miscellaneous utilities - getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - - -- * HTML cross reference mapping - html_xrefs_ref, html_xrefs_ref', - - -- * Doc markup - markup, - idMarkup, - - -- * List utilities - replace, - spanWith, - - -- * MTL stuff - MonadIO(..), - - -- * Logging - parseVerbosity, - out, - - -- * System tools - getProcessID - ) where - - -import Haddock.Types -import Haddock.GhcUtils - -import GHC -import Name - -import Control.Monad ( liftM ) -import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) -import Numeric ( showIntAtBase ) -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import Data.IORef ( IORef, newIORef, readIORef ) -import Data.List ( isSuffixOf ) -import Data.Maybe ( mapMaybe ) -import System.Environment ( getProgName ) -import System.Exit -import System.IO ( hPutStr, stderr ) -import System.IO.Unsafe ( unsafePerformIO ) -import qualified System.FilePath.Posix as HtmlPath -import Distribution.Verbosity -import Distribution.ReadE - -#ifndef mingw32_HOST_OS -import qualified System.Posix.Internals -#endif - -import MonadUtils ( MonadIO(..) ) - - --------------------------------------------------------------------------------- --- * Logging --------------------------------------------------------------------------------- - - -parseVerbosity :: String -> Either String Verbosity -parseVerbosity = runReadE flagToVerbosity - - --- | Print a message to stdout, if it is not too verbose -out :: MonadIO m - => Verbosity -- ^ program verbosity - -> Verbosity -- ^ message verbosity - -> String -> m () -out progVerbosity msgVerbosity msg - | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg - | otherwise = return () - - --------------------------------------------------------------------------------- --- * Some Utilities --------------------------------------------------------------------------------- - - --- | Extract a module's short description. -toDescription :: Interface -> Maybe (Doc Name) -toDescription = hmi_description . ifaceInfo - - --- | Extract a module's short description. -toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) -toInstalledDescription = hmi_description . instInfo - - --------------------------------------------------------------------------------- --- * Making abstract declarations --------------------------------------------------------------------------------- - - -restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name -restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), - tcdATs = restrictATs names (tcdATs d) }) - _ -> decl - -restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name -restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) - | DataType <- new_or_data - = defn { dd_cons = restrictCons names cons } - | otherwise -- Newtype - = case restrictCons names cons of - [] -> defn { dd_ND = DataType, dd_cons = [] } - [con] -> defn { dd_cons = [con] } - _ -> error "Should not happen" - -restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | unLoc (con_name d) `elem` names = - case con_details d of - PrefixCon _ -> Just d - RecCon fields - | all field_avail fields -> Just d - | otherwise -> Just (d { con_details = PrefixCon (field_types fields) }) - -- if we have *all* the field names available, then - -- keep the record declaration. Otherwise degrade to - -- a constructor declaration. This isn't quite right, but - -- it's the best we can do. - InfixCon _ _ -> Just d - where - field_avail (ConDeclField n _ _) = unLoc n `elem` names - field_types flds = [ t | ConDeclField _ t _ <- flds ] - - keep _ = Nothing - - -restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) - - -restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] -restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] - -emptyHsQTvs :: LHsTyVarBndrs Name --- This function is here, rather than in HsTypes, because it *renamed*, but --- does not necessarily have all the rigt kind variables. It is used --- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } - - --------------------------------------------------------------------------------- --- * Filename mangling functions stolen from s main/DriverUtil.lhs. --------------------------------------------------------------------------------- - - -baseName :: ModuleName -> FilePath -baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString - - -moduleHtmlFile :: Module -> FilePath -moduleHtmlFile mdl = - case Map.lookup mdl html_xrefs of - Nothing -> baseName mdl' ++ ".html" - Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"] - where - mdl' = moduleName mdl - - -moduleHtmlFile' :: ModuleName -> FilePath -moduleHtmlFile' mdl = - case Map.lookup mdl html_xrefs' of - Nothing -> baseName mdl ++ ".html" - Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] - - -contentsHtmlFile, indexHtmlFile :: String -contentsHtmlFile = "index.html" -indexHtmlFile = "doc-index.html" - - --- | The name of the module index file to be displayed inside a frame. --- Modules are display in full, but without indentation. Clicking opens in --- the main window. -frameIndexHtmlFile :: String -frameIndexHtmlFile = "index-frames.html" - - -moduleIndexFrameName, mainFrameName, synopsisFrameName :: String -moduleIndexFrameName = "modules" -mainFrameName = "main" -synopsisFrameName = "synopsis" - - -subIndexHtmlFile :: String -> String -subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" - where b | all isAlpha ls = ls - | otherwise = concatMap (show . ord) ls - - -------------------------------------------------------------------------------- --- * Anchor and URL utilities --- --- NB: Anchor IDs, used as the destination of a link within a document must --- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's --- various needs and compatibility constraints, means these IDs have to match: --- [A-Za-z][A-Za-z0-9:_.-]* --- Such IDs do not need to be escaped in any way when used as the fragment part --- of a URL. Indeed, %-escaping them can lead to compatibility issues as it --- isn't clear if such fragment identifiers should, or should not be unescaped --- before being matched with IDs in the target document. -------------------------------------------------------------------------------- - - -moduleUrl :: Module -> String -moduleUrl = moduleHtmlFile - - -moduleNameUrl :: Module -> OccName -> String -moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n - - -moduleNameUrl' :: ModuleName -> OccName -> String -moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n - - -nameAnchorId :: OccName -> String -nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) - where prefix | isValOcc name = 'v' - | otherwise = 't' - - --- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is --- identity preserving. -makeAnchorId :: String -> String -makeAnchorId [] = [] -makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r - where - escape p c | p c = [c] - | otherwise = '-' : show (ord c) ++ "-" - isLegal ':' = True - isLegal '_' = True - isLegal '.' = True - isLegal c = isAscii c && isAlphaNum c - -- NB: '-' is legal in IDs, but we use it as the escape char - - -------------------------------------------------------------------------------- --- * Files we need to copy from our $libdir -------------------------------------------------------------------------------- - - -jsFile, framesFile :: String -jsFile = "haddock-util.js" -framesFile = "frames.html" - - -------------------------------------------------------------------------------- --- * Misc. -------------------------------------------------------------------------------- - - -getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName - where str `withoutSuffix` suff - | suff `isSuffixOf` str = take (length str - length suff) str - | otherwise = str - - -bye :: String -> IO a -bye s = putStr s >> exitSuccess - - -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - - -dieMsg :: String -> IO a -dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - - -noDieMsg :: String -> IO () -noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) - - -mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] -mapSnd _ [] = [] -mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs - - -mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) -mapMaybeM _ Nothing = return Nothing -mapMaybeM f (Just a) = liftM Just (f a) - - -escapeStr :: String -> String -escapeStr = escapeURIString isUnreserved - - --- Following few functions are copy'n'pasted from Network.URI module --- to avoid depending on the network lib, since doing so gives a --- circular build dependency between haddock and network --- (at least if you want to build network with haddock docs) -escapeURIChar :: (Char -> Bool) -> Char -> String -escapeURIChar p c - | p c = [c] - | otherwise = '%' : myShowHex (ord c) "" - where - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 toChrHex n r of - [] -> "00" - [a] -> ['0',a] - cs -> cs - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'A' + fromIntegral (d - 10)) - - -escapeURIString :: (Char -> Bool) -> String -> String -escapeURIString = concatMap . escapeURIChar - - -isUnreserved :: Char -> Bool -isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") - - -isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool -isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') -isDigitChar c = c >= '0' && c <= '9' -isAlphaNumChar c = isAlphaChar c || isDigitChar c - - ------------------------------------------------------------------------------ --- * HTML cross references --- --- For each module, we need to know where its HTML documentation lives --- so that we can point hyperlinks to it. It is extremely --- inconvenient to plumb this information to all the places that need --- it (basically every function in HaddockHtml), and furthermore the --- mapping is constant for any single run of Haddock. So for the time --- being I'm going to use a write-once global variable. ------------------------------------------------------------------------------ - - -{-# NOINLINE html_xrefs_ref #-} -html_xrefs_ref :: IORef (Map Module FilePath) -html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) - - -{-# NOINLINE html_xrefs_ref' #-} -html_xrefs_ref' :: IORef (Map ModuleName FilePath) -html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map")) - - -{-# NOINLINE html_xrefs #-} -html_xrefs :: Map Module FilePath -html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) - - -{-# NOINLINE html_xrefs' #-} -html_xrefs' :: Map ModuleName FilePath -html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref') - - ------------------------------------------------------------------------------ --- * List utils ------------------------------------------------------------------------------ - - -replace :: Eq a => a -> a -> [a] -> [a] -replace a b = map (\x -> if x == a then b else x) - - -spanWith :: (a -> Maybe b) -> [a] -> ([b],[a]) -spanWith _ [] = ([],[]) -spanWith p xs@(a:as) - | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) - | otherwise = ([],xs) - - ------------------------------------------------------------------------------ --- * Put here temporarily ------------------------------------------------------------------------------ - - -markup :: DocMarkup id a -> Doc id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) - - -markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) -markupPair m (a,b) = (markup m a, markup m b) - - --- | The identity markup -idMarkup :: DocMarkup a (Doc a) -idMarkup = Markup { - markupEmpty = DocEmpty, - markupString = DocString, - markupParagraph = DocParagraph, - markupAppend = DocAppend, - markupIdentifier = DocIdentifier, - markupIdentifierUnchecked = DocIdentifierUnchecked, - markupModule = DocModule, - markupWarning = DocWarning, - markupEmphasis = DocEmphasis, - markupBold = DocBold, - markupMonospaced = DocMonospaced, - markupUnorderedList = DocUnorderedList, - markupOrderedList = DocOrderedList, - markupDefList = DocDefList, - markupCodeBlock = DocCodeBlock, - markupHyperlink = DocHyperlink, - markupAName = DocAName, - markupPic = DocPic, - markupProperty = DocProperty, - markupExample = DocExamples, - markupHeader = DocHeader - } - - ------------------------------------------------------------------------------ --- * System tools ------------------------------------------------------------------------------ - - -#ifdef mingw32_HOST_OS -foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows -#else -getProcessID :: IO Int -getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid -#endif diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs deleted file mode 100644 --- a/src/Haddock/Version.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Version --- Copyright : (c) Simon Marlow 2003 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Version ( - projectName, projectVersion, projectUrl -) where - -import Paths_haddock ( version ) -import Data.Version ( showVersion ) - -projectName, projectUrl :: String -projectName = "Haddock" -projectUrl = "http://www.haskell.org/haddock/" - -projectVersion :: String -projectVersion = showVersion version diff --git a/src/haddock.sh b/src/haddock.sh deleted file mode 100644 --- a/src/haddock.sh +++ /dev/null @@ -1,7 +0,0 @@ -# Mini-driver for Haddock - -# needs the following variables: -# HADDOCKLIB -# HADDOCKBIN - -$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"} diff --git a/test/Haddock/Parser/UtilSpec.hs b/test/Haddock/Parser/UtilSpec.hs deleted file mode 100644 --- a/test/Haddock/Parser/UtilSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Haddock.Parser.UtilSpec (main, spec) where - -import Test.Hspec -import Data.Either - -import Data.Attoparsec.ByteString.Char8 -import Haddock.Parser.Util - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "takeUntil" $ do - it "takes everything until a specified byte sequence" $ do - parseOnly (takeUntil "end") "someend" `shouldBe` Right "some" - - it "requires the end sequence" $ do - parseOnly (takeUntil "end") "someen" `shouldSatisfy` isLeft - - it "takes escaped bytes unconditionally" $ do - parseOnly (takeUntil "end") "some\\endend" `shouldBe` Right "some\\end" diff --git a/test/Haddock/ParserSpec.hs b/test/Haddock/ParserSpec.hs deleted file mode 100644 --- a/test/Haddock/ParserSpec.hs +++ /dev/null @@ -1,839 +0,0 @@ -{-# LANGUAGE OverloadedStrings, StandaloneDeriving - , FlexibleInstances, UndecidableInstances - , IncoherentInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Haddock.ParserSpec (main, spec) where - -import Data.Monoid -import Data.String -import qualified Haddock.Parser as Parse -import Haddock.Types -import Outputable (Outputable, showSDoc, ppr) -import RdrName (RdrName, mkVarUnqual) -import FastString (fsLit) -import StaticFlags (initStaticOpts) -import Test.Hspec -import Test.QuickCheck - -import Helper - -instance Outputable a => Show a where - show = showSDoc dynFlags . ppr - -deriving instance Show a => Show (Header a) -deriving instance Show a => Show (Doc a) -deriving instance Eq a => Eq (Header a) -deriving instance Eq a => Eq (Doc a) - -instance IsString RdrName where - fromString = mkVarUnqual . fsLit - -instance IsString (Doc RdrName) where - fromString = DocString - -instance IsString a => IsString (Maybe a) where - fromString = Just . fromString - -parseParas :: String -> Doc RdrName -parseParas = Parse.parseParas dynFlags - -parseString :: String -> Doc RdrName -parseString = Parse.parseString dynFlags - -main :: IO () -main = hspec spec - -spec :: Spec -spec = before initStaticOpts $ do - describe "parseString" $ do - let infix 1 `shouldParseTo` - shouldParseTo :: String -> Doc RdrName -> Expectation - shouldParseTo input ast = parseString input `shouldBe` ast - - it "is total" $ do - property $ \xs -> - (length . show . parseString) xs `shouldSatisfy` (> 0) - - context "when parsing text" $ do - it "can handle unicode" $ do - "灼眼のシャナ" `shouldParseTo` "灼眼のシャナ" - - it "accepts numeric character references" $ do - "foo bar baz λ" `shouldParseTo` "foo bar baz λ" - - it "accepts hexadecimal character references" $ do - "e" `shouldParseTo` "e" - - it "allows to backslash-escape characters" $ do - property $ \x -> ['\\', x] `shouldParseTo` DocString [x] - - context "when parsing strings contaning numeric character references" $ do - it "will implicitly convert digits to characters" $ do - "AAAA" `shouldParseTo` "AAAA" - - "灼眼のシャナ" - `shouldParseTo` "灼眼のシャナ" - - it "will implicitly convert hex encoded characters" $ do - "eeee" `shouldParseTo` "eeee" - - context "when parsing identifiers" $ do - it "parses identifiers enclosed within single ticks" $ do - "'foo'" `shouldParseTo` DocIdentifier "foo" - - it "parses identifiers enclosed within backticks" $ do - "`foo`" `shouldParseTo` DocIdentifier "foo" - - it "parses a word with an one of the delimiters in it as DocString" $ do - "don't" `shouldParseTo` "don't" - - it "doesn't pass pairs of delimiters with spaces between them" $ do - "hel'lo w'orld" `shouldParseTo` "hel'lo w'orld" - - it "don't use apostrophe's in the wrong place's" $ do - " don't use apostrophe's in the wrong place's" `shouldParseTo` - "don't use apostrophe's in the wrong place's" - - context "when parsing URLs" $ do - let hyperlink :: String -> Maybe String -> Doc RdrName - hyperlink url = DocHyperlink . Hyperlink url - - it "parses a URL" $ do - "" `shouldParseTo` hyperlink "http://example.com/" Nothing - - it "accepts an optional label" $ do - "" `shouldParseTo` hyperlink "http://example.com/" "some link" - - it "does not accept newlines in label" $ do - "" `shouldParseTo` "" - - -- new behaviour test, this will be now consistent with other markup - it "allows us to escape > inside the URL" $ do - "le.com>" `shouldParseTo` - hyperlink "http://examp>le.com" Nothing - - "mp\\>le.com>" `shouldParseTo` - hyperlink "http://exa>mp>le.com" Nothing - - -- Likewise in label - "oo>" `shouldParseTo` - hyperlink "http://example.com" "f>oo" - - it "parses inline URLs" $ do - "foo bar" `shouldParseTo` - "foo " <> hyperlink "http://example.com/" Nothing <> " bar" - - it "doesn't allow for multi-line link tags" $ do - "" `shouldParseTo` "" - - context "when autolinking URLs" $ do - it "autolinks HTTP URLs" $ do - "http://example.com/" `shouldParseTo` hyperlink "http://example.com/" Nothing - - it "autolinks HTTPS URLs" $ do - "https://www.example.com/" `shouldParseTo` hyperlink "https://www.example.com/" Nothing - - it "autolinks FTP URLs" $ do - "ftp://example.com/" `shouldParseTo` hyperlink "ftp://example.com/" Nothing - - it "does not include a trailing comma" $ do - "http://example.com/, Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> ", Some other sentence." - - it "does not include a trailing dot" $ do - "http://example.com/. Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> ". Some other sentence." - - it "does not include a trailing exclamation mark" $ do - "http://example.com/! Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> "! Some other sentence." - - it "does not include a trailing question mark" $ do - "http://example.com/? Some other sentence." `shouldParseTo` - hyperlink "http://example.com/" Nothing <> "? Some other sentence." - - context "when parsing pictures" $ do - let picture :: String -> Maybe String -> Doc RdrName - picture uri = DocPic . Picture uri - - it "parses a simple picture" $ do - "<>" `shouldParseTo` picture "baz" Nothing - - it "parses a picture with a title" $ do - "<>" `shouldParseTo` picture "b" (Just "a z") - - it "parses a picture with unicode" $ do - "<<灼眼のシャナ>>" `shouldParseTo` picture "灼眼のシャナ" Nothing - - it "allows for escaping of the closing tags" $ do - "<>z>>" `shouldParseTo` picture "ba>>z" Nothing - - it "doesn't allow for multi-line picture tags" $ do - "<>" `shouldParseTo` "<>" - - context "when parsing anchors" $ do - it "parses a single word anchor" $ do - "#foo#" `shouldParseTo` DocAName "foo" - - it "parses a multi word anchor" $ do - "#foo bar#" `shouldParseTo` DocAName "foo bar" - - it "parses a unicode anchor" $ do - "#灼眼のシャナ#" `shouldParseTo` DocAName "灼眼のシャナ" - - it "does not accept newlines in anchors" $ do - "#foo\nbar#" `shouldParseTo` "#foo\nbar#" - - it "accepts anchors mid-paragraph" $ do - "Hello #someAnchor# world!" - `shouldParseTo` "Hello " <> DocAName "someAnchor" <> " world!" - - it "does not accept empty anchors" $ do - "##" `shouldParseTo` "##" - - context "when parsing emphasised text" $ do - it "emphasises a word on its own" $ do - "/foo/" `shouldParseTo` DocEmphasis "foo" - - it "emphasises inline correctly" $ do - "foo /bar/ baz" `shouldParseTo` "foo " <> DocEmphasis "bar" <> " baz" - - it "emphasises unicode" $ do - "/灼眼のシャナ/" `shouldParseTo` DocEmphasis "灼眼のシャナ" - - it "does not emphasise multi-line strings" $ do - " /foo\nbar/" `shouldParseTo` "/foo\nbar/" - - it "does not emphasise the empty string" $ do - "//" `shouldParseTo` "//" - - it "parses escaped slashes literally" $ do - "/foo\\/bar/" `shouldParseTo` DocEmphasis "foo/bar" - - it "recognizes other markup constructs within emphasised text" $ do - "/foo @bar@ baz/" `shouldParseTo` - DocEmphasis ("foo " <> DocMonospaced "bar" <> " baz") - - it "allows other markup inside of emphasis" $ do - "/__inner bold__/" `shouldParseTo` DocEmphasis (DocBold "inner bold") - - it "doesn't mangle inner markup unicode" $ do - "/__灼眼のシャナ A__/" `shouldParseTo` DocEmphasis (DocBold "灼眼のシャナ A") - - it "properly converts HTML escape sequences" $ do - "/AAAA/" `shouldParseTo` DocEmphasis "AAAA" - - it "allows to escape the emphasis delimiter inside of emphasis" $ do - "/empha\\/sis/" `shouldParseTo` DocEmphasis "empha/sis" - - context "when parsing monospaced text" $ do - it "parses simple monospaced text" $ do - "@foo@" `shouldParseTo` DocMonospaced "foo" - - it "parses inline monospaced text" $ do - "foo @bar@ baz" `shouldParseTo` "foo " <> DocMonospaced "bar" <> " baz" - - it "allows to escape @" $ do - "@foo \\@ bar@" `shouldParseTo` DocMonospaced "foo @ bar" - - it "accepts unicode" $ do - "@foo 灼眼のシャナ bar@" `shouldParseTo` DocMonospaced "foo 灼眼のシャナ bar" - - it "accepts other markup in monospaced text" $ do - "@/foo/@" `shouldParseTo` DocMonospaced (DocEmphasis "foo") - - it "requires the closing @" $ do - "@foo /bar/ baz" `shouldParseTo` "@foo " <> DocEmphasis "bar" <> " baz" - - context "when parsing bold strings" $ do - it "allows for a bold string on its own" $ do - "__bold string__" `shouldParseTo` - DocBold "bold string" - - it "bolds inline correctly" $ do - "hello __everyone__ there" `shouldParseTo` - "hello " - <> DocBold "everyone" <> " there" - - it "bolds unicode" $ do - "__灼眼のシャナ__" `shouldParseTo` - DocBold "灼眼のシャナ" - - it "does not do __multi-line\\n bold__" $ do - " __multi-line\n bold__" `shouldParseTo` "__multi-line\n bold__" - - it "allows other markup inside of bold" $ do - "__/inner emphasis/__" `shouldParseTo` - (DocBold $ DocEmphasis "inner emphasis") - - it "doesn't mangle inner markup unicode" $ do - "__/灼眼のシャナ A/__" `shouldParseTo` - (DocBold $ DocEmphasis "灼眼のシャナ A") - - it "properly converts HTML escape sequences" $ do - "__AAAA__" `shouldParseTo` - DocBold "AAAA" - - it "allows to escape the bold delimiter inside of bold" $ do - "__bo\\__ld__" `shouldParseTo` - DocBold "bo__ld" - - it "doesn't allow for empty bold" $ do - "____" `shouldParseTo` "____" - - context "when parsing module strings" $ do - it "should parse a module on its own" $ do - "\"Module\"" `shouldParseTo` - DocModule "Module" - - it "should parse a module inline" $ do - "This is a \"Module\"." `shouldParseTo` - "This is a " <> DocModule "Module" <> "." - - it "can accept a simple module name" $ do - "\"Hello\"" `shouldParseTo` DocModule "Hello" - - it "can accept a module name with dots" $ do - "\"Hello.World\"" `shouldParseTo` DocModule "Hello.World" - - it "can accept a module name with unicode" $ do - "\"Hello.Worldλ\"" `shouldParseTo` DocModule "Hello.Worldλ" - - it "parses a module name with a trailing dot as regular quoted string" $ do - "\"Hello.\"" `shouldParseTo` "\"Hello.\"" - - it "parses a module name with a space as regular quoted string" $ do - "\"Hello World\"" `shouldParseTo` "\"Hello World\"" - - it "parses a module name with invalid characters as regular quoted string" $ do - "\"Hello&[{}(=*)+]!\"" `shouldParseTo` "\"Hello&[{}(=*)+]!\"" - - it "accepts a module name with unicode" $ do - "\"Foo.Barλ\"" `shouldParseTo` DocModule "Foo.Barλ" - - it "treats empty module name as regular double quotes" $ do - "\"\"" `shouldParseTo` "\"\"" - - it "accepts anchor reference syntax as DocModule" $ do - "\"Foo#bar\"" `shouldParseTo` DocModule "Foo#bar" - - it "accepts old anchor reference syntax as DocModule" $ do - "\"Foo\\#bar\"" `shouldParseTo` DocModule "Foo\\#bar" - - describe "parseParas" $ do - let infix 1 `shouldParseTo` - shouldParseTo :: String -> Doc RdrName -> Expectation - shouldParseTo input ast = parseParas input `shouldBe` ast - - it "is total" $ do - property $ \xs -> - (length . show . parseParas) xs `shouldSatisfy` (> 0) - - context "when parsing text paragraphs" $ do - let filterSpecial = filter (`notElem` (".(=#-[*`\v\f\n\t\r\\\"'_/@<> " :: String)) - - it "parses an empty paragraph" $ do - "" `shouldParseTo` DocEmpty - - it "parses a simple text paragraph" $ do - "foo bar baz" `shouldParseTo` DocParagraph "foo bar baz" - - it "accepts markup in text paragraphs" $ do - "foo /bar/ baz" `shouldParseTo` DocParagraph ("foo " <> DocEmphasis "bar" <> " baz") - - it "preserve all regular characters" $ do - property $ \xs -> let input = filterSpecial xs in (not . null) input ==> - input `shouldParseTo` DocParagraph (DocString input) - - it "separates paragraphs by empty lines" $ do - unlines [ - "foo" - , " \t " - , "bar" - ] `shouldParseTo` DocParagraph "foo" <> DocParagraph "bar" - - context "when a pragraph only contains monospaced text" $ do - it "turns it into a code block" $ do - "@foo@" `shouldParseTo` DocCodeBlock "foo" - - context "when parsing birdtracks" $ do - it "parses them as a code block" $ do - unlines [ - ">foo" - , ">bar" - , ">baz" - ] `shouldParseTo` DocCodeBlock "foo\nbar\nbaz" - - it "ignores leading whitespace" $ do - unlines [ - " >foo" - , " \t >bar" - , " >baz" - ] - `shouldParseTo` DocCodeBlock "foo\nbar\nbaz" - - it "strips one leading space from each line of the block" $ do - unlines [ - "> foo" - , "> bar" - , "> baz" - ] `shouldParseTo` DocCodeBlock "foo\n bar\nbaz" - - it "ignores empty lines when stripping spaces" $ do - unlines [ - "> foo" - , ">" - , "> bar" - ] `shouldParseTo` DocCodeBlock "foo\n\nbar" - - context "when any non-empty line does not start with a space" $ do - it "does not strip any spaces" $ do - unlines [ - ">foo" - , "> bar" - ] `shouldParseTo` DocCodeBlock "foo\n bar" - - it "ignores nested markup" $ do - unlines [ - ">/foo/" - ] `shouldParseTo` DocCodeBlock "/foo/" - - it "treats them as regular text inside text paragraphs" $ do - unlines [ - "foo" - , ">bar" - ] `shouldParseTo` DocParagraph "foo\n>bar" - - context "when parsing code blocks" $ do - it "accepts a simple code block" $ do - unlines [ - "@" - , "foo" - , "bar" - , "baz" - , "@" - ] `shouldParseTo` DocCodeBlock "foo\nbar\nbaz\n" - - it "ignores trailing whitespace after the opening @" $ do - unlines [ - "@ " - , "foo" - , "@" - ] `shouldParseTo` DocCodeBlock "foo\n" - - it "rejects code blocks that are not closed" $ do - unlines [ - "@" - , "foo" - ] `shouldParseTo` DocParagraph "@\nfoo" - - it "accepts nested markup" $ do - unlines [ - "@" - , "/foo/" - , "@" - ] `shouldParseTo` DocCodeBlock (DocEmphasis "foo" <> "\n") - - it "allows to escape the @" $ do - unlines [ - "@" - , "foo" - , "\\@" - , "bar" - , "@" - ] `shouldParseTo` DocCodeBlock "foo\n@\nbar\n" - - it "accepts horizontal space before the @" $ do - unlines [ " @" - , "foo" - , "" - , "bar" - , "@" - ] `shouldParseTo` DocCodeBlock "foo\n\nbar\n" - - it "strips a leading space from a @ block if present" $ do - unlines [ " @" - , " hello" - , " world" - , " @" - ] `shouldParseTo` DocCodeBlock "hello\nworld\n" - - unlines [ " @" - , " hello" - , "" - , " world" - , " @" - ] `shouldParseTo` DocCodeBlock "hello\n\nworld\n" - - it "only drops whitespace if there's some before closing @" $ do - unlines [ "@" - , " Formatting" - , " matters." - , "@" - ] - `shouldParseTo` DocCodeBlock " Formatting\n matters.\n" - - it "accepts unicode" $ do - "@foo 灼眼のシャナ bar@" `shouldParseTo` DocCodeBlock "foo 灼眼のシャナ bar" - - it "requires the closing @" $ do - "@foo /bar/ baz" - `shouldParseTo` DocParagraph ("@foo " <> DocEmphasis "bar" <> " baz") - - - context "when parsing examples" $ do - it "parses a simple example" $ do - ">>> foo" `shouldParseTo` DocExamples [Example "foo" []] - - it "parses an example with result" $ do - unlines [ - ">>> foo" - , "bar" - , "baz" - ] `shouldParseTo` DocExamples [Example "foo" ["bar", "baz"]] - - it "parses consecutive examples" $ do - unlines [ - ">>> fib 5" - , "5" - , ">>> fib 10" - , "55" - ] `shouldParseTo` DocExamples [ - Example "fib 5" ["5"] - , Example "fib 10" ["55"] - ] - - it ("requires an example to be separated" - ++ " from a previous paragraph by an empty line") $ do - "foobar\n\n>>> fib 10\n55" `shouldParseTo` - DocParagraph "foobar" - <> DocExamples [Example "fib 10" ["55"]] - - it "parses bird-tracks inside of paragraphs as plain strings" $ do - let xs = "foo\n>>> bar" - xs `shouldParseTo` DocParagraph (DocString xs) - - it "skips empty lines in front of an example" $ do - "\n \n\n>>> foo" `shouldParseTo` DocExamples [Example "foo" []] - - it "terminates example on empty line" $ do - unlines [ - ">>> foo" - , "bar" - , " " - , "baz" - ] - `shouldParseTo` - DocExamples [Example "foo" ["bar"]] <> DocParagraph "baz" - - it "parses a result as an empty result" $ do - unlines [ - ">>> foo" - , "bar" - , "" - , "baz" - ] - `shouldParseTo` DocExamples [Example "foo" ["bar", "", "baz"]] - - it "accepts unicode in examples" $ do - ">>> 灼眼\nシャナ" `shouldParseTo` DocExamples [Example "灼眼" ["シャナ"]] - - context "when prompt is prefixed by whitespace" $ do - it "strips the exact same amount of whitespace from result lines" $ do - unlines [ - " >>> foo" - , " bar" - , " baz" - ] `shouldParseTo` DocExamples [Example "foo" ["bar", "baz"]] - - it "preserves additional whitespace" $ do - unlines [ - " >>> foo" - , " bar" - ] `shouldParseTo` DocExamples [Example "foo" [" bar"]] - - it "keeps original if stripping is not possible" $ do - unlines [ - " >>> foo" - , " bar" - ] `shouldParseTo` DocExamples [Example "foo" [" bar"]] - - - context "when parsing paragraphs nested in lists" $ do - it "can nest the same type of list" $ do - "* foo\n\n * bar" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocUnorderedList [DocParagraph "bar"]] - - it "can nest another type of list inside" $ do - "* foo\n\n 1. bar" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocOrderedList [DocParagraph "bar"]] - - it "can nest a code block inside" $ do - "* foo\n\n @foo bar baz@" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocCodeBlock "foo bar baz"] - - "* foo\n\n @\n foo bar baz\n @" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocCodeBlock "foo bar baz\n"] - - it "can nest more than one level" $ do - "* foo\n\n * bar\n\n * baz\n qux" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocUnorderedList [ DocParagraph $ "bar" - <> DocUnorderedList [DocParagraph "baz\nqux"] - ] - ] - - it "won't fail on not fully indented paragraph" $ do - "* foo\n\n * bar\n\n * qux\nquux" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocUnorderedList [ DocParagraph "bar" ] - , DocParagraph "qux\nquux"] - - - it "can nest definition lists" $ do - "[a] foo\n\n [b] bar\n\n [c] baz\n qux" `shouldParseTo` - DocDefList [ ("a", "foo" - <> DocDefList [ ("b", "bar" - <> DocDefList [("c", "baz\nqux")]) - ]) - ] - - it "can come back to top level with a different list" $ do - "* foo\n\n * bar\n\n1. baz" `shouldParseTo` - DocUnorderedList [ DocParagraph $ "foo" - <> DocUnorderedList [ DocParagraph "bar" ] - ] - <> DocOrderedList [ DocParagraph "baz" ] - - it "definition lists can come back to top level with a different list" $ do - "[foo] foov\n\n [bar] barv\n\n1. baz" `shouldParseTo` - DocDefList [ ("foo", "foov" - <> DocDefList [ ("bar", "barv") ]) - ] - <> DocOrderedList [ DocParagraph "baz" ] - - context "when parsing properties" $ do - it "can parse a single property" $ do - "prop> 23 == 23" `shouldParseTo` DocProperty "23 == 23" - - it "can parse multiple subsequent properties" $ do - unlines [ - "prop> 23 == 23" - , "prop> 42 == 42" - ] - `shouldParseTo` - DocProperty "23 == 23" <> DocProperty "42 == 42" - - it "accepts unicode in properties" $ do - "prop> 灼眼のシャナ ≡ 愛" `shouldParseTo` - DocProperty "灼眼のシャナ ≡ 愛" - - it "can deal with whitespace before and after the prop> prompt" $ do - " prop> xs == (reverse $ reverse xs) " `shouldParseTo` - DocProperty "xs == (reverse $ reverse xs)" - - context "when parsing unordered lists" $ do - it "parses a simple list" $ do - unlines [ - " * one" - , " * two" - , " * three" - ] - `shouldParseTo` DocUnorderedList [ - DocParagraph "one" - , DocParagraph "two" - , DocParagraph "three" - ] - - it "ignores empty lines between list items" $ do - unlines [ - "* one" - , "" - , "* two" - ] - `shouldParseTo` DocUnorderedList [ - DocParagraph "one" - , DocParagraph "two" - ] - - it "accepts an empty list item" $ do - "*" `shouldParseTo` DocUnorderedList [DocParagraph DocEmpty] - - it "accepts multi-line list items" $ do - unlines [ - "* point one" - , " more one" - , "* point two" - , "more two" - ] - `shouldParseTo` DocUnorderedList [ - DocParagraph "point one\n more one" - , DocParagraph "point two\nmore two" - ] - - it "accepts markup in list items" $ do - "* /foo/" `shouldParseTo` DocUnorderedList [DocParagraph (DocEmphasis "foo")] - - it "requires empty lines between list and other paragraphs" $ do - unlines [ - "foo" - , "" - , "* bar" - , "" - , "baz" - ] - `shouldParseTo` DocParagraph "foo" <> DocUnorderedList [DocParagraph "bar"] <> DocParagraph "baz" - - context "when parsing ordered lists" $ do - it "parses a simple list" $ do - unlines [ - " 1. one" - , " (1) two" - , " 3. three" - ] - `shouldParseTo` DocOrderedList [ - DocParagraph "one" - , DocParagraph "two" - , DocParagraph "three" - ] - - it "ignores empty lines between list items" $ do - unlines [ - "1. one" - , "" - , "2. two" - ] - `shouldParseTo` DocOrderedList [ - DocParagraph "one" - , DocParagraph "two" - ] - - it "accepts an empty list item" $ do - "1." `shouldParseTo` DocOrderedList [DocParagraph DocEmpty] - - it "accepts multi-line list items" $ do - unlines [ - "1. point one" - , " more one" - , "1. point two" - , "more two" - ] - `shouldParseTo` DocOrderedList [ - DocParagraph "point one\n more one" - , DocParagraph "point two\nmore two" - ] - - it "accepts markup in list items" $ do - "1. /foo/" `shouldParseTo` DocOrderedList [DocParagraph (DocEmphasis "foo")] - - it "requires empty lines between list and other paragraphs" $ do - unlines [ - "foo" - , "" - , "1. bar" - , "" - , "baz" - ] - `shouldParseTo` DocParagraph "foo" <> DocOrderedList [DocParagraph "bar"] <> DocParagraph "baz" - - context "when parsing definition lists" $ do - it "parses a simple list" $ do - unlines [ - " [foo] one" - , " [bar] two" - , " [baz] three" - ] - `shouldParseTo` DocDefList [ - ("foo", "one") - , ("bar", "two") - , ("baz", "three") - ] - - it "ignores empty lines between list items" $ do - unlines [ - "[foo] one" - , "" - , "[bar] two" - ] - `shouldParseTo` DocDefList [ - ("foo", "one") - , ("bar", "two") - ] - - it "accepts an empty list item" $ do - "[foo]" `shouldParseTo` DocDefList [("foo", DocEmpty)] - - it "accepts multi-line list items" $ do - unlines [ - "[foo] point one" - , " more one" - , "[bar] point two" - , "more two" - ] - `shouldParseTo` DocDefList [ - ("foo", "point one\n more one") - , ("bar", "point two\nmore two") - ] - - it "accepts markup in list items" $ do - "[foo] /foo/" `shouldParseTo` DocDefList [("foo", DocEmphasis "foo")] - - it "accepts markup for the label" $ do - "[/foo/] bar" `shouldParseTo` DocDefList [(DocEmphasis "foo", "bar")] - - it "requires empty lines between list and other paragraphs" $ do - unlines [ - "foo" - , "" - , "[foo] bar" - , "" - , "baz" - ] - `shouldParseTo` DocParagraph "foo" <> DocDefList [("foo", "bar")] <> DocParagraph "baz" - - context "when parsing consecutive paragraphs" $ do - it "will not capture irrelevant consecutive lists" $ do - unlines [ " * bullet" - , "" - , "" - , " - different bullet" - , "" - , "" - , " (1) ordered" - , " " - , " 2. different bullet" - , " " - , " [cat] kitten" - , " " - , " [pineapple] fruit" - ] `shouldParseTo` - DocUnorderedList [ DocParagraph "bullet" - , DocParagraph "different bullet"] - <> DocOrderedList [ DocParagraph "ordered" - , DocParagraph "different bullet" - ] - <> DocDefList [ ("cat", "kitten") - , ("pineapple", "fruit") - ] - - context "when parsing function documentation headers" $ do - it "can parse a simple header" $ do - "= Header 1\nHello." `shouldParseTo` - DocParagraph (DocHeader (Header 1 "Header 1")) - <> DocParagraph "Hello." - - it "allow consecutive headers" $ do - "= Header 1\n== Header 2" `shouldParseTo` - DocParagraph (DocHeader (Header 1 "Header 1")) - <> DocParagraph (DocHeader (Header 2 "Header 2")) - - it "accepts markup in the header" $ do - "= /Header/ __1__\nFoo" `shouldParseTo` - DocParagraph (DocHeader - (Header 1 (DocEmphasis "Header" <> " " <> DocBold "1"))) - <> DocParagraph "Foo" diff --git a/test/Haddock/Utf8Spec.hs b/test/Haddock/Utf8Spec.hs deleted file mode 100644 --- a/test/Haddock/Utf8Spec.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Haddock.Utf8Spec (main, spec) where - -import Test.Hspec -import Test.QuickCheck - -import Haddock.Utf8 - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "decodeUtf8" $ do - it "is inverse to encodeUtf8" $ do - property $ \xs -> (decodeUtf8 . encodeUtf8) xs `shouldBe` xs diff --git a/test/Helper.hs b/test/Helper.hs deleted file mode 100644 --- a/test/Helper.hs +++ /dev/null @@ -1,183 +0,0 @@ -module Helper where -import DynFlags (Settings(..), DynFlags, defaultDynFlags) -import Platform -import PlatformConstants - -dynFlags :: DynFlags -dynFlags = defaultDynFlags settings - where - settings = Settings { - sTargetPlatform = platform - , sGhcUsagePath = error "Haddock.ParserSpec.sGhcUsagePath" - , sGhciUsagePath = error "Haddock.ParserSpec.sGhciUsagePath" - , sTopDir = error "Haddock.ParserSpec.sTopDir" - , sTmpDir = error "Haddock.ParserSpec.sTmpDir" - , sRawSettings = [] - , sExtraGccViaCFlags = error "Haddock.ParserSpec.sExtraGccViaCFlags" - , sSystemPackageConfig = error "Haddock.ParserSpec.sSystemPackageConfig" - , sPgm_L = error "Haddock.ParserSpec.sPgm_L" - , sPgm_P = error "Haddock.ParserSpec.sPgm_P" - , sPgm_F = error "Haddock.ParserSpec.sPgm_F" - , sPgm_c = error "Haddock.ParserSpec.sPgm_c" - , sPgm_s = error "Haddock.ParserSpec.sPgm_s" - , sPgm_a = error "Haddock.ParserSpec.sPgm_a" - , sPgm_l = error "Haddock.ParserSpec.sPgm_l" - , sPgm_dll = error "Haddock.ParserSpec.sPgm_dll" - , sPgm_T = error "Haddock.ParserSpec.sPgm_T" - , sPgm_sysman = error "Haddock.ParserSpec.sPgm_sysman" - , sPgm_windres = error "Haddock.ParserSpec.sPgm_windres" - , sPgm_libtool = error "Haddock.ParserSpec.sPgm_libtool" - , sPgm_lo = error "Haddock.ParserSpec.sPgm_lo" - , sPgm_lc = error "Haddock.ParserSpec.sPgm_lc" - , sOpt_L = [] - , sOpt_P = [] - , sOpt_F = [] - , sOpt_c = [] - , sOpt_a = [] - , sOpt_l = [] - , sOpt_windres = [] - , sOpt_lo = [] - , sOpt_lc = [] - , sLdSupportsCompactUnwind = error "Haddock.ParserSpec.sLdSupportsCompactUnwind" - , sLdSupportsBuildId = error "Haddock.ParserSpec.sLdSupportsBuildId " - , sLdSupportsFilelist = error "Haddock.ParserSpec.sLdSupportsFilelist " - , sLdIsGnuLd = error "Haddock.ParserSpec.sLdIsGnuLd" - , sPlatformConstants = platformConstants - } - platform = Platform { - platformArch = ArchUnknown - , platformOS = OSUnknown - , platformWordSize = 64 - , platformHasGnuNonexecStack = False - , platformHasIdentDirective = False - , platformHasSubsectionsViaSymbols = False - , platformUnregisterised = error "Haddock.ParserSpec.platformUnregisterised" - } - - platformConstants = PlatformConstants { - pc_platformConstants = () - , pc_STD_HDR_SIZE = 0 - , pc_PROF_HDR_SIZE = 0 - , pc_BLOCK_SIZE = 0 - , pc_BLOCKS_PER_MBLOCK = 0 - , pc_OFFSET_StgRegTable_rR1 = 0 - , pc_OFFSET_StgRegTable_rR2 = 0 - , pc_OFFSET_StgRegTable_rR3 = 0 - , pc_OFFSET_StgRegTable_rR4 = 0 - , pc_OFFSET_StgRegTable_rR5 = 0 - , pc_OFFSET_StgRegTable_rR6 = 0 - , pc_OFFSET_StgRegTable_rR7 = 0 - , pc_OFFSET_StgRegTable_rR8 = 0 - , pc_OFFSET_StgRegTable_rR9 = 0 - , pc_OFFSET_StgRegTable_rR10 = 0 - , pc_OFFSET_StgRegTable_rF1 = 0 - , pc_OFFSET_StgRegTable_rF2 = 0 - , pc_OFFSET_StgRegTable_rF3 = 0 - , pc_OFFSET_StgRegTable_rF4 = 0 - , pc_OFFSET_StgRegTable_rF5 = 0 - , pc_OFFSET_StgRegTable_rF6 = 0 - , pc_OFFSET_StgRegTable_rD1 = 0 - , pc_OFFSET_StgRegTable_rD2 = 0 - , pc_OFFSET_StgRegTable_rD3 = 0 - , pc_OFFSET_StgRegTable_rD4 = 0 - , pc_OFFSET_StgRegTable_rD5 = 0 - , pc_OFFSET_StgRegTable_rD6 = 0 - , pc_OFFSET_StgRegTable_rXMM1 = 0 - , pc_OFFSET_StgRegTable_rXMM2 = 0 - , pc_OFFSET_StgRegTable_rXMM3 = 0 - , pc_OFFSET_StgRegTable_rXMM4 = 0 - , pc_OFFSET_StgRegTable_rXMM5 = 0 - , pc_OFFSET_StgRegTable_rXMM6 = 0 - , pc_OFFSET_StgRegTable_rL1 = 0 - , pc_OFFSET_StgRegTable_rSp = 0 - , pc_OFFSET_StgRegTable_rSpLim = 0 - , pc_OFFSET_StgRegTable_rHp = 0 - , pc_OFFSET_StgRegTable_rHpLim = 0 - , pc_OFFSET_StgRegTable_rCCCS = 0 - , pc_OFFSET_StgRegTable_rCurrentTSO = 0 - , pc_OFFSET_StgRegTable_rCurrentNursery = 0 - , pc_OFFSET_StgRegTable_rHpAlloc = 0 - , pc_OFFSET_stgEagerBlackholeInfo = 0 - , pc_OFFSET_stgGCEnter1 = 0 - , pc_OFFSET_stgGCFun = 0 - , pc_OFFSET_Capability_r = 0 - , pc_OFFSET_bdescr_start = 0 - , pc_OFFSET_bdescr_free = 0 - , pc_OFFSET_bdescr_blocks = 0 - , pc_SIZEOF_CostCentreStack = 0 - , pc_OFFSET_CostCentreStack_mem_alloc = 0 - , pc_REP_CostCentreStack_mem_alloc = 0 - , pc_OFFSET_CostCentreStack_scc_count = 0 - , pc_REP_CostCentreStack_scc_count = 0 - , pc_OFFSET_StgHeader_ccs = 0 - , pc_OFFSET_StgHeader_ldvw = 0 - , pc_SIZEOF_StgSMPThunkHeader = 0 - , pc_OFFSET_StgEntCounter_allocs = 0 - , pc_REP_StgEntCounter_allocs = 0 - , pc_OFFSET_StgEntCounter_allocd = 0 - , pc_REP_StgEntCounter_allocd = 0 - , pc_OFFSET_StgEntCounter_registeredp = 0 - , pc_OFFSET_StgEntCounter_link = 0 - , pc_OFFSET_StgEntCounter_entry_count = 0 - , pc_SIZEOF_StgUpdateFrame_NoHdr = 0 - , pc_SIZEOF_StgMutArrPtrs_NoHdr = 0 - , pc_OFFSET_StgMutArrPtrs_ptrs = 0 - , pc_OFFSET_StgMutArrPtrs_size = 0 - , pc_SIZEOF_StgArrWords_NoHdr = 0 - , pc_OFFSET_StgTSO_cccs = 0 - , pc_OFFSET_StgTSO_stackobj = 0 - , pc_OFFSET_StgStack_sp = 0 - , pc_OFFSET_StgStack_stack = 0 - , pc_OFFSET_StgUpdateFrame_updatee = 0 - , pc_SIZEOF_StgFunInfoExtraRev = 0 - , pc_MAX_SPEC_SELECTEE_SIZE = 0 - , pc_MAX_SPEC_AP_SIZE = 0 - , pc_MIN_PAYLOAD_SIZE = 0 - , pc_MIN_INTLIKE = 0 - , pc_MAX_INTLIKE = 0 - , pc_MIN_CHARLIKE = 0 - , pc_MAX_CHARLIKE = 0 - , pc_MUT_ARR_PTRS_CARD_BITS = 0 - , pc_MAX_Vanilla_REG = 0 - , pc_MAX_Float_REG = 0 - , pc_MAX_Double_REG = 0 - , pc_MAX_Long_REG = 0 - , pc_MAX_XMM_REG = 0 - , pc_MAX_Real_Vanilla_REG = 0 - , pc_MAX_Real_Float_REG = 0 - , pc_MAX_Real_Double_REG = 0 - , pc_MAX_Real_XMM_REG = 0 - , pc_MAX_Real_Long_REG = 0 - , pc_RESERVED_C_STACK_BYTES = 0 - , pc_RESERVED_STACK_WORDS = 0 - , pc_AP_STACK_SPLIM = 0 - , pc_WORD_SIZE = 0 - , pc_DOUBLE_SIZE = 0 - , pc_CINT_SIZE = 0 - , pc_CLONG_SIZE = 0 - , pc_CLONG_LONG_SIZE = 0 - , pc_BITMAP_BITS_SHIFT = 0 - , pc_TAG_BITS = 0 - , pc_WORDS_BIGENDIAN = False - , pc_DYNAMIC_BY_DEFAULT = False - , pc_LDV_SHIFT = 0 - , pc_ILDV_CREATE_MASK = 0 - , pc_ILDV_STATE_CREATE = 0 - , pc_ILDV_STATE_USE = 0 - , pc_OFFSET_StgRegTable_rYMM1 = 0 - , pc_OFFSET_StgRegTable_rYMM2 = 0 - , pc_OFFSET_StgRegTable_rYMM3 = 0 - , pc_OFFSET_StgRegTable_rYMM4 = 0 - , pc_OFFSET_StgRegTable_rYMM5 = 0 - , pc_OFFSET_StgRegTable_rYMM6 = 0 - , pc_OFFSET_StgRegTable_rZMM1 = 0 - , pc_OFFSET_StgRegTable_rZMM2 = 0 - , pc_OFFSET_StgRegTable_rZMM3 = 0 - , pc_OFFSET_StgRegTable_rZMM4 = 0 - , pc_OFFSET_StgRegTable_rZMM5 = 0 - , pc_OFFSET_StgRegTable_rZMM6 = 0 - , pc_OFFSET_StgFunInfoExtraFwd_arity = 0 - , pc_REP_StgFunInfoExtraFwd_arity = 0 - , pc_OFFSET_StgFunInfoExtraRev_arity = 0 - , pc_REP_StgFunInfoExtraRev_arity = 0 - } diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/vendor/attoparsec-0.10.4.0/Data/Attoparsec.hs b/vendor/attoparsec-0.10.4.0/Data/Attoparsec.hs deleted file mode 100644 --- a/vendor/attoparsec-0.10.4.0/Data/Attoparsec.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | --- Module : Data.Attoparsec --- Copyright : Bryan O'Sullivan 2007-2011 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient combinator parsing for 'ByteString' strings, --- loosely based on the Parsec library. - -module Data.Attoparsec - ( - module Data.Attoparsec.ByteString - ) where - -import Data.Attoparsec.ByteString diff --git a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString.hs b/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString.hs deleted file mode 100644 --- a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString.hs +++ /dev/null @@ -1,205 +0,0 @@ --- | --- Module : Data.Attoparsec.ByteString --- Copyright : Bryan O'Sullivan 2007-2011 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient combinator parsing for 'B.ByteString' strings, --- loosely based on the Parsec library. - -module Data.Attoparsec.ByteString - ( - -- * Differences from Parsec - -- $parsec - - -- * Incremental input - -- $incremental - - -- * Performance considerations - -- $performance - - -- * Parser types - I.Parser - , Result - , T.IResult(..) - , I.compareResults - - -- * Running parsers - , parse - , feed - , I.parseOnly - , parseWith - , parseTest - - -- ** Result conversion - , maybeResult - , eitherResult - - -- * Combinators - , (I.) - , I.try - , module Data.Attoparsec.Combinator - - -- * Parsing individual bytes - , I.word8 - , I.anyWord8 - , I.notWord8 - , I.peekWord8 - , I.satisfy - , I.satisfyWith - , I.skip - - -- ** Byte classes - , I.inClass - , I.notInClass - - -- * Efficient string handling - , I.string - , I.skipWhile - , I.take - , I.scan - , I.takeWhile - , I.takeWhile1 - , I.takeTill - - -- ** Consume all remaining input - , I.takeByteString - , I.takeLazyByteString - - -- * State observation and manipulation functions - , I.endOfInput - , I.atEnd - ) where - -import Data.Attoparsec.Combinator -import qualified Data.Attoparsec.ByteString.Internal as I -import qualified Data.Attoparsec.Internal as I -import qualified Data.ByteString as B -import Data.Attoparsec.ByteString.Internal (Result, parse) -import qualified Data.Attoparsec.Internal.Types as T - --- $parsec --- --- Compared to Parsec 3, Attoparsec makes several tradeoffs. It is --- not intended for, or ideal for, all possible uses. --- --- * While Attoparsec can consume input incrementally, Parsec cannot. --- Incremental input is a huge deal for efficient and secure network --- and system programming, since it gives much more control to users --- of the library over matters such as resource usage and the I/O --- model to use. --- --- * Much of the performance advantage of Attoparsec is gained via --- high-performance parsers such as 'I.takeWhile' and 'I.string'. --- If you use complicated combinators that return lists of bytes or --- characters, there is less performance difference between the two --- libraries. --- --- * Unlike Parsec 3, Attoparsec does not support being used as a --- monad transformer. --- --- * Attoparsec is specialised to deal only with strict 'B.ByteString' --- input. Efficiency concerns rule out both lists and lazy --- bytestrings. The usual use for lazy bytestrings would be to --- allow consumption of very large input without a large footprint. --- For this need, Attoparsec's incremental input provides an --- excellent substitute, with much more control over when input --- takes place. If you must use lazy bytestrings, see the 'Lazy' --- module, which feeds lazy chunks to a regular parser. --- --- * Parsec parsers can produce more helpful error messages than --- Attoparsec parsers. This is a matter of focus: Attoparsec avoids --- the extra book-keeping in favour of higher performance. - --- $incremental --- --- Attoparsec supports incremental input, meaning that you can feed it --- a bytestring that represents only part of the expected total amount --- of data to parse. If your parser reaches the end of a fragment of --- input and could consume more input, it will suspend parsing and --- return a 'T.Partial' continuation. --- --- Supplying the 'T.Partial' continuation with another bytestring will --- resume parsing at the point where it was suspended. You must be --- prepared for the result of the resumed parse to be another --- 'T.Partial' continuation. --- --- To indicate that you have no more input, supply the 'T.Partial' --- continuation with an empty bytestring. --- --- Remember that some parsing combinators will not return a result --- until they reach the end of input. They may thus cause 'T.Partial' --- results to be returned. --- --- If you do not need support for incremental input, consider using --- the 'I.parseOnly' function to run your parser. It will never --- prompt for more input. - --- $performance --- --- If you write an Attoparsec-based parser carefully, it can be --- realistic to expect it to perform within a factor of 2 of a --- hand-rolled C parser (measuring megabytes parsed per second). --- --- To actually achieve high performance, there are a few guidelines --- that it is useful to follow. --- --- Use the 'B.ByteString'-oriented parsers whenever possible, --- e.g. 'I.takeWhile1' instead of 'many1' 'I.anyWord8'. There is --- about a factor of 100 difference in performance between the two --- kinds of parser. --- --- For very simple byte-testing predicates, write them by hand instead --- of using 'I.inClass' or 'I.notInClass'. For instance, both of --- these predicates test for an end-of-line byte, but the first is --- much faster than the second: --- --- >endOfLine_fast w = w == 13 || w == 10 --- >endOfLine_slow = inClass "\r\n" --- --- Make active use of benchmarking and profiling tools to measure, --- find the problems with, and improve the performance of your parser. - --- | If a parser has returned a 'T.Partial' result, supply it with more --- input. -feed :: Result r -> B.ByteString -> Result r -feed f@(T.Fail _ _ _) _ = f -feed (T.Partial k) d = k d -feed (T.Done bs r) d = T.Done (B.append bs d) r -{-# INLINE feed #-} - --- | Run a parser and print its result to standard output. -parseTest :: (Show a) => I.Parser a -> B.ByteString -> IO () -parseTest p s = print (parse p s) - --- | Run a parser with an initial input string, and a monadic action --- that can supply more input if needed. -parseWith :: Monad m => - (m B.ByteString) - -- ^ An action that will be executed to provide the parser - -- with more input, if necessary. The action must return an - -- 'B.empty' string when there is no more input available. - -> I.Parser a - -> B.ByteString - -- ^ Initial input for the parser. - -> m (Result a) -parseWith refill p s = step $ parse p s - where step (T.Partial k) = (step . k) =<< refill - step r = return r -{-# INLINE parseWith #-} - --- | Convert a 'Result' value to a 'Maybe' value. A 'T.Partial' result --- is treated as failure. -maybeResult :: Result r -> Maybe r -maybeResult (T.Done _ r) = Just r -maybeResult _ = Nothing - --- | Convert a 'Result' value to an 'Either' value. A 'T.Partial' --- result is treated as failure. -eitherResult :: Result r -> Either String r -eitherResult (T.Done _ r) = Right r -eitherResult (T.Fail _ _ msg) = Left msg -eitherResult _ = Left "Result: incomplete input" diff --git a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Char8.hs b/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Char8.hs deleted file mode 100644 --- a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Char8.hs +++ /dev/null @@ -1,549 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, TypeFamilies, - TypeSynonymInstances, GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- Module : Data.Attoparsec.ByteString.Char8 --- Copyright : Bryan O'Sullivan 2007-2011 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient, character-oriented combinator parsing for --- 'B.ByteString' strings, loosely based on the Parsec library. - -module Data.Attoparsec.ByteString.Char8 - ( - -- * Character encodings - -- $encodings - - -- * Parser types - Parser - , A.Result - , A.IResult(..) - , I.compareResults - - -- * Running parsers - , A.parse - , A.feed - , A.parseOnly - , A.parseTest - , A.parseWith - - -- ** Result conversion - , A.maybeResult - , A.eitherResult - - -- * Combinators - , (I.) - , I.try - , module Data.Attoparsec.Combinator - - -- * Parsing individual characters - , char - , char8 - , anyChar - , notChar - , peekChar - , satisfy - - -- ** Special character parsers - , digit - , letter_iso8859_15 - , letter_ascii - , space - - -- ** Fast predicates - , isDigit - , isDigit_w8 - , isAlpha_iso8859_15 - , isAlpha_ascii - , isSpace - , isSpace_w8 - - -- *** Character classes - , inClass - , notInClass - - -- * Efficient string handling - , I.string - , stringCI - , skipSpace - , skipWhile - , I.take - , scan - , takeWhile - , takeWhile1 - , takeTill - - -- ** String combinators - -- $specalt - , (.*>) - , (<*.) - - -- ** Consume all remaining input - , I.takeByteString - , I.takeLazyByteString - - -- * Text parsing - , I.endOfLine - , isEndOfLine - , isHorizontalSpace - - -- * Numeric parsers - , decimal - , hexadecimal - , signed - , double - , Number(..) - , number - , rational - - -- * State observation and manipulation functions - , I.endOfInput - , I.atEnd - ) where - -import Control.Applicative ((*>), (<*), (<$>), (<|>)) -import Data.Attoparsec.ByteString.FastSet (charClass, memberChar) -import Data.Attoparsec.ByteString.Internal (Parser, ()) -import Data.Attoparsec.Combinator -import Data.Attoparsec.Number (Number(..)) -import Data.Bits (Bits, (.|.), shiftL) -import Data.ByteString.Internal (c2w, w2c) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Ratio ((%)) -import Data.String (IsString(..)) -import Data.Word (Word8, Word16, Word32, Word64, Word) -import Prelude hiding (takeWhile) -import qualified Data.Attoparsec.ByteString as A -import qualified Data.Attoparsec.ByteString.Internal as I -import qualified Data.Attoparsec.Internal as I -import qualified Data.ByteString as B8 -import qualified Data.ByteString.Char8 as B - -instance (a ~ B.ByteString) => IsString (Parser a) where - fromString = I.string . B.pack - --- $encodings --- --- This module is intended for parsing text that is --- represented using an 8-bit character set, e.g. ASCII or --- ISO-8859-15. It /does not/ make any attempt to deal with character --- encodings, multibyte characters, or wide characters. In --- particular, all attempts to use characters above code point U+00FF --- will give wrong answers. --- --- Code points below U+0100 are simply translated to and from their --- numeric values, so e.g. the code point U+00A4 becomes the byte --- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic --- currency sign in ISO-8859-1). Haskell 'Char' values above U+00FF --- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@. - --- ASCII-specific but fast, oh yes. -toLower :: Word8 -> Word8 -toLower w | w >= 65 && w <= 90 = w + 32 - | otherwise = w - --- | Satisfy a literal string, ignoring case. -stringCI :: B.ByteString -> Parser B.ByteString -stringCI = I.stringTransform (B8.map toLower) -{-# INLINE stringCI #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser requires the predicate to succeed on at least one byte --- of input: it will fail if the predicate never returns 'True' or if --- there is no input left. -takeWhile1 :: (Char -> Bool) -> Parser B.ByteString -takeWhile1 p = I.takeWhile1 (p . w2c) -{-# INLINE takeWhile1 #-} - --- | The parser @satisfy p@ succeeds for any byte for which the --- predicate @p@ returns 'True'. Returns the byte that is actually --- parsed. --- --- >digit = satisfy isDigit --- > where isDigit c = c >= '0' && c <= '9' -satisfy :: (Char -> Bool) -> Parser Char -satisfy = I.satisfyWith w2c -{-# INLINE satisfy #-} - --- | Match a letter, in the ISO-8859-15 encoding. -letter_iso8859_15 :: Parser Char -letter_iso8859_15 = satisfy isAlpha_iso8859_15 "letter_iso8859_15" -{-# INLINE letter_iso8859_15 #-} - --- | Match a letter, in the ASCII encoding. -letter_ascii :: Parser Char -letter_ascii = satisfy isAlpha_ascii "letter_ascii" -{-# INLINE letter_ascii #-} - --- | A fast alphabetic predicate for the ISO-8859-15 encoding --- --- /Note/: For all character encodings other than ISO-8859-15, and --- almost all Unicode code points above U+00A3, this predicate gives --- /wrong answers/. -isAlpha_iso8859_15 :: Char -> Bool -isAlpha_iso8859_15 c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || - (c >= '\166' && moby c) - where moby = notInClass "\167\169\171-\179\182\183\185\187\191\215\247" - {-# NOINLINE moby #-} -{-# INLINE isAlpha_iso8859_15 #-} - --- | A fast alphabetic predicate for the ASCII encoding --- --- /Note/: For all character encodings other than ASCII, and --- almost all Unicode code points above U+007F, this predicate gives --- /wrong answers/. -isAlpha_ascii :: Char -> Bool -isAlpha_ascii c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') -{-# INLINE isAlpha_ascii #-} - --- | Parse a single digit. -digit :: Parser Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | A fast digit predicate. -isDigit :: Char -> Bool -isDigit c = c >= '0' && c <= '9' -{-# INLINE isDigit #-} - --- | A fast digit predicate. -isDigit_w8 :: Word8 -> Bool -isDigit_w8 w = w >= 48 && w <= 57 -{-# INLINE isDigit_w8 #-} - --- | Match any character. -anyChar :: Parser Char -anyChar = satisfy $ const True -{-# INLINE anyChar #-} - --- | Match any character. Returns 'Nothing' if end of input has been --- reached. Does not consume any input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -peekChar :: Parser (Maybe Char) -peekChar = (fmap w2c) `fmap` I.peekWord8 -{-# INLINE peekChar #-} - --- | Fast predicate for matching ASCII space characters. --- --- /Note/: This predicate only gives correct answers for the ASCII --- encoding. For instance, it does not recognise U+00A0 (non-breaking --- space) as a space character, even though it is a valid ISO-8859-15 --- byte. For a Unicode-aware and only slightly slower predicate, --- use 'Data.Char.isSpace' -isSpace :: Char -> Bool -isSpace c = (c == ' ') || ('\t' <= c && c <= '\r') -{-# INLINE isSpace #-} - --- | Fast 'Word8' predicate for matching ASCII space characters. -isSpace_w8 :: Word8 -> Bool -isSpace_w8 w = (w == 32) || (9 <= w && w <= 13) -{-# INLINE isSpace_w8 #-} - - --- | Parse a space character. --- --- /Note/: This parser only gives correct answers for the ASCII --- encoding. For instance, it does not recognise U+00A0 (non-breaking --- space) as a space character, even though it is a valid ISO-8859-15 --- byte. -space :: Parser Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Match a specific character. -char :: Char -> Parser Char -char c = satisfy (== c) [c] -{-# INLINE char #-} - --- | Match a specific character, but return its 'Word8' value. -char8 :: Char -> Parser Word8 -char8 c = I.satisfy (== c2w c) [c] -{-# INLINE char8 #-} - --- | Match any character except the given one. -notChar :: Char -> Parser Char -notChar c = satisfy (/= c) "not " ++ [c] -{-# INLINE notChar #-} - --- | Match any character in a set. --- --- >vowel = inClass "aeiou" --- --- Range notation is supported. --- --- >halfAlphabet = inClass "a-nA-N" --- --- To add a literal \'-\' to a set, place it at the beginning or end --- of the string. -inClass :: String -> Char -> Bool -inClass s = (`memberChar` mySet) - where mySet = charClass s -{-# INLINE inClass #-} - --- | Match any character not in a set. -notInClass :: String -> Char -> Bool -notInClass s = not . inClass s -{-# INLINE notInClass #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'False' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -takeWhile :: (Char -> Bool) -> Parser B.ByteString -takeWhile p = I.takeWhile (p . w2c) -{-# INLINE takeWhile #-} - --- | A stateful scanner. The predicate consumes and transforms a --- state argument, and each transformed state is passed to successive --- invocations of the predicate on each byte of the input until one --- returns 'Nothing' or the input ends. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'Nothing' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -scan :: s -> (s -> Char -> Maybe s) -> Parser B.ByteString -scan s0 p = I.scan s0 (\s -> p s . w2c) -{-# INLINE scan #-} - --- | Consume input as long as the predicate returns 'False' --- (i.e. until it returns 'True'), and return the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'True' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -takeTill :: (Char -> Bool) -> Parser B.ByteString -takeTill p = I.takeTill (p . w2c) -{-# INLINE takeTill #-} - --- | Skip past input for as long as the predicate returns 'True'. -skipWhile :: (Char -> Bool) -> Parser () -skipWhile p = I.skipWhile (p . w2c) -{-# INLINE skipWhile #-} - --- | Skip over white space. -skipSpace :: Parser () -skipSpace = I.skipWhile isSpace_w8 -{-# INLINE skipSpace #-} - --- $specalt --- --- The '.*>' and '<*.' combinators are intended for use with the --- @OverloadedStrings@ language extension. They simplify the common --- task of matching a statically known string, then immediately --- parsing something else. --- --- An example makes this easier to understand: --- --- @{-\# LANGUAGE OverloadedStrings #-} --- --- shoeSize = \"Shoe size: \" '.*>' 'decimal' --- @ --- --- If we were to try to use '*>' above instead, the type checker would --- not be able to tell which 'IsString' instance to use for the text --- in quotes. We would have to be explicit, using either a type --- signature or the 'I.string' parser. - --- | Type-specialized version of '*>' for 'B.ByteString'. -(.*>) :: B.ByteString -> Parser a -> Parser a -s .*> f = I.string s *> f - --- | Type-specialized version of '<*' for 'B.ByteString'. -(<*.) :: Parser a -> B.ByteString -> Parser a -f <*. s = f <* I.string s - --- | A predicate that matches either a carriage return @\'\\r\'@ or --- newline @\'\\n\'@ character. -isEndOfLine :: Word8 -> Bool -isEndOfLine w = w == 13 || w == 10 -{-# INLINE isEndOfLine #-} - --- | A predicate that matches either a space @\' \'@ or horizontal tab --- @\'\\t\'@ character. -isHorizontalSpace :: Word8 -> Bool -isHorizontalSpace w = w == 32 || w == 9 -{-# INLINE isHorizontalSpace #-} - --- | Parse and decode an unsigned hexadecimal number. The hex digits --- @\'a\'@ through @\'f\'@ may be upper or lower case. --- --- This parser does not accept a leading @\"0x\"@ string. -hexadecimal :: (Integral a, Bits a) => Parser a -hexadecimal = B8.foldl' step 0 `fmap` I.takeWhile1 isHexDigit - where - isHexDigit w = (w >= 48 && w <= 57) || - (w >= 97 && w <= 102) || - (w >= 65 && w <= 70) - step a w | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48) - | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87) - | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55) -{-# SPECIALISE hexadecimal :: Parser Int #-} -{-# SPECIALISE hexadecimal :: Parser Int8 #-} -{-# SPECIALISE hexadecimal :: Parser Int16 #-} -{-# SPECIALISE hexadecimal :: Parser Int32 #-} -{-# SPECIALISE hexadecimal :: Parser Int64 #-} -{-# SPECIALISE hexadecimal :: Parser Integer #-} -{-# SPECIALISE hexadecimal :: Parser Word #-} -{-# SPECIALISE hexadecimal :: Parser Word8 #-} -{-# SPECIALISE hexadecimal :: Parser Word16 #-} -{-# SPECIALISE hexadecimal :: Parser Word32 #-} -{-# SPECIALISE hexadecimal :: Parser Word64 #-} - --- | Parse and decode an unsigned decimal number. -decimal :: Integral a => Parser a -decimal = B8.foldl' step 0 `fmap` I.takeWhile1 isDig - where isDig w = w >= 48 && w <= 57 - step a w = a * 10 + fromIntegral (w - 48) -{-# SPECIALISE decimal :: Parser Int #-} -{-# SPECIALISE decimal :: Parser Int8 #-} -{-# SPECIALISE decimal :: Parser Int16 #-} -{-# SPECIALISE decimal :: Parser Int32 #-} -{-# SPECIALISE decimal :: Parser Int64 #-} -{-# SPECIALISE decimal :: Parser Integer #-} -{-# SPECIALISE decimal :: Parser Word #-} -{-# SPECIALISE decimal :: Parser Word8 #-} -{-# SPECIALISE decimal :: Parser Word16 #-} -{-# SPECIALISE decimal :: Parser Word32 #-} -{-# SPECIALISE decimal :: Parser Word64 #-} - --- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign --- character. -signed :: Num a => Parser a -> Parser a -{-# SPECIALISE signed :: Parser Int -> Parser Int #-} -{-# SPECIALISE signed :: Parser Int8 -> Parser Int8 #-} -{-# SPECIALISE signed :: Parser Int16 -> Parser Int16 #-} -{-# SPECIALISE signed :: Parser Int32 -> Parser Int32 #-} -{-# SPECIALISE signed :: Parser Int64 -> Parser Int64 #-} -{-# SPECIALISE signed :: Parser Integer -> Parser Integer #-} -signed p = (negate <$> (char8 '-' *> p)) - <|> (char8 '+' *> p) - <|> p - --- | Parse a rational number. --- --- This parser accepts an optional leading sign character, followed by --- at least one decimal digit. The syntax similar to that accepted by --- the 'read' function, with the exception that a trailing @\'.\'@ or --- @\'e\'@ /not/ followed by a number is not consumed. --- --- Examples with behaviour identical to 'read', if you feed an empty --- continuation to the first result: --- --- >rational "3" == Done 3.0 "" --- >rational "3.1" == Done 3.1 "" --- >rational "3e4" == Done 30000.0 "" --- >rational "3.1e4" == Done 31000.0, "" --- --- Examples with behaviour identical to 'read': --- --- >rational ".3" == Fail "input does not start with a digit" --- >rational "e3" == Fail "input does not start with a digit" --- --- Examples of differences from 'read': --- --- >rational "3.foo" == Done 3.0 ".foo" --- >rational "3e" == Done 3.0 "e" --- --- This function does not accept string representations of \"NaN\" or --- \"Infinity\". -rational :: Fractional a => Parser a -{-# SPECIALIZE rational :: Parser Double #-} -{-# SPECIALIZE rational :: Parser Float #-} -{-# SPECIALIZE rational :: Parser Rational #-} -rational = floaty $ \real frac fracDenom -> fromRational $ - real % 1 + frac % fracDenom - --- | Parse a rational number. --- --- The syntax accepted by this parser is the same as for 'rational'. --- --- /Note/: This function is almost ten times faster than 'rational', --- but is slightly less accurate. --- --- The 'Double' type supports about 16 decimal places of accuracy. --- For 94.2% of numbers, this function and 'rational' give identical --- results, but for the remaining 5.8%, this function loses precision --- around the 15th decimal place. For 0.001% of numbers, this --- function will lose precision at the 13th or 14th decimal place. --- --- This function does not accept string representations of \"NaN\" or --- \"Infinity\". -double :: Parser Double -double = floaty asDouble - -asDouble :: Integer -> Integer -> Integer -> Double -asDouble real frac fracDenom = - fromIntegral real + fromIntegral frac / fromIntegral fracDenom -{-# INLINE asDouble #-} - --- | Parse a number, attempting to preserve both speed and precision. --- --- The syntax accepted by this parser is the same as for 'rational'. --- --- /Note/: This function is almost ten times faster than 'rational'. --- On integral inputs, it gives perfectly accurate answers, and on --- floating point inputs, it is slightly less accurate than --- 'rational'. --- --- This function does not accept string representations of \"NaN\" or --- \"Infinity\". -number :: Parser Number -number = floaty $ \real frac fracDenom -> - if frac == 0 && fracDenom == 0 - then I real - else D (asDouble real frac fracDenom) -{-# INLINE number #-} - -data T = T !Integer !Int - -floaty :: Fractional a => (Integer -> Integer -> Integer -> a) -> Parser a -{-# INLINE floaty #-} -floaty f = do - let minus = 45 - plus = 43 - !positive <- ((== plus) <$> I.satisfy (\c -> c == minus || c == plus)) <|> - return True - real <- decimal - let tryFraction = do - let dot = 46 - _ <- I.satisfy (==dot) - ds <- I.takeWhile isDigit_w8 - case I.parseOnly decimal ds of - Right n -> return $ T n (B.length ds) - _ -> fail "no digits after decimal" - T fraction fracDigits <- tryFraction <|> return (T 0 0) - let littleE = 101 - bigE = 69 - e w = w == littleE || w == bigE - power <- (I.satisfy e *> signed decimal) <|> return (0::Int) - let n = if fracDigits == 0 - then if power == 0 - then fromIntegral real - else fromIntegral real * (10 ^^ power) - else if power == 0 - then f real fraction (10 ^ fracDigits) - else f real fraction (10 ^ fracDigits) * (10 ^^ power) - return $ if positive - then n - else -n diff --git a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/FastSet.hs b/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/FastSet.hs deleted file mode 100644 --- a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/FastSet.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE BangPatterns, MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Attoparsec.ByteString.FastSet --- Copyright : Bryan O'Sullivan 2008 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Fast set membership tests for 'Word8' and 8-bit 'Char' values. The --- set representation is unboxed for efficiency. For small sets, we --- test for membership using a binary search. For larger sets, we use --- a lookup table. --- ------------------------------------------------------------------------------ -module Data.Attoparsec.ByteString.FastSet - ( - -- * Data type - FastSet - -- * Construction - , fromList - , set - -- * Lookup - , memberChar - , memberWord8 - -- * Debugging - , fromSet - -- * Handy interface - , charClass - ) where - -import Data.Bits ((.&.), (.|.)) -import Foreign.Storable (peekByteOff, pokeByteOff) -import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#) -import GHC.Word (Word8(W8#)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Internal as I -import qualified Data.ByteString.Unsafe as U - -data FastSet = Sorted { fromSet :: !B.ByteString } - | Table { fromSet :: !B.ByteString } - deriving (Eq, Ord) - -instance Show FastSet where - show (Sorted s) = "FastSet Sorted " ++ show (B8.unpack s) - show (Table _) = "FastSet Table" - --- | The lower bound on the size of a lookup table. We choose this to --- balance table density against performance. -tableCutoff :: Int -tableCutoff = 8 - --- | Create a set. -set :: B.ByteString -> FastSet -set s | B.length s < tableCutoff = Sorted . B.sort $ s - | otherwise = Table . mkTable $ s - -fromList :: [Word8] -> FastSet -fromList = set . B.pack - -data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8 - -shiftR :: Int -> Int -> Int -shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#) - -shiftL :: Word8 -> Int -> Word8 -shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#)) - -index :: Int -> I -index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7)) -{-# INLINE index #-} - --- | Check the set for membership. -memberWord8 :: Word8 -> FastSet -> Bool -memberWord8 w (Table t) = - let I byte bit = index (fromIntegral w) - in U.unsafeIndex t byte .&. bit /= 0 -memberWord8 w (Sorted s) = search 0 (B.length s - 1) - where search lo hi - | hi < lo = False - | otherwise = - let mid = (lo + hi) `div` 2 - in case compare w (U.unsafeIndex s mid) of - GT -> search (mid + 1) hi - LT -> search lo (mid - 1) - _ -> True - --- | Check the set for membership. Only works with 8-bit characters: --- characters above code point 255 will give wrong answers. -memberChar :: Char -> FastSet -> Bool -memberChar c = memberWord8 (I.c2w c) -{-# INLINE memberChar #-} - -mkTable :: B.ByteString -> B.ByteString -mkTable s = I.unsafeCreate 32 $ \t -> do - _ <- I.memset t 0 32 - U.unsafeUseAsCStringLen s $ \(p, l) -> - let loop n | n == l = return () - | otherwise = do - c <- peekByteOff p n :: IO Word8 - let I byte bit = index (fromIntegral c) - prev <- peekByteOff t byte :: IO Word8 - pokeByteOff t byte (prev .|. bit) - loop (n + 1) - in loop 0 - -charClass :: String -> FastSet -charClass = set . B8.pack . go - where go (a:'-':b:xs) = [a..b] ++ go xs - go (x:xs) = x : go xs - go _ = "" diff --git a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Internal.hs b/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Internal.hs deleted file mode 100644 --- a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/ByteString/Internal.hs +++ /dev/null @@ -1,516 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, Rank2Types, OverloadedStrings, - RecordWildCards, MagicHash, UnboxedTuples #-} --- | --- Module : Data.Attoparsec.ByteString.Internal --- Copyright : Bryan O'Sullivan 2007-2011 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : unknown --- --- Simple, efficient parser combinators for 'B.ByteString' strings, --- loosely based on the Parsec library. - -module Data.Attoparsec.ByteString.Internal - ( - -- * Parser types - Parser - , Result - - -- * Running parsers - , parse - , parseOnly - - -- * Combinators - , () - , try - , module Data.Attoparsec.Combinator - - -- * Parsing individual bytes - , satisfy - , satisfyWith - , anyWord8 - , skip - , word8 - , notWord8 - , peekWord8 - - -- ** Byte classes - , inClass - , notInClass - - -- * Parsing more complicated structures - , storable - - -- * Efficient string handling - , skipWhile - , string - , stringTransform - , take - , scan - , takeWhile - , takeWhile1 - , takeTill - - -- ** Consume all remaining input - , takeByteString - , takeLazyByteString - - -- * State observation and manipulation functions - , endOfInput - , atEnd - - -- * Utilities - , endOfLine - ) where - -import Control.Applicative ((<|>), (<$>)) -import Control.Monad (when) -import Data.Attoparsec.ByteString.FastSet (charClass, memberWord8) -import Data.Attoparsec.Combinator -import Data.Attoparsec.Internal.Types - hiding (Parser, Input, Added, Failure, Success) -import Data.Monoid (Monoid(..)) -import Data.Word (Word8) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (castPtr, minusPtr, plusPtr) -import Foreign.Storable (Storable(peek, sizeOf)) -import Prelude hiding (getChar, take, takeWhile) -import qualified Data.Attoparsec.Internal.Types as T -import qualified Data.ByteString as B8 -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Unsafe as B - -#if defined(__GLASGOW_HASKELL__) -import GHC.Base (realWorld#) -import GHC.IO (IO(IO)) -#else -import System.IO.Unsafe (unsafePerformIO) -#endif - -type Parser = T.Parser B.ByteString -type Result = IResult B.ByteString -type Input = T.Input B.ByteString -type Added = T.Added B.ByteString -type Failure r = T.Failure B.ByteString r -type Success a r = T.Success B.ByteString a r - -ensure' :: Int -> Input -> Added -> More -> Failure r -> Success B.ByteString r - -> IResult B.ByteString r -ensure' !n0 i0 a0 m0 kf0 ks0 = - T.runParser (demandInput >> go n0) i0 a0 m0 kf0 ks0 - where - go !n = T.Parser $ \i a m kf ks -> - if B.length (unI i) >= n - then ks i a m (unI i) - else T.runParser (demandInput >> go n) i a m kf ks - --- | If at least @n@ bytes of input are available, return the current --- input, otherwise fail. -ensure :: Int -> Parser B.ByteString -ensure !n = T.Parser $ \i0 a0 m0 kf ks -> - if B.length (unI i0) >= n - then ks i0 a0 m0 (unI i0) - -- The uncommon case is kept out-of-line to reduce code size: - else ensure' n i0 a0 m0 kf ks --- Non-recursive so the bounds check can be inlined: -{-# INLINE ensure #-} - --- | Ask for input. If we receive any, pass it to a success --- continuation, otherwise to a failure continuation. -prompt :: Input -> Added -> More - -> (Input -> Added -> More -> Result r) - -> (Input -> Added -> More -> Result r) - -> Result r -prompt i0 a0 _m0 kf ks = Partial $ \s -> - if B.null s - then kf i0 a0 Complete - else ks (i0 <> I s) (a0 <> A s) Incomplete - --- | Immediately demand more input via a 'Partial' continuation --- result. -demandInput :: Parser () -demandInput = T.Parser $ \i0 a0 m0 kf ks -> - if m0 == Complete - then kf i0 a0 m0 ["demandInput"] "not enough bytes" - else let kf' i a m = kf i a m ["demandInput"] "not enough bytes" - ks' i a m = ks i a m () - in prompt i0 a0 m0 kf' ks' - --- | This parser always succeeds. It returns 'True' if any input is --- available either immediately or on demand, and 'False' if the end --- of all input has been reached. -wantInput :: Parser Bool -wantInput = T.Parser $ \i0 a0 m0 _kf ks -> - case () of - _ | not (B.null (unI i0)) -> ks i0 a0 m0 True - | m0 == Complete -> ks i0 a0 m0 False - | otherwise -> let kf' i a m = ks i a m False - ks' i a m = ks i a m True - in prompt i0 a0 m0 kf' ks' - -get :: Parser B.ByteString -get = T.Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0) - -put :: B.ByteString -> Parser () -put s = T.Parser $ \_i0 a0 m0 _kf ks -> ks (I s) a0 m0 () - --- | Attempt a parse, and if it fails, rewind the input so that no --- input appears to have been consumed. --- --- This combinator is provided for compatibility with Parsec. --- Attoparsec parsers always backtrack on failure. -try :: Parser a -> Parser a -try p = p -{-# INLINE try #-} - --- | The parser @satisfy p@ succeeds for any byte for which the --- predicate @p@ returns 'True'. Returns the byte that is actually --- parsed. --- --- >digit = satisfy isDigit --- > where isDigit w = w >= 48 && w <= 57 -satisfy :: (Word8 -> Bool) -> Parser Word8 -satisfy p = do - s <- ensure 1 - let !w = B.unsafeHead s - if p w - then put (B.unsafeTail s) >> return w - else fail "satisfy" -{-# INLINE satisfy #-} - --- | The parser @skip p@ succeeds for any byte for which the predicate --- @p@ returns 'True'. --- --- >skipDigit = skip isDigit --- > where isDigit w = w >= 48 && w <= 57 -skip :: (Word8 -> Bool) -> Parser () -skip p = do - s <- ensure 1 - if p (B.unsafeHead s) - then put (B.unsafeTail s) - else fail "skip" - --- | The parser @satisfyWith f p@ transforms a byte, and succeeds if --- the predicate @p@ returns 'True' on the transformed value. The --- parser returns the transformed byte that was parsed. -satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Parser a -satisfyWith f p = do - s <- ensure 1 - let c = f $! B.unsafeHead s - if p c - then let !t = B.unsafeTail s - in put t >> return c - else fail "satisfyWith" -{-# INLINE satisfyWith #-} - -storable :: Storable a => Parser a -storable = hack undefined - where - hack :: Storable b => b -> Parser b - hack dummy = do - (fp,o,_) <- B.toForeignPtr `fmap` take (sizeOf dummy) - return . B.inlinePerformIO . withForeignPtr fp $ \p -> - peek (castPtr $ p `plusPtr` o) - --- | Consume @n@ bytes of input, but succeed only if the predicate --- returns 'True'. -takeWith :: Int -> (B.ByteString -> Bool) -> Parser B.ByteString -takeWith n0 p = do - let n = max n0 0 - s <- ensure n - let h = B.unsafeTake n s - t = B.unsafeDrop n s - if p h - then put t >> return h - else fail "takeWith" - --- | Consume exactly @n@ bytes of input. -take :: Int -> Parser B.ByteString -take n = takeWith n (const True) -{-# INLINE take #-} - --- | @string s@ parses a sequence of bytes that identically match --- @s@. Returns the parsed string (i.e. @s@). This parser consumes no --- input if it fails (even if a partial match). --- --- /Note/: The behaviour of this parser is different to that of the --- similarly-named parser in Parsec, as this one is all-or-nothing. --- To illustrate the difference, the following parser will fail under --- Parsec given an input of @\"for\"@: --- --- >string "foo" <|> string "for" --- --- The reason for its failure is that the first branch is a --- partial match, and will consume the letters @\'f\'@ and @\'o\'@ --- before failing. In Attoparsec, the above parser will /succeed/ on --- that input, because the failed first branch will consume nothing. -string :: B.ByteString -> Parser B.ByteString -string s = takeWith (B.length s) (==s) -{-# INLINE string #-} - -stringTransform :: (B.ByteString -> B.ByteString) -> B.ByteString - -> Parser B.ByteString -stringTransform f s = takeWith (B.length s) ((==f s) . f) -{-# INLINE stringTransform #-} - --- | Skip past input for as long as the predicate returns 'True'. -skipWhile :: (Word8 -> Bool) -> Parser () -skipWhile p = go - where - go = do - t <- B8.dropWhile p <$> get - put t - when (B.null t) $ do - input <- wantInput - when input go -{-# INLINE skipWhile #-} - --- | Consume input as long as the predicate returns 'False' --- (i.e. until it returns 'True'), and return the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'True' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -takeTill :: (Word8 -> Bool) -> Parser B.ByteString -takeTill p = takeWhile (not . p) -{-# INLINE takeTill #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'False' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -takeWhile :: (Word8 -> Bool) -> Parser B.ByteString -takeWhile p = (B.concat . reverse) `fmap` go [] - where - go acc = do - (h,t) <- B8.span p <$> get - put t - if B.null t - then do - input <- wantInput - if input - then go (h:acc) - else return (h:acc) - else return (h:acc) -{-# INLINE takeWhile #-} - -takeRest :: Parser [B.ByteString] -takeRest = go [] - where - go acc = do - input <- wantInput - if input - then do - s <- get - put B.empty - go (s:acc) - else return (reverse acc) - --- | Consume all remaining input and return it as a single string. -takeByteString :: Parser B.ByteString -takeByteString = B.concat `fmap` takeRest - --- | Consume all remaining input and return it as a single string. -takeLazyByteString :: Parser L.ByteString -takeLazyByteString = L.fromChunks `fmap` takeRest - -data T s = T {-# UNPACK #-} !Int s - --- | A stateful scanner. The predicate consumes and transforms a --- state argument, and each transformed state is passed to successive --- invocations of the predicate on each byte of the input until one --- returns 'Nothing' or the input ends. --- --- This parser does not fail. It will return an empty string if the --- predicate returns 'Nothing' on the first byte of input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -scan :: s -> (s -> Word8 -> Maybe s) -> Parser B.ByteString -scan s0 p = do - chunks <- go [] s0 - case chunks of - [x] -> return x - xs -> return $! B.concat $ reverse xs - where - go acc s1 = do - let scanner (B.PS fp off len) = - withForeignPtr fp $ \ptr0 -> do - let start = ptr0 `plusPtr` off - end = start `plusPtr` len - inner ptr !s - | ptr < end = do - w <- peek ptr - case p s w of - Just s' -> inner (ptr `plusPtr` 1) s' - _ -> done (ptr `minusPtr` start) s - | otherwise = done (ptr `minusPtr` start) s - done !i !s = return (T i s) - inner start s1 - bs <- get - let T i s' = inlinePerformIO $ scanner bs - !h = B.unsafeTake i bs - !t = B.unsafeDrop i bs - put t - if B.null t - then do - input <- wantInput - if input - then go (h:acc) s' - else return (h:acc) - else return (h:acc) -{-# INLINE scan #-} - --- | Consume input as long as the predicate returns 'True', and return --- the consumed input. --- --- This parser requires the predicate to succeed on at least one byte --- of input: it will fail if the predicate never returns 'True' or if --- there is no input left. -takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString -takeWhile1 p = do - (`when` demandInput) =<< B.null <$> get - (h,t) <- B8.span p <$> get - when (B.null h) $ fail "takeWhile1" - put t - if B.null t - then (h<>) `fmap` takeWhile p - else return h - --- | Match any byte in a set. --- --- >vowel = inClass "aeiou" --- --- Range notation is supported. --- --- >halfAlphabet = inClass "a-nA-N" --- --- To add a literal @\'-\'@ to a set, place it at the beginning or end --- of the string. -inClass :: String -> Word8 -> Bool -inClass s = (`memberWord8` mySet) - where mySet = charClass s - {-# NOINLINE mySet #-} -{-# INLINE inClass #-} - --- | Match any byte not in a set. -notInClass :: String -> Word8 -> Bool -notInClass s = not . inClass s -{-# INLINE notInClass #-} - --- | Match any byte. -anyWord8 :: Parser Word8 -anyWord8 = satisfy $ const True -{-# INLINE anyWord8 #-} - --- | Match a specific byte. -word8 :: Word8 -> Parser Word8 -word8 c = satisfy (== c) show c -{-# INLINE word8 #-} - --- | Match any byte except the given one. -notWord8 :: Word8 -> Parser Word8 -notWord8 c = satisfy (/= c) "not " ++ show c -{-# INLINE notWord8 #-} - --- | Match any byte. Returns 'Nothing' if end of input has been --- reached. Does not consume any input. --- --- /Note/: Because this parser does not fail, do not use it with --- combinators such as 'many', because such parsers loop until a --- failure occurs. Careless use will thus result in an infinite loop. -peekWord8 :: Parser (Maybe Word8) -peekWord8 = T.Parser $ \i0 a0 m0 _kf ks -> - if B.null (unI i0) - then if m0 == Complete - then ks i0 a0 m0 Nothing - else let ks' i a m = let !w = B.unsafeHead (unI i) - in ks i a m (Just w) - kf' i a m = ks i a m Nothing - in prompt i0 a0 m0 kf' ks' - else let !w = B.unsafeHead (unI i0) - in ks i0 a0 m0 (Just w) -{-# INLINE peekWord8 #-} - --- | Match only if all input has been consumed. -endOfInput :: Parser () -endOfInput = T.Parser $ \i0 a0 m0 kf ks -> - if B.null (unI i0) - then if m0 == Complete - then ks i0 a0 m0 () - else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $ - \ i2 a2 m2 -> ks i2 a2 m2 () - ks' i1 a1 m1 _ = addS i0 a0 m0 i1 a1 m1 $ - \ i2 a2 m2 -> kf i2 a2 m2 [] - "endOfInput" - in T.runParser demandInput i0 a0 m0 kf' ks' - else kf i0 a0 m0 [] "endOfInput" - --- | Return an indication of whether the end of input has been --- reached. -atEnd :: Parser Bool -atEnd = not <$> wantInput -{-# INLINE atEnd #-} - --- | Match either a single newline character @\'\\n\'@, or a carriage --- return followed by a newline character @\"\\r\\n\"@. -endOfLine :: Parser () -endOfLine = (word8 10 >> return ()) <|> (string "\r\n" >> return ()) - --- | Name the parser, in case failure occurs. -() :: Parser a - -> String -- ^ the name to use if parsing fails - -> Parser a -p msg0 = T.Parser $ \i0 a0 m0 kf ks -> - let kf' i a m strs msg = kf i a m (msg0:strs) msg - in T.runParser p i0 a0 m0 kf' ks -{-# INLINE () #-} -infix 0 - --- | Terminal failure continuation. -failK :: Failure a -failK i0 _a0 _m0 stack msg = Fail (unI i0) stack msg -{-# INLINE failK #-} - --- | Terminal success continuation. -successK :: Success a a -successK i0 _a0 _m0 a = Done (unI i0) a -{-# INLINE successK #-} - --- | Run a parser. -parse :: Parser a -> B.ByteString -> Result a -parse m s = T.runParser m (I s) mempty Incomplete failK successK -{-# INLINE parse #-} - --- | Run a parser that cannot be resupplied via a 'Partial' result. -parseOnly :: Parser a -> B.ByteString -> Either String a -parseOnly m s = case T.runParser m (I s) mempty Complete failK successK of - Fail _ _ err -> Left err - Done _ a -> Right a - _ -> error "parseOnly: impossible error!" -{-# INLINE parseOnly #-} - --- | Just like unsafePerformIO, but we inline it. Big performance gains as --- it exposes lots of things to further inlining. /Very unsafe/. In --- particular, you should do no memory allocation inside an --- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@. -inlinePerformIO :: IO a -> a -#if defined(__GLASGOW_HASKELL__) -inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -#else -inlinePerformIO = unsafePerformIO -#endif -{-# INLINE inlinePerformIO #-} diff --git a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/Combinator.hs b/vendor/attoparsec-0.10.4.0/Data/Attoparsec/Combinator.hs deleted file mode 100644 --- a/vendor/attoparsec-0.10.4.0/Data/Attoparsec/Combinator.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP #-} --- | --- Module : Data.Attoparsec.Combinator --- Copyright : Daan Leijen 1999-2001, Bryan O'Sullivan 2009-2010 --- License : BSD3 --- --- Maintainer : bos@serpentine.com --- Stability : experimental --- Portability : portable --- --- Useful parser combinators, similar to those provided by Parsec. -module Data.Attoparsec.Combinator - ( - choice - , count - , option - , many' - , many1 - , many1' - , manyTill - , manyTill' - , sepBy - , sepBy' - , sepBy1 - , sepBy1' - , skipMany - , skipMany1 - , eitherP - ) where - -import Control.Applicative (Alternative(..), Applicative(..), empty, liftA2, - (<|>), (*>), (<$>)) -import Control.Monad (MonadPlus(..)) -#if !MIN_VERSION_base(4,2,0) -import Control.Applicative (many) -#endif - -#if __GLASGOW_HASKELL__ >= 700 -import Data.Attoparsec.Internal.Types (Parser) -import Data.ByteString (ByteString) -#endif - --- | @choice ps@ tries to apply the actions in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- action. -choice :: Alternative f => [f a] -> f a -choice = foldr (<|>) empty -#if __GLASGOW_HASKELL__ >= 700 -{-# SPECIALIZE choice :: [Parser ByteString a] -> Parser ByteString a #-} -#endif - --- | @option x p@ tries to apply action @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (digitToInt <$> digit) -option :: Alternative f => a -> f a -> f a -option x p = p <|> pure x -#if __GLASGOW_HASKELL__ >= 700 -{-# SPECIALIZE option :: a -> Parser ByteString a -> Parser ByteString a #-} -#endif - --- | A version of 'liftM2' that is strict in the result of its first --- action. -liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c -liftM2' f a b = do - !x <- a - y <- b - return (f x y) -{-# INLINE liftM2' #-} - --- | @many' p@ applies the action @p@ /zero/ or more times. Returns a --- list of the returned values of @p@. The value returned by @p@ is --- forced to WHNF. --- --- > word = many' letter -many' :: (MonadPlus m) => m a -> m [a] -many' p = many_p - where many_p = some_p `mplus` return [] - some_p = liftM2' (:) p many_p -{-# INLINE many' #-} - --- | @many1 p@ applies the action @p@ /one/ or more times. Returns a --- list of the returned values of @p@. --- --- > word = many1 letter -many1 :: Alternative f => f a -> f [a] -many1 p = liftA2 (:) p (many p) -{-# INLINE many1 #-} - --- | @many1' p@ applies the action @p@ /one/ or more times. Returns a --- list of the returned values of @p@. The value returned by @p@ is --- forced to WHNF. --- --- > word = many1' letter -many1' :: (MonadPlus m) => m a -> m [a] -many1' p = liftM2' (:) p (many' p) -{-# INLINE many1' #-} - --- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. --- --- > commaSep p = p `sepBy` (symbol ",") -sepBy :: Alternative f => f a -> f s -> f [a] -sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure [] -#if __GLASGOW_HASKELL__ >= 700 -{-# SPECIALIZE sepBy :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} -#endif - --- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. The value --- returned by @p@ is forced to WHNF. --- --- > commaSep p = p `sepBy'` (symbol ",") -sepBy' :: (MonadPlus m) => m a -> m s -> m [a] -sepBy' p s = scan `mplus` return [] - where scan = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return []) -#if __GLASGOW_HASKELL__ >= 700 -{-# SPECIALIZE sepBy' :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} -#endif - --- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. --- --- > commaSep p = p `sepBy1` (symbol ",") -sepBy1 :: Alternative f => f a -> f s -> f [a] -sepBy1 p s = scan - where scan = liftA2 (:) p ((s *> scan) <|> pure []) -#if __GLASGOW_HASKELL__ >= 700 -{-# SPECIALIZE sepBy1 :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} -#endif - --- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated --- by @sep@. Returns a list of the values returned by @p@. The value --- returned by @p@ is forced to WHNF. --- --- > commaSep p = p `sepBy1'` (symbol ",") -sepBy1' :: (MonadPlus m) => m a -> m s -> m [a] -sepBy1' p s = scan - where scan = liftM2' (:) p ((s >> scan) `mplus` return []) -#if __GLASGOW_HASKELL__ >= 700 -{-# SPECIALIZE sepBy1' :: Parser ByteString a -> Parser ByteString s - -> Parser ByteString [a] #-} -#endif - --- | @manyTill p end@ applies action @p@ /zero/ or more times until --- action @end@ succeeds, and returns the list of values returned by --- @p@. This can be used to scan comments: --- --- > simpleComment = string "")) --- --- Note the overlapping parsers @anyChar@ and @string \"")) --- --- Note the overlapping parsers @anyChar@ and @string \"