diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,43 @@ +Changes in version 2.8.0 + + * HTML backend completely rewritten to generate semantically rich XHTML + using the xhtml package. + + * New default CSS based on the color scheme chosen for the new Haskell + wiki, with a pull-out tab for the synopsis. + + * Theme engine based on CSS files. Themes can be switched from the + header menu. (New flags --built-in-themes and --theme. The latter + is an alias for --css which now has extended semantics). + + * Markup support for executable examples/unit-tests. To be used with an + upcoming version of the DocTest program. + + * Addition of a LaTeX backend. + + * Frames-mode can be enabled from the header menu. + + * Path to source entities can be specified per package, so that source + links work for cross-package documentation. + + * Support for a second form of enumerated lists (1. 2. etc). + + * Additions and changes to the Haddock API. + + * New flag --no-tmp-comp-dir to tell Haddock to write and pick up + compilation files (.o, .hi, etc) to/from GHC's output directory instead + of a temporary directory. + + * Various bug fixes. + +----------------------------------------------------------------------------- + +Changes in version 2.6.1 (bug fix release from the stable branch) + + * Fix #128 + +----------------------------------------------------------------------------- + Changes in version 2.7.2 * Add Paths_haddock to library diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2002, Simon Marlow. All rights reserved. +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: diff --git a/dist/build/haddock/haddock-tmp/Haddock/Lex.hs b/dist/build/haddock/haddock-tmp/Haddock/Lex.hs --- a/dist/build/haddock/haddock-tmp/Haddock/Lex.hs +++ b/dist/build/haddock/haddock-tmp/Haddock/Lex.hs @@ -10,6 +10,7 @@ module Haddock.Lex ( Token(..), + LToken, tokenise ) where @@ -42,21 +43,133 @@ #else import GlaExts #endif +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/wrappers.hs" #-} +-- ----------------------------------------------------------------------------- +-- Alex wrapper code. +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +{-# LINE 18 "templates/wrappers.hs" #-} + +-- ----------------------------------------------------------------------------- +-- The input type + + +type AlexInput = (AlexPosn, -- current position, + Char, -- previous char + String) -- current input string + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (p,c,s) = c + +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar (p,c,[]) = Nothing +alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq` + Just (c, (p', c, s)) + + +{-# LINE 51 "templates/wrappers.hs" #-} + +-- ----------------------------------------------------------------------------- +-- Token positions + +-- `Posn' records the location of a token in the input text. It has three +-- fields: the address (number of chacaters preceding the token), line number +-- and column of a token within the file. `start_pos' gives the position of the +-- start of the file and `eof_pos' a standard encoding for the end of file. +-- `move_pos' calculates the new position after traversing a given character, +-- assuming the usual eight character tab stops. + + +data AlexPosn = AlexPn !Int !Int !Int + deriving (Eq,Show) + +alexStartPos :: AlexPosn +alexStartPos = AlexPn 0 1 1 + +alexMove :: AlexPosn -> Char -> AlexPosn +alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1) +alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1 +alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1) + + +-- ----------------------------------------------------------------------------- +-- Default monad + +{-# LINE 162 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Monad (with ByteString input) + +{-# LINE 251 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper + +{-# LINE 273 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Basic wrapper, ByteString version + +{-# LINE 297 "templates/wrappers.hs" #-} + +{-# LINE 322 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper + +-- Adds text positions to the basic model. + + +--alexScanTokens :: String -> [token] +alexScanTokens str = go (alexStartPos,'\n',str) + where go inp@(pos,_,str) = + case alexScan inp 0 of + AlexEOF -> [] + AlexError _ -> error "lexical error" + AlexSkip inp' len -> go inp' + AlexToken inp' len act -> act pos (take len str) : go inp' + + + +-- ----------------------------------------------------------------------------- +-- Posn wrapper, ByteString version + +{-# LINE 354 "templates/wrappers.hs" #-} + + +-- ----------------------------------------------------------------------------- +-- GScan wrapper + +-- For compatibility with previous versions of Alex, and because we can. + alex_base :: AlexAddr -alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\x01\x00\x00\x00\x06\x00\x00\x00\x11\x00\x00\x00\x23\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xff\xff\xff\x00\x00\x00\x00\xfe\xff\xff\xff\x02\x00\x00\x00\x04\x00\x00\x00\x0a\x00\x00\x00\x0f\x00\x00\x00\x22\x00\x00\x00\x24\x00\x00\x00\x0c\x00\x00\x00\x15\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\xf9\x00\x00\x00\x55\x01\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x7d\x00\x00\x00\xa4\x01\x00\x00\xe7\xff\xff\xff\x00\x00\x00\x00\xae\x01\x00\x00\xd4\x01\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\x11\x00\x00\x00\xfe\xff\xff\xff\x02\x00\x00\x00\x03\x00\x00\x00\x06\x00\x00\x00\x4b\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\xd0\xff\xff\xff\x00\x00\x00\x00\xd6\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x00\x00\xd7\xff\xff\xff\xd4\x00\x00\x00\x00\x00\x00\x00\xd8\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\xdb\xff\xff\xff\xdc\xff\xff\xff\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xff\xff\xff\x28\x00\x00\x00\x2b\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x4c\x01\x00\x00\xa8\x01\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xd3\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\xf7\x01\x00\x00\x0e\x02\x00\x00\x00\x00\x00\x00\x27\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\x13\x00\x13\x00\xff\xff\xff\xff\x2b\x00\x30\x00\xff\xff\xff\xff\xff\xff\x11\x00\x12\x00\x11\x00\x11\x00\x11\x00\xff\xff\x00\x00\xff\xff\x00\x00\x09\x00\xff\xff\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\xff\xff\x0f\x00\xff\xff\x0b\x00\x15\x00\x1e\x00\x0b\x00\x11\x00\x2c\x00\x26\x00\xff\xff\x00\x00\x00\x00\xff\xff\x30\x00\xff\xff\x1d\x00\x21\x00\x09\x00\x20\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x1d\x00\x0f\x00\x1d\x00\x0b\x00\x16\x00\x1a\x00\x0b\x00\x00\x00\x16\x00\x15\x00\x17\x00\x00\x00\x10\x00\x15\x00\x1e\x00\x00\x00\x17\x00\x2c\x00\x26\x00\x18\x00\x00\x00\x1b\x00\x20\x00\x0a\x00\x00\x00\x00\x00\x21\x00\x0c\x00\x08\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x32\x00\x1a\x00\x1b\x00\x26\x00\x1b\x00\x15\x00\x08\x00\x07\x00\x08\x00\x08\x00\x08\x00\x00\x00\x00\x00\x08\x00\x0c\x00\x09\x00\x07\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x28\x00\x33\x00\x00\x00\x00\x00\x26\x00\x09\x00\x11\x00\x12\x00\x11\x00\x11\x00\x11\x00\x00\x00\x0d\x00\x0f\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x0b\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x29\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x25\x00\x0c\x00\x25\x00\x25\x00\x25\x00\x25\x00\x24\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x23\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x24\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x23\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x00\x00\x25\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x30\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +alex_table = AlexA# "\x00\x00\x0a\x00\x09\x00\x0a\x00\x0a\x00\x0a\x00\x1a\x00\x1d\x00\x1c\x00\x1d\x00\x1d\x00\x1d\x00\x21\x00\x23\x00\x0d\x00\x16\x00\x19\x00\x16\x00\x16\x00\x16\x00\x0c\x00\x18\x00\x17\x00\x1a\x00\x0a\x00\x1e\x00\x1f\x00\x40\x00\x21\x00\x23\x00\x1d\x00\x26\x00\x12\x00\xff\xff\x0e\x00\xff\xff\xff\xff\x0e\x00\x16\x00\xff\xff\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\xff\xff\x25\x00\x2e\x00\xff\xff\x0b\x00\x3c\x00\x36\x00\xff\xff\x2d\x00\x3b\x00\x20\x00\x2d\x00\xff\xff\x00\x00\x31\x00\x00\x00\xff\xff\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x30\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x25\x00\x10\x00\x0f\x00\x0a\x00\x09\x00\x0a\x00\x0a\x00\x0a\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x27\x00\x00\x00\x0a\x00\x00\x00\x38\x00\x42\x00\x40\x00\x28\x00\x36\x00\x2b\x00\x12\x00\x00\x00\x0e\x00\x2b\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x25\x00\x2e\x00\x0b\x00\x00\x00\x3c\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x25\x00\x0f\x00\x0a\x00\x09\x00\x0a\x00\x0a\x00\x0a\x00\x13\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x38\x00\x43\x00\x00\x00\x00\x00\x36\x00\x12\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x16\x00\x19\x00\x16\x00\x16\x00\x16\x00\x00\x00\x1d\x00\x1c\x00\x1d\x00\x1d\x00\x1d\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x39\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x15\x00\x35\x00\x35\x00\x35\x00\x35\x00\x34\x00\x20\x00\x00\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x3f\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x3f\x00\x35\x00\x00\x00\x35\x00\x35\x00\x33\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x34\x00\x00\x00\x00\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x33\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x00\x00\x35\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x40\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\xff\xff\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\xff\xff\x0a\x00\xff\xff\x20\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x28\x00\x0a\x00\x2a\x00\x22\x00\x23\x00\x2d\x00\x20\x00\x26\x00\x27\x00\x0a\x00\xff\xff\xff\xff\x0a\x00\x0a\x00\x0a\x00\x23\x00\x2f\x00\x20\x00\x2f\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\x23\x00\x28\x00\x23\x00\x2a\x00\x3e\x00\x3c\x00\x2d\x00\xff\xff\x3e\x00\x40\x00\x3e\x00\xff\xff\x3e\x00\x22\x00\x23\x00\xff\xff\x3e\x00\x26\x00\x27\x00\x3c\x00\xff\xff\x3e\x00\x2f\x00\x3e\x00\xff\xff\xff\xff\x2f\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x3c\x00\x3e\x00\x60\x00\x3e\x00\x40\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x20\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\x20\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x29\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\x21\x00\x5b\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x3e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x3e\x00\x3e\x00\x0a\x00\x20\x00\x3e\x00\x3e\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x3e\x00\x28\x00\x0a\x00\x2a\x00\x0a\x00\x0a\x00\x2d\x00\x20\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\x3e\x00\x26\x00\x27\x00\x0a\x00\x23\x00\x23\x00\x3e\x00\x23\x00\x0a\x00\xff\xff\x2f\x00\xff\xff\x0a\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\x2f\x00\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\x29\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x3e\x00\xff\xff\x20\x00\xff\xff\x5c\x00\x5d\x00\x0a\x00\x3c\x00\x60\x00\x3e\x00\x28\x00\xff\xff\x2a\x00\x3e\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x22\x00\x23\x00\x3e\x00\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\x5b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\x3e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x3e\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x58\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x78\x00\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x22\x00\x23\x00\xff\xff\xff\xff\x26\x00\x27\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x2f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\x14\x00\x31\x00\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x19\x00\x19\x00\x19\x00\x19\x00\x1c\x00\x1c\x00\x1c\x00\x1f\x00\x1f\x00\x1f\x00\xff\xff\x22\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\xff\xff\xff\xff"# +alex_deflt = AlexA# "\xff\xff\x1b\x00\x41\x00\xff\xff\x22\x00\x24\x00\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x29\x00\x29\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\x2f\x00\x2f\x00\xff\xff\x32\x00\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff"# -alex_accept = listArray (0::Int,51) [[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_5))],[],[],[(AlexAccSkip)],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_12))],[],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_19))],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_19))],[],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_15))],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_17))],[],[],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_18))],[],[],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))]] -{-# LINE 96 "src/Haddock/Lex.x" #-} +alex_accept = listArray (0::Int,67) [[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_15))],[],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_7))],[],[(AlexAccSkip)],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_8))],[],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))],[],[(AlexAcc (alex_action_14))],[],[],[(AlexAcc (alex_action_16))],[],[(AlexAcc (alex_action_17))],[],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_20))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_20))],[],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_23))],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_25))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_30))],[(AlexAcc (alex_action_31))]] +{-# LINE 112 "src/Haddock/Lex.x" #-} +-- | A located token +type LToken = (Token, AlexPosn) + data Token = TokPara | TokNumber @@ -71,98 +184,115 @@ | TokEmphasis String | TokAName String | TokBirdTrack String + | TokExamplePrompt String + | TokExampleExpression String + | TokExampleResult String -- deriving Show +tokenPos :: LToken -> (Int, Int) +tokenPos t = let AlexPn _ line col = snd t in (line, col) + -- ----------------------------------------------------------------------------- -- Alex support stuff type StartCode = Int -type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] - -type AlexInput = (Char,String) - -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) +type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken] -alexInputPrevChar (c,_) = c +tokenise :: DynFlags -> String -> (Int, Int) -> [LToken] +tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks + where + posn = AlexPn 0 line col -tokenise :: String -> [Token] -tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks - where go inp@(_,str) sc = + go inp@(pos, _, str) sc = case alexScan inp sc of AlexEOF -> [] AlexError _ -> error "lexical error" AlexSkip inp' _ -> go inp' sc - AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) + AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags -- NB. we add a final \n to the string, (see comment in the beginning of line -- production above). eofHack str = str++"\n" andBegin :: Action -> StartCode -> Action -andBegin act new_sc = \str _ cont -> act str new_sc cont +andBegin act new_sc = \pos str _ cont dflags -> act pos str new_sc cont dflags token :: Token -> Action -token t = \_ sc cont -> t : cont sc +token t = \pos _ sc cont _ -> (t, pos) : cont sc strtoken, strtokenNL :: (String -> Token) -> Action -strtoken t = \str sc cont -> t str : cont sc -strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc +strtoken t = \pos str sc cont _ -> (t str, pos) : cont sc +strtokenNL t = \pos str sc cont _ -> (t (filter (/= '\r') str), pos) : cont sc -- ^ We only want LF line endings in our internal doc string format, so we -- filter out all CRs. begin :: StartCode -> Action -begin sc = \_ _ cont -> cont sc +begin sc = \_ _ _ cont _ -> cont sc -- ----------------------------------------------------------------------------- -- Lex a string as a Haskell identifier ident :: Action -ident str sc cont = - case strToHsQNames id of - Just names -> TokIdent names : cont sc - Nothing -> TokString str : cont sc +ident pos str sc cont dflags = + case strToHsQNames dflags id of + Just names -> (TokIdent names, pos) : cont sc + Nothing -> (TokString str, pos) : cont sc where id = init (tail str) -strToHsQNames :: String -> Maybe [RdrName] -strToHsQNames str0 = +strToHsQNames :: DynFlags -> String -> Maybe [RdrName] +strToHsQNames dflags str0 = let buffer = unsafePerformIO (stringToStringBuffer str0) - pstate = mkPState buffer noSrcLoc defaultDynFlags +#if MIN_VERSION_ghc(6,13,0) + pstate = mkPState dflags buffer noSrcLoc +#else + pstate = mkPState buffer noSrcLoc dflags +#endif result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] _ -> Nothing -birdtrack,def,line,para,string :: Int +birdtrack,def,example,exampleexpr,exampleresult,line,para,string :: Int birdtrack = 1 def = 2 -line = 3 -para = 4 -string = 5 +example = 3 +exampleexpr = 4 +exampleresult = 5 +line = 6 +para = 7 +string = 8 alex_action_1 = begin birdtrack -alex_action_2 = token TokBullet `andBegin` string -alex_action_3 = token TokDefStart `andBegin` def -alex_action_4 = token TokNumber `andBegin` string -alex_action_5 = begin string -alex_action_6 = begin birdtrack -alex_action_7 = token TokPara `andBegin` para -alex_action_8 = begin string -alex_action_9 = strtokenNL TokBirdTrack `andBegin` line -alex_action_10 = strtoken $ \s -> TokSpecial (head s) -alex_action_11 = strtoken $ \s -> TokPic (init $ init $ tail $ tail s) -alex_action_12 = strtoken $ \s -> TokURL (init (tail s)) -alex_action_13 = strtoken $ \s -> TokAName (init (tail s)) -alex_action_14 = strtoken $ \s -> TokEmphasis (init (tail s)) -alex_action_15 = ident -alex_action_16 = strtoken (TokString . tail) -alex_action_17 = strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] -alex_action_18 = strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] -alex_action_19 = strtoken TokString -alex_action_20 = strtokenNL TokString `andBegin` line -alex_action_21 = strtoken TokString -alex_action_22 = token TokDefEnd `andBegin` string -alex_action_23 = strtoken TokString +alex_action_2 = strtoken TokExamplePrompt `andBegin` exampleexpr +alex_action_3 = token TokBullet `andBegin` string +alex_action_4 = token TokDefStart `andBegin` def +alex_action_5 = token TokNumber `andBegin` string +alex_action_6 = token TokNumber `andBegin` string +alex_action_7 = begin string +alex_action_8 = begin birdtrack +alex_action_9 = strtoken TokExamplePrompt `andBegin` exampleexpr +alex_action_10 = token TokPara `andBegin` para +alex_action_11 = begin string +alex_action_12 = strtokenNL TokBirdTrack `andBegin` line +alex_action_13 = token TokPara `andBegin` para +alex_action_14 = strtoken TokExamplePrompt `andBegin` exampleexpr +alex_action_15 = begin exampleresult +alex_action_16 = strtokenNL TokExampleExpression `andBegin` example +alex_action_17 = strtokenNL TokExampleResult `andBegin` example +alex_action_18 = strtoken $ \s -> TokSpecial (head s) +alex_action_19 = strtoken $ \s -> TokPic (init $ init $ tail $ tail s) +alex_action_20 = strtoken $ \s -> TokURL (init (tail s)) +alex_action_21 = strtoken $ \s -> TokAName (init (tail s)) +alex_action_22 = strtoken $ \s -> TokEmphasis (init (tail s)) +alex_action_23 = ident +alex_action_24 = strtoken (TokString . tail) +alex_action_25 = strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] +alex_action_26 = strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] +alex_action_27 = strtoken TokString +alex_action_28 = strtokenNL TokString `andBegin` line +alex_action_29 = strtoken TokString +alex_action_30 = token TokDefEnd `andBegin` string +alex_action_31 = strtoken TokString {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} @@ -177,9 +307,9 @@ -- ----------------------------------------------------------------------------- -- INTERNALS and main scanner engine -{-# LINE 35 "templates/GenericTemplate.hs" #-} +{-# LINE 37 "templates/GenericTemplate.hs" #-} -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 47 "templates/GenericTemplate.hs" #-} data AlexAddr = AlexA# Addr# @@ -264,17 +394,17 @@ AlexError input' - (AlexLastSkip input len, _) -> + (AlexLastSkip input'' len, _) -> - AlexSkip input len + AlexSkip input'' len - (AlexLastAcc k input len, _) -> + (AlexLastAcc k input''' len, _) -> - AlexToken input len k + AlexToken input''' len k -- Push the input through the DFA, remembering the most recent accepting @@ -293,12 +423,12 @@ let - base = alexIndexInt32OffAddr alex_base s - (I# (ord_c)) = ord c - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset + !(base) = alexIndexInt32OffAddr alex_base s + !((I# (ord_c))) = ord c + !(offset) = (base +# ord_c) + !(check) = alexIndexInt16OffAddr alex_check offset - new_s = if (offset >=# 0#) && (check ==# ord_c) + !(new_s) = if (offset >=# 0#) && (check ==# ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in @@ -313,11 +443,11 @@ check_accs [] = last_acc check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len)) check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len)) - check_accs (AlexAccPred a pred : rest) - | pred user orig_input (I# (len)) input + check_accs (AlexAccPred a predx : rest) + | predx user orig_input (I# (len)) input = AlexLastAcc a input (I# (len)) - check_accs (AlexAccSkipPred pred : rest) - | pred user orig_input (I# (len)) input + check_accs (AlexAccSkipPred predx : rest) + | predx user orig_input (I# (len)) input = AlexLastSkip input (I# (len)) check_accs (_ : rest) = check_accs rest diff --git a/dist/build/haddock/haddock-tmp/Haddock/Parse.hs b/dist/build/haddock/haddock-tmp/Haddock/Parse.hs --- a/dist/build/haddock/haddock-tmp/Haddock/Parse.hs +++ b/dist/build/haddock/haddock-tmp/Haddock/Parse.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-} {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. @@ -9,125 +10,138 @@ module Haddock.Parse where import Haddock.Lex -import Haddock.Types (Doc(..)) +import Haddock.Types (Doc(..), Example(Example)) import Haddock.Doc import HsSyn import RdrName -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Exts -#else -import GlaExts -#endif +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import Data.List (stripPrefix) +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.17 +-- parser produced by Happy Version 1.18.5 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 -type HappyAny = GHC.Exts.Any +type HappyAny = Happy_GHC_Exts.Any #else type HappyAny = forall a . a #endif happyIn5 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn5 x = unsafeCoerce# x +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn5 #-} happyOut5 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut5 x = unsafeCoerce# x +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut5 #-} happyIn6 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn6 x = unsafeCoerce# x +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn6 #-} happyOut6 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut6 x = unsafeCoerce# x +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut6 #-} happyIn7 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn7 x = unsafeCoerce# x +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn7 #-} happyOut7 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut7 x = unsafeCoerce# x +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut7 #-} happyIn8 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn8 x = unsafeCoerce# x +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn8 #-} happyOut8 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut8 x = unsafeCoerce# x +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut8 #-} happyIn9 :: ((Doc RdrName, Doc RdrName)) -> (HappyAbsSyn ) -happyIn9 x = unsafeCoerce# x +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn9 #-} happyOut9 :: (HappyAbsSyn ) -> ((Doc RdrName, Doc RdrName)) -happyOut9 x = unsafeCoerce# x +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut9 #-} happyIn10 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn10 x = unsafeCoerce# x +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn10 #-} happyOut10 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut10 x = unsafeCoerce# x +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut10 #-} happyIn11 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn11 x = unsafeCoerce# x +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn11 #-} happyOut11 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut11 x = unsafeCoerce# x +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut11 #-} -happyIn12 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn12 x = unsafeCoerce# x +happyIn12 :: ([Example]) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut12 x = unsafeCoerce# x +happyOut12 :: (HappyAbsSyn ) -> ([Example]) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut12 #-} -happyIn13 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn13 x = unsafeCoerce# x +happyIn13 :: (Example) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut13 x = unsafeCoerce# x +happyOut13 :: (HappyAbsSyn ) -> (Example) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut13 #-} -happyIn14 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn14 x = unsafeCoerce# x +happyIn14 :: (String) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut14 x = unsafeCoerce# x +happyOut14 :: (HappyAbsSyn ) -> (String) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut14 #-} happyIn15 :: (Doc RdrName) -> (HappyAbsSyn ) -happyIn15 x = unsafeCoerce# x +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn15 #-} happyOut15 :: (HappyAbsSyn ) -> (Doc RdrName) -happyOut15 x = unsafeCoerce# x +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut15 #-} -happyIn16 :: (String) -> (HappyAbsSyn ) -happyIn16 x = unsafeCoerce# x +happyIn16 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> (String) -happyOut16 x = unsafeCoerce# x +happyOut16 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut16 #-} -happyInTok :: Token -> (HappyAbsSyn ) -happyInTok x = unsafeCoerce# x +happyIn17 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Doc RdrName) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> (Doc RdrName) +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: (String) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> (String) +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyInTok :: (LToken) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> Token -happyOutTok x = unsafeCoerce# x +happyOutTok :: (HappyAbsSyn ) -> (LToken) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOutTok #-} happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\xff\xff\x25\x00\x0d\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x51\x00\x25\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x5d\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x46\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x44\x00\x2f\x00\x2b\x00\x27\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\xff\xff\x2e\x00\x10\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x2e\x00\x00\x00\x66\x00\x2e\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x64\x00\x5a\x00\x00\x00\x00\x00\x53\x00\x53\x00\x47\x00\xff\xff\x00\x00\xff\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x49\x00\x46\x00\x3b\x00\x66\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x4b\x00\x78\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x7a\x00\x70\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x66\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x52\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\x5d\x00\x92\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x8e\x00\x00\x00\x1d\x00\x67\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x81\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x41\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x12\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf1\xff\xf2\xff\xed\xff\xec\xff\x00\x00\x00\x00\x00\x00\xe5\xff\xe4\xff\xe3\xff\xe6\xff\x00\x00\x00\x00\xef\xff\xe2\xff\xe7\xff\x00\x00\x00\x00\xfb\xff\xfa\xff\xfc\xff\xfa\xff\xf0\xff\xf4\xff\xf5\xff\x00\x00\xe0\xff\x00\x00\x00\x00\xe8\xff\x00\x00\xee\xff\xea\xff\xe9\xff\xeb\xff\x00\x00\xdf\xff\xe1\xff\xfd\xff\xf3\xff"# +happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf1\xff\xf0\xff\xec\xff\xf2\xff\xe6\xff\xe5\xff\x00\x00\x00\x00\x00\x00\xde\xff\xdd\xff\xdc\xff\xdf\xff\x00\x00\x00\x00\xee\xff\x00\x00\xdb\xff\xe0\xff\x00\x00\x00\x00\xfb\xff\xfa\xff\xfc\xff\xfa\xff\xea\xff\xef\xff\xf4\xff\xf5\xff\x00\x00\xd9\xff\x00\x00\x00\x00\xe1\xff\x00\x00\xe7\xff\xed\xff\xe3\xff\xe2\xff\xe4\xff\x00\x00\xd8\xff\xda\xff\xeb\xff\xe8\xff\xfd\xff\xe9\xff\xf3\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x02\x00\x03\x00\x06\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x0b\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x09\x00\x0a\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x02\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x07\x00\x08\x00\x0d\x00\x0a\x00\x0f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x05\x00\x0a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x09\x00\x0a\x00\x10\x00\x0d\x00\x0e\x00\x0f\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0c\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\x0e\x00\x0a\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\x0f\x00\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x09\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0c\x00\x0d\x00\x10\x00\x11\x00\x12\x00\x02\x00\x03\x00\x0e\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0c\x00\x0d\x00\x10\x00\x02\x00\x12\x00\x09\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0c\x00\x0d\x00\x0c\x00\x0d\x00\x07\x00\x08\x00\x10\x00\x02\x00\x12\x00\x06\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0e\x00\x0a\x00\x0b\x00\x0e\x00\x0d\x00\x02\x00\x10\x00\x05\x00\x12\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x04\x00\x0a\x00\x0b\x00\x0e\x00\x0d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x11\x00\x0a\x00\x0b\x00\x12\x00\x0d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x13\x00\x0a\x00\x0b\x00\x0f\x00\x0d\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0c\x00\x0a\x00\x0b\x00\x12\x00\x0d\x00\x0d\x00\x10\x00\x11\x00\x12\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x11\x00\x0a\x00\x0b\x00\xff\xff\x0d\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\x0d\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\x0d\x00\x0a\x00\x0b\x00\xff\xff\x0d\x00\x0a\x00\x0b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x0d\x00\x0e\x00\x2c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x1c\x00\x18\x00\x0d\x00\x0e\x00\x1e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x21\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x28\x00\x25\x00\x16\x00\x17\x00\x0d\x00\x18\x00\x2b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x2c\x00\x2f\x00\x0a\x00\x17\x00\x0b\x00\x18\x00\x2e\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x23\x00\x0b\x00\x1c\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x2e\x00\x0b\x00\x19\x00\x1a\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x0b\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x29\x00\x25\x00\xff\xff\x17\x00\x27\x00\x18\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x16\x00\x0b\x00\x1f\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x0b\x00\x20\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x23\x00\x0a\x00\x23\x00\x0b\x00\x27\x00\x0a\x00\x00\x00\x0b\x00\x18\x00\x0a\x00\x00\x00\x0b\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x0f\x00\x10\x00\x36\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x2d\x00\x29\x00\x1a\x00\x1f\x00\x1b\x00\x0f\x00\x10\x00\x31\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x2e\x00\x29\x00\x1a\x00\x0f\x00\x1b\x00\x33\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x28\x00\x29\x00\x18\x00\x19\x00\x2c\x00\x0a\x00\x1a\x00\x0f\x00\x1b\x00\x22\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x25\x00\x37\x00\x0c\x00\x35\x00\x0d\x00\x30\x00\x1a\x00\x33\x00\x1b\x00\x35\x00\x1d\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x31\x00\x0b\x00\x0c\x00\x35\x00\x0d\x00\x1f\x00\x1d\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x21\x00\x0b\x00\x0c\x00\x27\x00\x0d\x00\x1c\x00\x1d\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\x0b\x00\x0c\x00\x22\x00\x0d\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x18\x00\x27\x00\x0c\x00\x27\x00\x0d\x00\x19\x00\x1a\x00\x2b\x00\x1b\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x21\x00\x0b\x00\x0c\x00\x00\x00\x0d\x00\x23\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x0c\x00\x00\x00\x0d\x00\x24\x00\x08\x00\x09\x00\x0a\x00\x00\x00\x0b\x00\x0c\x00\x00\x00\x0d\x00\x2b\x00\x0c\x00\x00\x00\x0d\x00\x1b\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = array (2, 32) [ +happyReduceArr = Happy_Data_Array.array (2, 39) [ (2 , happyReduce_2), (3 , happyReduce_3), (4 , happyReduce_4), @@ -158,11 +172,18 @@ (29 , happyReduce_29), (30 , happyReduce_30), (31 , happyReduce_31), - (32 , happyReduce_32) + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39) ] -happy_n_terms = 17 :: Int -happy_n_nonterms = 12 :: Int +happy_n_terms = 20 :: Int +happy_n_nonterms = 15 :: Int happyReduce_2 = happySpecReduce_3 0# happyReduction_2 happyReduction_2 happy_x_3 @@ -244,15 +265,15 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut12 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> + = case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_4 of { happy_var_4 -> happyIn9 ((happy_var_2, happy_var_4) ) `HappyStk` happyRest}} happyReduce_13 = happySpecReduce_1 5# happyReduction_13 happyReduction_13 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> + = case happyOut15 happy_x_1 of { happy_var_1 -> happyIn10 (docParagraph happy_var_1 )} @@ -264,166 +285,228 @@ (DocCodeBlock happy_var_1 )} -happyReduce_15 = happySpecReduce_2 6# happyReduction_15 -happyReduction_15 happy_x_2 +happyReduce_15 = happySpecReduce_1 5# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn10 + (DocExamples happy_var_1 + )} + +happyReduce_16 = happySpecReduce_2 6# happyReduction_16 +happyReduction_16 happy_x_2 happy_x_1 - = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> + = case happyOutTok happy_x_1 of { ((TokBirdTrack happy_var_1,_)) -> case happyOut11 happy_x_2 of { happy_var_2 -> happyIn11 (docAppend (DocString happy_var_1) happy_var_2 )}} -happyReduce_16 = happySpecReduce_1 6# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TokBirdTrack happy_var_1) -> +happyReduce_17 = happySpecReduce_1 6# happyReduction_17 +happyReduction_17 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokBirdTrack happy_var_1,_)) -> happyIn11 (DocString happy_var_1 )} -happyReduce_17 = happySpecReduce_2 7# happyReduction_17 -happyReduction_17 happy_x_2 +happyReduce_18 = happySpecReduce_2 7# happyReduction_18 +happyReduction_18 happy_x_2 happy_x_1 = case happyOut13 happy_x_1 of { happy_var_1 -> case happyOut12 happy_x_2 of { happy_var_2 -> happyIn12 - (docAppend happy_var_1 happy_var_2 + (happy_var_1 : happy_var_2 )}} -happyReduce_18 = happySpecReduce_1 7# happyReduction_18 -happyReduction_18 happy_x_1 +happyReduce_19 = happySpecReduce_1 7# happyReduction_19 +happyReduction_19 happy_x_1 = case happyOut13 happy_x_1 of { happy_var_1 -> happyIn12 - (happy_var_1 - )} - -happyReduce_19 = happySpecReduce_1 8# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn13 - (happy_var_1 + ([happy_var_1] )} happyReduce_20 = happySpecReduce_3 8# happyReduction_20 happyReduction_20 happy_x_3 happy_x_2 happy_x_1 - = case happyOut14 happy_x_2 of { happy_var_2 -> + = case happyOutTok happy_x_1 of { ((TokExamplePrompt happy_var_1,_)) -> + case happyOutTok happy_x_2 of { ((TokExampleExpression happy_var_2,_)) -> + case happyOut14 happy_x_3 of { happy_var_3 -> happyIn13 - (DocMonospaced happy_var_2 - )} + (makeExample happy_var_1 happy_var_2 (lines happy_var_3) + )}}} -happyReduce_21 = happySpecReduce_2 9# happyReduction_21 +happyReduce_21 = happySpecReduce_2 8# happyReduction_21 happyReduction_21 happy_x_2 happy_x_1 - = case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn14 - (docAppend (DocString "\n") happy_var_2 - )} + = case happyOutTok happy_x_1 of { ((TokExamplePrompt happy_var_1,_)) -> + case happyOutTok happy_x_2 of { ((TokExampleExpression happy_var_2,_)) -> + happyIn13 + (makeExample happy_var_1 happy_var_2 [] + )}} happyReduce_22 = happySpecReduce_2 9# happyReduction_22 happyReduction_22 happy_x_2 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> + = case happyOutTok happy_x_1 of { ((TokExampleResult happy_var_1,_)) -> case happyOut14 happy_x_2 of { happy_var_2 -> happyIn14 - (docAppend happy_var_1 happy_var_2 + (happy_var_1 ++ happy_var_2 )}} happyReduce_23 = happySpecReduce_1 9# happyReduction_23 happyReduction_23 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> + = case happyOutTok happy_x_1 of { ((TokExampleResult happy_var_1,_)) -> happyIn14 (happy_var_1 )} -happyReduce_24 = happySpecReduce_1 10# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> +happyReduce_24 = happySpecReduce_2 10# happyReduction_24 +happyReduction_24 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> happyIn15 - (DocString happy_var_1 - )} + (docAppend happy_var_1 happy_var_2 + )}} happyReduce_25 = happySpecReduce_1 10# happyReduction_25 happyReduction_25 happy_x_1 - = case happyOutTok happy_x_1 of { (TokEmphasis happy_var_1) -> + = case happyOut16 happy_x_1 of { happy_var_1 -> happyIn15 - (DocEmphasis (DocString happy_var_1) + (happy_var_1 )} -happyReduce_26 = happySpecReduce_1 10# happyReduction_26 +happyReduce_26 = happySpecReduce_1 11# happyReduction_26 happyReduction_26 happy_x_1 - = case happyOutTok happy_x_1 of { (TokURL happy_var_1) -> - happyIn15 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn16 + (happy_var_1 + )} + +happyReduce_27 = happySpecReduce_3 11# happyReduction_27 +happyReduction_27 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn16 + (DocMonospaced happy_var_2 + )} + +happyReduce_28 = happySpecReduce_2 12# happyReduction_28 +happyReduction_28 happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn17 + (docAppend (DocString "\n") happy_var_2 + )} + +happyReduce_29 = happySpecReduce_2 12# happyReduction_29 +happyReduction_29 happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn17 + (docAppend happy_var_1 happy_var_2 + )}} + +happyReduce_30 = happySpecReduce_1 12# happyReduction_30 +happyReduction_30 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn17 + (happy_var_1 + )} + +happyReduce_31 = happySpecReduce_1 13# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokString happy_var_1,_)) -> + happyIn18 + (DocString happy_var_1 + )} + +happyReduce_32 = happySpecReduce_1 13# happyReduction_32 +happyReduction_32 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokEmphasis happy_var_1,_)) -> + happyIn18 + (DocEmphasis (DocString happy_var_1) + )} + +happyReduce_33 = happySpecReduce_1 13# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokURL happy_var_1,_)) -> + happyIn18 (DocURL happy_var_1 )} -happyReduce_27 = happySpecReduce_1 10# happyReduction_27 -happyReduction_27 happy_x_1 - = case happyOutTok happy_x_1 of { (TokPic happy_var_1) -> - happyIn15 +happyReduce_34 = happySpecReduce_1 13# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokPic happy_var_1,_)) -> + happyIn18 (DocPic happy_var_1 )} -happyReduce_28 = happySpecReduce_1 10# happyReduction_28 -happyReduction_28 happy_x_1 - = case happyOutTok happy_x_1 of { (TokAName happy_var_1) -> - happyIn15 +happyReduce_35 = happySpecReduce_1 13# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokAName happy_var_1,_)) -> + happyIn18 (DocAName happy_var_1 )} -happyReduce_29 = happySpecReduce_1 10# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOutTok happy_x_1 of { (TokIdent happy_var_1) -> - happyIn15 +happyReduce_36 = happySpecReduce_1 13# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokIdent happy_var_1,_)) -> + happyIn18 (DocIdentifier happy_var_1 )} -happyReduce_30 = happySpecReduce_3 10# happyReduction_30 -happyReduction_30 happy_x_3 +happyReduce_37 = happySpecReduce_3 13# happyReduction_37 +happyReduction_37 happy_x_3 happy_x_2 happy_x_1 - = case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn15 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn18 (DocModule happy_var_2 )} -happyReduce_31 = happySpecReduce_1 11# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - happyIn16 +happyReduce_38 = happySpecReduce_1 14# happyReduction_38 +happyReduction_38 happy_x_1 + = case happyOutTok happy_x_1 of { ((TokString happy_var_1,_)) -> + happyIn19 (happy_var_1 )} -happyReduce_32 = happySpecReduce_2 11# happyReduction_32 -happyReduction_32 happy_x_2 +happyReduce_39 = happySpecReduce_2 14# happyReduction_39 +happyReduction_39 happy_x_2 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn16 + = case happyOutTok happy_x_1 of { ((TokString happy_var_1,_)) -> + case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn19 (happy_var_1 ++ happy_var_2 )}} happyNewToken action sts stk [] = - happyDoAction 16# notHappyAtAll action sts stk [] + happyDoAction 19# notHappyAtAll action sts stk [] happyNewToken action sts stk (tk:tks) = let cont i = happyDoAction i tk action sts stk tks in case tk of { - TokSpecial '/' -> cont 1#; - TokSpecial '@' -> cont 2#; - TokDefStart -> cont 3#; - TokDefEnd -> cont 4#; - TokSpecial '\"' -> cont 5#; - TokURL happy_dollar_dollar -> cont 6#; - TokPic happy_dollar_dollar -> cont 7#; - TokAName happy_dollar_dollar -> cont 8#; - TokEmphasis happy_dollar_dollar -> cont 9#; - TokBullet -> cont 10#; - TokNumber -> cont 11#; - TokBirdTrack happy_dollar_dollar -> cont 12#; - TokIdent happy_dollar_dollar -> cont 13#; - TokPara -> cont 14#; - TokString happy_dollar_dollar -> cont 15#; + (TokSpecial '/',_) -> cont 1#; + (TokSpecial '@',_) -> cont 2#; + (TokDefStart,_) -> cont 3#; + (TokDefEnd,_) -> cont 4#; + (TokSpecial '\"',_) -> cont 5#; + (TokURL happy_dollar_dollar,_) -> cont 6#; + (TokPic happy_dollar_dollar,_) -> cont 7#; + (TokAName happy_dollar_dollar,_) -> cont 8#; + (TokEmphasis happy_dollar_dollar,_) -> cont 9#; + (TokBullet,_) -> cont 10#; + (TokNumber,_) -> cont 11#; + (TokBirdTrack happy_dollar_dollar,_) -> cont 12#; + (TokExamplePrompt happy_dollar_dollar,_) -> cont 13#; + (TokExampleResult happy_dollar_dollar,_) -> cont 14#; + (TokExampleExpression happy_dollar_dollar,_) -> cont 15#; + (TokIdent happy_dollar_dollar,_) -> cont 16#; + (TokPara,_) -> cont 17#; + (TokString happy_dollar_dollar,_) -> cont 18#; _ -> happyError' (tk:tks) } @@ -436,20 +519,40 @@ happyThen1 m k tks = (>>=) m (\a -> k a tks) happyReturn1 :: () => a -> b -> Maybe a happyReturn1 = \a tks -> (return) a -happyError' :: () => [Token] -> Maybe a +happyError' :: () => [(LToken)] -> Maybe a happyError' = happyError parseParas tks = happySomeParser where happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) parseString tks = happySomeParser where - happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut12 x)) + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut15 x)) happySeq = happyDontSeq -happyError :: [Token] -> Maybe a +happyError :: [LToken] -> Maybe a happyError toks = Nothing + +-- | Create an 'Example', stripping superfluous characters as appropriate +makeExample :: String -> String -> [String] -> Example +makeExample prompt expression result = + Example + (strip expression) -- we do not care about leading and trailing + -- whitespace in expressions, so drop them + result' + where + -- drop trailing whitespace from the prompt, remember the prefix + (prefix, _) = span isSpace prompt + -- drop, if possible, the exact same sequence of whitespace characters + -- from each result line + result' = map (tryStripPrefix prefix) result + where + tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys + +-- | Remove all leading and trailing whitespace +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} @@ -457,20 +560,20 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 28 "templates/GenericTemplate.hs" #-} +{-# LINE 30 "templates/GenericTemplate.hs" #-} -data Happy_IntList = HappyCons Int# Happy_IntList +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList -{-# LINE 49 "templates/GenericTemplate.hs" #-} +{-# LINE 51 "templates/GenericTemplate.hs" #-} -{-# LINE 59 "templates/GenericTemplate.hs" #-} +{-# LINE 61 "templates/GenericTemplate.hs" #-} -{-# LINE 68 "templates/GenericTemplate.hs" #-} +{-# LINE 70 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -505,49 +608,40 @@ happyFail i tk st -1# -> {- nothing -} happyAccept i tk st - n | (n <# (0# :: Int#)) -> {- nothing -} + n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - (happyReduceArr ! rule) i tk st - where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) n -> {- nothing -} happyShift new_state i tk st - where new_state = (n -# (1# :: Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off +# i) - check = if (off_i >=# (0# :: Int#)) - then (indexShortOffAddr happyCheck off_i ==# i) + where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where !(off) = indexShortOffAddr happyActOffsets st + !(off_i) = (off Happy_GHC_Exts.+# i) + check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) + then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st + !(action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st -{-# LINE 127 "templates/GenericTemplate.hs" #-} +{-# LINE 130 "templates/GenericTemplate.hs" #-} indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 - narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - intToInt16# i -#else - (i `iShiftL#` 16#) `iShiftRA#` 16# -#endif + Happy_GHC_Exts.narrow16Int# i where -#if __GLASGOW_HASKELL__ >= 503 - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) -#else - i = word2Int# ((high `shiftL#` 8#) `or#` low) -#endif - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# + !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + !off' = off Happy_GHC_Exts.*# 2# -data HappyAddr = HappyA# Addr# +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# @@ -555,13 +649,13 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 170 "templates/GenericTemplate.hs" #-} +{-# LINE 163 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in + let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -596,7 +690,7 @@ happyReduce k i fn 0# tk st sts stk = happyFail 0# tk st sts stk happyReduce k nt fn j tk st sts stk - = case happyDrop (k -# (1# :: Int#)) sts of + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of sts1@((HappyCons (st1@(action)) (_))) -> let r = fn stk in -- it doesn't hurt to always seq here... happyDoSeq r (happyGoto nt j tk st1 sts1 r) @@ -605,28 +699,28 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i + !(off) = indexShortOffAddr happyGotoOffsets st1 + !(off_i) = (off Happy_GHC_Exts.+# nt) + !(new_state) = indexShortOffAddr happyTable off_i happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs ----------------------------------------------------------------------------- -- Moving to a new state after a reduction @@ -635,9 +729,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off +# nt) - new_state = indexShortOffAddr happyTable off_i + where !(off) = indexShortOffAddr happyGotoOffsets st + !(off_i) = (off Happy_GHC_Exts.+# nt) + !(new_state) = indexShortOffAddr happyTable off_i @@ -665,7 +759,7 @@ -- save the old token and carry on. happyFail i tk (action) sts stk = -- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) -- Internal happy errors: @@ -675,7 +769,7 @@ -- Hack to get the typechecker to accept our action functions -happyTcHack :: Int# -> a -> a +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a happyTcHack x y = y {-# INLINE happyTcHack #-} diff --git a/doc/configure.ac b/doc/configure.ac --- a/doc/configure.ac +++ b/doc/configure.ac @@ -5,7 +5,7 @@ dnl ** check for DocBook toolchain FP_CHECK_DOCBOOK_DTD -FP_DIR_DOCBOOK_XSL([/usr/share/xml/docbook/stylesheet/nwalsh/current /usr/share/xml/docbook/stylesheet/nwalsh /usr/share/sgml/docbook/docbook-xsl-stylesheets* /usr/share/sgml/docbook/xsl-stylesheets* /opt/kde?/share/apps/ksgmltools2/docbook/xsl /usr/share/docbook-xsl /usr/share/sgml/docbkxsl /usr/local/share/xsl/docbook /sw/share/xml/xsl/docbook-xsl]) +FP_DIR_DOCBOOK_XSL([/usr/share/xml/docbook/stylesheet/nwalsh/current /usr/share/xml/docbook/stylesheet/nwalsh /usr/share/sgml/docbook/docbook-xsl-stylesheets* /usr/share/sgml/docbook/xsl-stylesheets* /opt/kde?/share/apps/ksgmltools2/docbook/xsl /usr/share/docbook-xsl /usr/share/sgml/docbkxsl /usr/local/share/xsl/docbook /sw/share/xml/xsl/docbook-xsl /usr/share/xml/docbook/xsl-stylesheets-*]) FP_PROG_FO_PROCESSOR AC_CONFIG_FILES([config.mk]) diff --git a/doc/haddock.xml b/doc/haddock.xml --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -10,13 +10,18 @@ Simon Marlow -
simonmar@microsoft.com
+
marlowsd@gmail.com
+ + David + Waern + +
david.waern@gmail.com
- 2004 - Simon Marlow + 2010 + Simon Marlow, David Waern - This document describes Haddock version 2.7.2, a Haskell + This document describes Haddock version 2.8.0, a Haskell documentation tool. @@ -93,7 +98,7 @@ We might want documentation in multiple formats - online - and printed, for example. Haddock comes with HTML, DocBook + and printed, for example. Haddock comes with HTML, LaTeX, and Hoogle backends, and it is structured in such a way that adding new back-ends is straightforward. @@ -120,7 +125,7 @@ Haddock source code, except where otherwise indicated.
- Copyright 2002, Simon Marlow. All rights reserved. + 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 @@ -157,6 +162,51 @@
+ 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 + Mark Lentczner + Mark Shields + Neil Mitchell + Mike Thomas + Manuel Chakravarty + Oliver Brown + Roman Cheplyaka + Ross Paterson + Simon Hengel + Simon Marlow + Simon Peyton-Jones + Sigbjorn Finne + Stefan O'Rear + Sven Panne + Thomas Schilling + Wolfgang Jeltsch + Yitzchak Gale + +
+
Acknowledgements Several documentation systems provided the inspiration for @@ -180,12 +230,9 @@ and probably several others I've forgotten. - Thanks to the following people for useful feedback, - discussion, patches, packaging, and moral support: Simon Peyton - Jones, Mark Shields, Manuel Chakravarty, Ross Patterson, Brett - Letner, Sven Panne, Hal Daume, George Russell, Oliver Braun, - Ashley Yakeley, Malcolm Wallace, Krasimir Angelov, the members - of haskelldoc@haskell.org, and everyone who + 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.
@@ -247,27 +294,30 @@ - - =option + + dir + + + =dir + - Pass option to GHC. + Generate files into dir + instead of the current directory. - - - dir + + dir - - =dir + + =dir - Generate files into dir - instead of the current directory. + Use Haddock auxiliary files (themes, javascript, etc...) in dir. @@ -329,35 +379,6 @@ - - dir - - - - =dir - - - Use auxiliary files in dir. - - - - - - - - - - - - - - Reserved for future use (output documentation in DocBook XML - format). - - - - - @@ -372,6 +393,15 @@ 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 @@ -380,36 +410,33 @@ - haddock.css + doc-index.html + doc-index-X.html - The stylesheet used by the generated HTML. Feel - free to modify this to change the colors or - layout, or even specify your own stylesheet using the - option. + The alphabetic index, possibly split into multiple + pages if big enough. - haddock-util.js + frames.html - A small piece of JavaScript for collapsing sections - of the generated HTML. + The top level document when viewing in frames. - module.html + some.css + etc... - An HTML page for each - module. + Files needed for the themes used. Specify your themes + using the option. - doc-index.html - doc-index-XX.html + haddock-util.js - The index, split into two - (functions/constructors and types/classes, as per - Haskell namespaces) and further split - alphabetically. + Some JavaScript utilities used to implement some of the + dynamic features like collapsable sections, and switching to + frames view. @@ -417,61 +444,81 @@ - - - - - - - + + + - - (In HTML mode only) Produce extra contents and index - files for given HTML Help system. Currently supported Help - systems are Microsoft HTML Help 1.3 and 2.0 and GNOME DevHelp. - - Using the Microsoft HTML Help system provides two - advantages over plain HTML: the help viewer gives you a nice - hierarchical folding contents pane on the left, and the - documentation files are compressed and therefore much - smaller (roughly a factor of 10). The disadvantage is that - the help can't be viewed over the web. - - In order to create a compiled Microsoft help file, you - also need the Microsoft HTML Help compiler, which is - available free from - http://www.microsoft.com/ - (search for HTML Help compiler). - - Viewers + + 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: + - - Microsoft HTML Help Viewer - Distributed with Microsoft Windows - - - xCHM - a CHM viewer for UNIX (Linux, *BSD, Solaris), written by Razvan Cojocaru + + package.tex + + The top-level LaTeX source file; to format the + documentation into PDF you might run something like + this: + +$ pdflatex package.tex + - JouleData Solutions' CHM Viewer - a comercial 100% native Cocoa .chm file viewer for the Mac OS X platform + 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. + - GnoCHM - a CHM file viewer. It is designed to integrate nicely with Gnome. + module.tex + + The LaTeX documentation for + each module. + - + + + - The GNOME DevHelp also provides help viewer which looks like - MSHelp viewer but the documentation files aren't compressed. - The documentation can be viewed with any HTML browser but - DevHelp gives you a nice hierarchical folding contents and - keyword index panes on the left. The DevHelp expects to see - *.devhelp file in the folder where the documentation is placed. - The file contains all required information - to build the contents and index panes. - + + + + + + + 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). @@ -637,6 +684,59 @@ + + =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 @@ -645,9 +745,7 @@ =file - Specify a stylesheet to use instead of the default one - that comes with Haddock. It should specify certain classes: - see the default stylesheet for details. + Deprecated aliases for @@ -718,6 +816,20 @@ + + + + + + + + + Output version information and exit. + + + + + @@ -736,44 +848,39 @@ - - + + - - - - - Output version information and exit. - - - - - When generating HTML, do not generate an index. - Instead, redirect the Index link on each page to + Instead, redirect the Contents and/or Index link on each page to URL. This option is intended for - use in conjuction with for - generating a separate index covering multiple + use in conjuction with and/or + for + generating a separate contents and/or index covering multiple libraries. + + + + - Generate an HTML index containing entries pulled from - all the specified interfaces (interfaces are specified using + 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 index for multiple sets of - Haddock documentation. + This is used to generate a single contents and/or index for multiple + sets of Haddock documentation. @@ -806,6 +913,16 @@ + + + =option + + + Pass option to GHC. + + + + @@ -818,6 +935,26 @@ Turn off all warnings. + + + + + + + + + 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. + + +
@@ -1409,12 +1546,17 @@ 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 \. + 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.
@@ -1464,6 +1606,28 @@ 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 bellow: +-- +-- >>> fib 10 +-- 55 +-- +-- >>> putStrLn "foo\nbar" +-- foo +-- bar + +
+
Hyperlinked Identifiers diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.7.2 +version: 2.8.0 cabal-version: >= 1.6 license: BSD3 build-type: Simple @@ -50,13 +50,18 @@ src/haddock.sh data-files: - html/haddock-DEBUG.css - html/haddock.css - html/haddock-util.js - html/haskell_icon.gif - html/minus.gif - html/plus.gif html/frames.html + 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? @@ -69,14 +74,15 @@ executable haddock build-depends: - base >= 4.0.0.0 && < 4.3.0.0, + base >= 4.0.0.0 && < 4.4.0.0, filepath, directory, pretty, containers, array, + xhtml >= 3000.2 && < 3000.3, Cabal >= 1.5, - ghc >= 6.12 && < 6.14 + ghc >= 6.12 && < 6.16 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE @@ -92,7 +98,7 @@ hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable, ScopedTypeVariables, MagicHash - ghc-options: -funbox-strict-fields -O2 -Wall + ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: Haddock.Interface @@ -105,14 +111,17 @@ Haddock.Interface.ParseModuleHeader Haddock.Lex Haddock.Parse - Haddock.Utils.BlockTable - Haddock.Utils.Html Haddock.Utils - Haddock.Backends.Html + 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.DevHelp - Haddock.Backends.HH - Haddock.Backends.HH2 Haddock.Backends.Hoogle Haddock.ModuleTree Haddock.Types @@ -125,16 +134,22 @@ library build-depends: - base >= 4.0.0.0 && < 4.3.0.0, + base >= 4.0.0.0 && < 4.4.0.0, filepath, directory, pretty, containers, array, + xhtml >= 3000.2 && < 3000.3, Cabal >= 1.5, - ghc >= 6.12 && < 6.14, - ghc-paths + ghc >= 6.12 && < 6.14 + if flag(in-ghc-tree) + cpp-options: -DIN_GHC_TREE + extensions: ForeignFunctionInterface + else + build-depends: ghc-paths + if flag(test) cpp-options: -DTEST build-depends: QuickCheck >= 2.1 && < 3 @@ -142,12 +157,13 @@ hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable, ScopedTypeVariables, MagicHash - ghc-options: -funbox-strict-fields -O2 -Wall + ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: Documentation.Haddock other-modules: + Main Haddock.Interface Haddock.Interface.Rename Haddock.Interface.Create @@ -158,14 +174,17 @@ Haddock.Interface.ParseModuleHeader Haddock.Lex Haddock.Parse - Haddock.Utils.BlockTable - Haddock.Utils.Html Haddock.Utils - Haddock.Backends.Html + 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.DevHelp - Haddock.Backends.HH - Haddock.Backends.HH2 Haddock.Backends.Hoogle Haddock.ModuleTree Haddock.Types diff --git a/haddock.spec b/haddock.spec --- a/haddock.spec +++ b/haddock.spec @@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock -%define version 2.7.2 +%define version 2.8.0 %define release 1 Name: %{name} diff --git a/html/Classic.theme/haskell_icon.gif b/html/Classic.theme/haskell_icon.gif new file mode 100644 Binary files /dev/null and b/html/Classic.theme/haskell_icon.gif differ diff --git a/html/Classic.theme/minus.gif b/html/Classic.theme/minus.gif new file mode 100644 Binary files /dev/null and b/html/Classic.theme/minus.gif differ diff --git a/html/Classic.theme/plus.gif b/html/Classic.theme/plus.gif new file mode 100644 Binary files /dev/null and b/html/Classic.theme/plus.gif differ diff --git a/html/Classic.theme/xhaddock.css b/html/Classic.theme/xhaddock.css new file mode 100644 --- /dev/null +++ b/html/Classic.theme/xhaddock.css @@ -0,0 +1,487 @@ +* { + margin: 0; + padding: 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 { + 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; +} + + + + diff --git a/html/Ocean.std-theme/hslogo-16.png b/html/Ocean.std-theme/hslogo-16.png new file mode 100644 Binary files /dev/null and b/html/Ocean.std-theme/hslogo-16.png differ diff --git a/html/Ocean.std-theme/minus.gif b/html/Ocean.std-theme/minus.gif new file mode 100644 Binary files /dev/null and b/html/Ocean.std-theme/minus.gif differ diff --git a/html/Ocean.std-theme/ocean.css b/html/Ocean.std-theme/ocean.css new file mode 100644 --- /dev/null +++ b/html/Ocean.std-theme/ocean.css @@ -0,0 +1,542 @@ +/* @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 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; +} + +.top p.src { + border-top: 1px solid #ccc; +} + +.subs, .doc { + /* use this selector for one level of indent */ + padding-left: 2em; +} + +.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 */ + +#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/html/Ocean.std-theme/plus.gif b/html/Ocean.std-theme/plus.gif new file mode 100644 Binary files /dev/null and b/html/Ocean.std-theme/plus.gif differ diff --git a/html/Ocean.std-theme/synopsis.png b/html/Ocean.std-theme/synopsis.png new file mode 100644 Binary files /dev/null and b/html/Ocean.std-theme/synopsis.png differ diff --git a/html/frames.html b/html/frames.html --- a/html/frames.html +++ b/html/frames.html @@ -1,27 +1,28 @@ - - - - - - - - - - - - - - - + + + + + + + + + + + + + diff --git a/html/haddock-DEBUG.css b/html/haddock-DEBUG.css deleted file mode 100644 --- a/html/haddock-DEBUG.css +++ /dev/null @@ -1,173 +0,0 @@ -/* -------- Global things --------- */ - -BODY { - background-color: #ffffff; - color: #000000; - font-family: sans-serif; - } - -A:link { color: #0000e0; text-decoration: none } -A:visited { color: #0000a0; text-decoration: none } -A:hover { background-color: #e0e0ff; text-decoration: none } - -TABLE.vanilla { - width: 100%; - border-width: 0px; - background-color: #ffe0e0; - /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ -} - -TD { - border-width: 0px; -} - -TABLE.narrow { - border-width: 0px; -} - -/* --------- Documentation elements ---------- */ - -TD.children { - padding-left: 25px; - } - -TD.synopsis { - padding: 2px; - background-color: #f0f0f0; - font-family: monospace - } - -TD.decl { - padding: 2px; - background-color: #f0f0f0; - font-family: monospace; - white-space: nowrap; - vertical-align: top; - } - -TD.recfield { padding-left: 20px } - -TD.doc { - padding-top: 2px; - padding-left: 10px; - background-color: #e0ffe0; - } - -TD.ndoc { - padding: 2px; - background-color: #e0ffe0; - } - -TD.rdoc { - padding: 2px; - padding-left: 10px; - background-color: #e0ffe0; - width: 100%; - } - -TD.body { - padding-left: 10px - } - -/* ------- Section Headings ------- */ - -TD.section1 { - padding-top: 15px; - font-weight: bold; - font-size: 150% - } - -TD.section2 { - padding-top: 10px; - font-weight: bold; - font-size: 130% - } - -TD.section3 { - padding-top: 5px; - font-weight: bold; - font-size: 110% - } - -TD.section4 { - font-weight: bold; - font-size: 100% - } - -/* -------------- The title bar at the top of the page */ - -TD.infohead { - color: #ffffff; - font-weight: bold; - padding-right: 10px; - text-align: left; -} - -TD.infoval { - color: #ffffff; - padding-right: 10px; - text-align: left; -} - -TD.topbar { - background-color: #000099; - padding: 5px; -} - -TD.title { - color: #ffffff; - padding-left: 10px; - width: 100% - } - -TD.topbut { - padding-left: 5px; - padding-right: 5px; - border-left-width: 1px; - border-left-color: #ffffff; - border-left-style: solid; - white-space: nowrap; - } - -TD.topbut A:link { - color: #ffffff - } - -TD.topbut A:visited { - color: #ffff00 - } - -TD.topbut A:hover { - background-color: #6060ff; - } - -TD.topbut:hover { - background-color: #6060ff - } - -TD.modulebar { - background-color: #0077dd; - padding: 5px; - border-top-width: 1px; - border-top-color: #ffffff; - border-top-style: solid; - } - -/* --------- The page footer --------- */ - -TD.botbar { - background-color: #000099; - color: #ffffff; - padding: 5px - } -TD.botbar A:link { - color: #ffffff; - text-decoration: underline - } -TD.botbar A:visited { - color: #ffff00 - } -TD.botbar A:hover { - background-color: #6060ff - } - diff --git a/html/haddock-util.js b/html/haddock-util.js --- a/html/haddock-util.js +++ b/html/haddock-util.js @@ -1,20 +1,84 @@ // Haddock JavaScript utilities -function toggle(button,id) + +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) { - var n = document.getElementById(id).style; - if (n.display == "none") - { - button.src = "minus.gif"; - n.display = "block"; - } - else - { - button.src = "plus.gif"; - n.display = "none"; - } + 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) + return b; +} + + +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; @@ -134,6 +198,114 @@ function setSynopsis(filename) { if (parent.window.synopsis) { - parent.window.synopsis.location = filename; + 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(); +} + diff --git a/html/haddock.css b/html/haddock.css deleted file mode 100644 --- a/html/haddock.css +++ /dev/null @@ -1,297 +0,0 @@ -/* -------- Global things --------- */ - -BODY { - background-color: #ffffff; - color: #000000; - font-family: sans-serif; - padding: 0 0; - } - -A:link { color: #0000e0; text-decoration: none } -A:visited { color: #0000a0; text-decoration: none } -A:hover { background-color: #e0e0ff; text-decoration: none } - -TABLE.vanilla { - width: 100%; - border-width: 0px; - /* I can't seem to specify cellspacing or cellpadding properly using CSS... */ -} - -TABLE.vanilla2 { - border-width: 0px; -} - -/* font is a little too small in MSIE */ -TT { font-size: 100%; } -PRE { font-size: 100%; } - -LI P { margin: 0pt } - -TD { - border-width: 0px; -} - -TABLE.narrow { - border-width: 0px; -} - -TD.s8 { height: 8px; } -TD.s15 { height: 15px; } - -SPAN.keyword { text-decoration: underline; } - -/* Resize the buttom image to match the text size */ -IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em } - -/* --------- Contents page ---------- */ - -DIV.node { - padding-left: 3em; -} - -DIV.cnode { - padding-left: 1.75em; -} - -SPAN.pkg { - position: absolute; - left: 50em; -} - -/* --------- Documentation elements ---------- */ - -TD.children { - padding-left: 25px; - } - -TD.synopsis { - padding: 2px; - background-color: #f0f0f0; - font-family: monospace - } - -TD.decl { - padding: 2px; - background-color: #f0f0f0; - font-family: monospace; - vertical-align: top; - } - -TD.topdecl { - padding: 2px; - background-color: #f0f0f0; - font-family: monospace; - vertical-align: top; -} - -TABLE.declbar { - border-spacing: 0px; - } - -TD.declname { - width: 100%; - } - -TD.declbut { - padding-left: 5px; - padding-right: 5px; - border-left-width: 1px; - border-left-color: #000099; - border-left-style: solid; - white-space: nowrap; - font-size: small; - } - -/* - arg is just like decl, except that wrapping is not allowed. It is - used for function and constructor arguments which have a text box - to the right, where if wrapping is allowed the text box squashes up - the declaration by wrapping it. -*/ -TD.arg { - padding: 2px; - background-color: #f0f0f0; - font-family: monospace; - vertical-align: top; - white-space: nowrap; - } - -TD.recfield { padding-left: 20px } - -TD.doc { - padding-top: 2px; - padding-left: 10px; - } - -TD.ndoc { - padding: 2px; - } - -TD.rdoc { - padding: 2px; - padding-left: 10px; - width: 100%; - } - -TD.body { - padding-left: 10px - } - -TD.pkg { - width: 100%; - padding-left: 10px -} - -TABLE.indexsearch TR.indexrow { - display: none; -} -TABLE.indexsearch TR.indexshow { - display: table-row; -} - -TD.indexentry { - vertical-align: top; - padding-right: 10px - } - -TD.indexannot { - vertical-align: top; - padding-left: 20px; - white-space: nowrap - } - -TD.indexlinks { - width: 100% - } - -/* ------- Section Headings ------- */ - -TD.section1 { - padding-top: 15px; - font-weight: bold; - font-size: 150% - } - -TD.section2 { - padding-top: 10px; - font-weight: bold; - font-size: 130% - } - -TD.section3 { - padding-top: 5px; - font-weight: bold; - font-size: 110% - } - -TD.section4 { - font-weight: bold; - font-size: 100% - } - -/* -------------- The title bar at the top of the page */ - -TD.infohead { - color: #ffffff; - font-weight: bold; - padding-right: 10px; - text-align: left; -} - -TD.infoval { - color: #ffffff; - padding-right: 10px; - text-align: left; -} - -TD.topbar { - background-color: #000099; - padding: 5px; -} - -TD.title { - color: #ffffff; - padding-left: 10px; - width: 100% - } - -TD.topbut { - padding-left: 5px; - padding-right: 5px; - border-left-width: 1px; - border-left-color: #ffffff; - border-left-style: solid; - white-space: nowrap; - } - -TD.topbut A:link { - color: #ffffff - } - -TD.topbut A:visited { - color: #ffff00 - } - -TD.topbut A:hover { - background-color: #6060ff; - } - -TD.topbut:hover { - background-color: #6060ff - } - -TD.modulebar { - background-color: #0077dd; - padding: 5px; - border-top-width: 1px; - border-top-color: #ffffff; - border-top-style: solid; - } - -/* --------- The page footer --------- */ - -TD.botbar { - background-color: #000099; - color: #ffffff; - padding: 5px - } -TD.botbar A:link { - color: #ffffff; - text-decoration: underline - } -TD.botbar A:visited { - color: #ffff00 - } -TD.botbar A:hover { - background-color: #6060ff - } - -/* --------- Mini Synopsis for Frame View --------- */ - -.outer { - margin: 0 0; - padding: 0 0; -} - -.mini-synopsis { - padding: 0.25em 0.25em; -} - -.mini-synopsis H1 { font-size: 130%; } -.mini-synopsis H2 { font-size: 110%; } -.mini-synopsis H3 { font-size: 100%; } -.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 { - margin-top: 0.5em; - margin-bottom: 0.25em; - padding: 0 0; -} - -.mini-synopsis H1 { border-bottom: 1px solid #ccc; } - -.mini-topbar { - font-size: 130%; - background: #0077dd; - padding: 0.25em; -} - - diff --git a/html/haskell_icon.gif b/html/haskell_icon.gif deleted file mode 100644 Binary files a/html/haskell_icon.gif and /dev/null differ diff --git a/html/minus.gif b/html/minus.gif deleted file mode 100644 Binary files a/html/minus.gif and /dev/null differ diff --git a/html/plus.gif b/html/plus.gif deleted file mode 100644 Binary files a/html/plus.gif and /dev/null differ diff --git a/latex/haddock.sty b/latex/haddock.sty new file mode 100644 --- /dev/null +++ b/latex/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs --- a/src/Documentation/Haddock.hs +++ b/src/Documentation/Haddock.hs @@ -11,21 +11,21 @@ -- 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(..), + Decl, DeclInfo, DocForDecl, - FnArgsDoc, - + FnArgsDoc, + -- * Hyperlinking LinkEnv, DocName(..), @@ -37,8 +37,10 @@ -- * Documentation comments Doc(..), + Example(..), DocMarkup(..), HaddockModInfo(..), + markup, -- * Interface files -- | (.haddock files) @@ -47,7 +49,7 @@ nameCacheFromGhc, freshNameCache, NameCacheAccessor, - + -- * Flags and options Flag(..), DocOption(..) @@ -59,3 +61,19 @@ import Haddock.Interface import Haddock.Types import Haddock.Options +import Haddock.Utils +import Main + + +-- | 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, _) <- readPackagesAndProcessModules flags modules + return ifaces + diff --git a/src/Haddock/Backends/DevHelp.hs b/src/Haddock/Backends/DevHelp.hs deleted file mode 100644 --- a/src/Haddock/Backends/DevHelp.hs +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.DevHelp --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ - -module Haddock.Backends.DevHelp (ppDevHelpFile) where - -import Haddock.ModuleTree -import Haddock.Types hiding (Doc) -import Haddock.Utils - -import Module -import Name ( Name, nameModule, getOccString, nameOccName ) - -import Data.Maybe ( fromMaybe ) -import qualified Data.Map as Map -import Text.PrettyPrint - -ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO () -ppDevHelpFile odir doctitle maybe_package ifaces = do - let devHelpFile = package++".devhelp" - tree = mkModuleTree True [ (ifaceMod iface, toDescription iface) | iface <- ifaces ] - doc = - text "" $$ - (text "text doctitle<> - text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$ - text "" $$ - nest 4 (ppModuleTree [] tree) $+$ - text "" $$ - text "" $$ - nest 4 (ppList index) $+$ - text "" $$ - text "" - writeFile (pathJoin [odir, devHelpFile]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppModuleTree :: [String] -> [ModuleTree] -> Doc - ppModuleTree ss [x] = ppNode ss x - ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs - ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf _ _short ts) = - case ts of - [] -> text "ppAttribs<>text "/>" - _ -> - text "ppAttribs<>text ">" $$ - nest 4 (ppModuleTree (s:ss) ts) $+$ - text "" - where - ppLink | leaf = text (moduleHtmlFile (mkModule (stringToPackageId "") - (mkModuleName mdl))) - | otherwise = empty - - ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink - - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - - index :: [(Name, [Module])] - index = Map.toAscList (foldr getModuleIndex Map.empty ifaces) - - getModuleIndex iface fm = - Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | name <- ifaceExports iface, nameModule name == mdl]) fm - where mdl = ifaceMod iface - - ppList :: [(Name, [Module])] -> Doc - ppList [] = empty - ppList ((name,refs):mdls) = - ppReference name refs $$ - ppList mdls - - ppReference :: Name -> [Module] -> Doc - ppReference _ [] = empty - ppReference name (mdl:refs) = - text "text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$ - ppReference name refs diff --git a/src/Haddock/Backends/HH.hs b/src/Haddock/Backends/HH.hs deleted file mode 100644 --- a/src/Haddock/Backends/HH.hs +++ /dev/null @@ -1,186 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.HH --- Copyright : (c) Simon Marlow 2003 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ - -module Haddock.Backends.HH (ppHHContents, ppHHIndex, ppHHProject) where - -ppHHContents, ppHHIndex, ppHHProject :: a -ppHHContents = error "not yet" -ppHHIndex = error "not yet" -ppHHProject = error "not yet" - -{- -import HaddockModuleTree -import HaddockTypes -import HaddockUtil -import HsSyn2 hiding(Doc) -import qualified Map - -import Data.Char ( toUpper ) -import Data.Maybe ( fromMaybe ) -import Text.PrettyPrint - -ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () -ppHHContents odir doctitle maybe_package tree = do - let contentsHHFile = package++".hhc" - - html = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - ppModuleTree tree $$ - text "" - writeFile (pathJoin [odir, contentsHHFile]) (render html) - where - package = fromMaybe "pkg" maybe_package - - ppModuleTree :: [ModuleTree] -> Doc - ppModuleTree ts = - text "" $$ - text "" $$ - text "" $$ - text "
      " $+$ - nest 4 (text "
    • " <> nest 4 - (text "" $$ - nest 4 (text "text doctitle<>text "\">" $$ - text "") $$ - text "") $+$ - text "
      • " $$ - text "
        " $+$ - nest 4 (fn [] ts) $+$ - text "
      ") $+$ - text "
    " - - fn :: [String] -> [ModuleTree] -> Doc - fn ss [x] = ppNode ss x - fn ss (x:xs) = ppNode ss x $$ fn ss xs - fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf _pkg _ []) = - ppLeaf s ss leaf - ppNode ss (Node s leaf _pkg _ ts) = - ppLeaf s ss leaf $$ - text "
      " $+$ - nest 4 (fn (s:ss) ts) $+$ - text "
    " - - ppLeaf s ss isleaf = - text "
  • " <> nest 4 - (text "" $$ - text " text s <> text "\">" $$ - (if isleaf then text " text (moduleHtmlFile mdl) <> text "\">" else empty) $$ - text "") $+$ - text "
    • " - where - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - -------------------------------- -ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO () -ppHHIndex odir maybe_package ifaces = do - let indexHHFile = package++".hhk" - - html = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "
      " $+$ - nest 4 (ppList index) $+$ - text "
    " $$ - text "" - writeFile (pathJoin [odir, indexHHFile]) (render html) - where - package = fromMaybe "pkg" maybe_package - - index :: [(HsName, [Module])] - index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - - getIfaceIndex iface fm = - foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl'] - where mdl = iface_module iface - - ppList [] = empty - ppList ((name,refs):mdls) = - text "
  • " <> nest 4 - (text "" $$ - text " text (show name) <> text "\">" $$ - ppReference name refs $$ - text "") $+$ - text "
    • " $$ - ppList mdls - - ppReference name [] = empty - ppReference name (Module mdl:refs) = - text " text (nameHtmlRef mdl name) <> text "\">" $$ - ppReference name refs - - -ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO () -ppHHProject odir doctitle maybe_package ifaces pkg_paths = do - let projectHHFile = package++".hhp" - doc = - text "[OPTIONS]" $$ - text "Compatibility=1.1 or later" $$ - text "Compiled file=" <> text package <> text ".chm" $$ - text "Contents file=" <> text package <> text ".hhc" $$ - text "Default topic=" <> text contentsHtmlFile $$ - text "Display compile progress=No" $$ - text "Index file=" <> text package <> text ".hhk" $$ - text "Title=" <> text doctitle $$ - space $$ - text "[FILES]" $$ - ppMods ifaces $$ - text contentsHtmlFile $$ - text indexHtmlFile $$ - ppIndexFiles chars $$ - ppLibFiles ("":pkg_paths) - writeFile (pathJoin [odir, projectHHFile]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppMods [] = empty - ppMods (iface:ifaces) = - let Module mdl = iface_module iface in - text (moduleHtmlFile mdl) $$ - ppMods ifaces - - ppIndexFiles [] = empty - ppIndexFiles (c:cs) = - text (subIndexHtmlFile c) $$ - ppIndexFiles cs - - ppLibFiles [] = empty - ppLibFiles (path:paths) = - ppLibFile cssFile $$ - ppLibFile iconFile $$ - ppLibFile jsFile $$ - ppLibFile plusFile $$ - ppLibFile minusFile $$ - ppLibFiles paths - where - toPath fname | null path = fname - | otherwise = pathJoin [path, fname] - ppLibFile fname = text (toPath fname) - - chars :: [Char] - chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) - - getIfaceIndex iface fm = - Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - where mdl = iface_module iface --} diff --git a/src/Haddock/Backends/HH2.hs b/src/Haddock/Backends/HH2.hs deleted file mode 100644 --- a/src/Haddock/Backends/HH2.hs +++ /dev/null @@ -1,197 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.HH2 --- Copyright : (c) Simon Marlow 2003 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ - -module Haddock.Backends.HH2 (ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where - -import Haddock.Types - -ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO () -ppHH2Files = error "not yet" - -ppHH2Contents, ppHH2Index, ppHH2Collection :: a -ppHH2Contents = error "not yet" -ppHH2Index = error "not yet" -ppHH2Collection = error "not yet" - -{- -import HaddockModuleTree -import HaddockUtil -import HsSyn2 hiding(Doc) -import qualified Map - -import Data.Char ( toUpper ) -import Data.Maybe ( fromMaybe ) -import Text.PrettyPrint - -ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () -ppHH2Contents odir doctitle maybe_package tree = do - let - contentsHH2File = package++".HxT" - - doc = - text "" $$ - text "" $$ - text "" $$ - nest 4 (text "text doctitle<>text"\" Url=\"index.html\">" $$ - nest 4 (ppModuleTree [] tree) $+$ - text "") $$ - text "" - writeFile (pathJoin [odir, contentsHH2File]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppModuleTree :: [String] -> [ModuleTree] -> Doc - ppModuleTree ss [x] = ppNode ss x - ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs - ppModuleTree _ [] = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given" - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf _pkg _short []) = - text " ppAttributes leaf (s:ss) <> text "/>" - ppNode ss (Node s leaf _pkg _short ts) = - text " ppAttributes leaf (s:ss) <> text ">" $$ - nest 4 (ppModuleTree (s:ss) ts) $+$ - text "" - - ppAttributes :: Bool -> [String] -> Doc - ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl] - where - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse ss - -- reconstruct the module name - - ppId = text "Id=" <> doubleQuotes (text mdl) - - ppTitle = text "Title=" <> doubleQuotes (text (head ss)) - - ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl)) - | otherwise = empty - ------------------------------------------------------------------------------------ - -ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO () -ppHH2Index odir maybe_package ifaces = do - let - indexKHH2File = package++"K.HxK" - indexNHH2File = package++"N.HxK" - docK = - text "" $$ - text "" $$ - text "" $$ - nest 4 (ppList index) $+$ - text "" - docN = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - nest 4 (text "text contentsHtmlFile<>text "\"/>") $$ - text "" $$ - text "" - writeFile (pathJoin [odir, indexKHH2File]) (render docK) - writeFile (pathJoin [odir, indexNHH2File]) (render docN) - where - package = fromMaybe "pkg" maybe_package - - index :: [(HsName, [Module])] - index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) - - getIfaceIndex iface fm = - Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - where mdl = iface_module iface - - ppList [] = empty - ppList ((name,mdls):vs) = - text " text (escapeStr (show name)) <> text "\">" $$ - nest 4 (vcat (map (ppJump name) mdls)) $$ - text "" $$ - ppList vs - - ppJump name (Module mdl) = text " text (nameHtmlRef mdl name) <> text "\"/>" - - ------------------------------------------------------------------------------------ - -ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO () -ppHH2Files odir maybe_package ifaces pkg_paths = do - let filesHH2File = package++".HxF" - doc = - text "" $$ - text "" $$ - text "" $$ - nest 4 (ppMods ifaces $$ - text "text contentsHtmlFile<>text "\"/>" $$ - text "text indexHtmlFile<>text "\"/>" $$ - ppIndexFiles chars $$ - ppLibFiles ("":pkg_paths)) $$ - text "" - writeFile (pathJoin [odir, filesHH2File]) (render doc) - where - package = fromMaybe "pkg" maybe_package - - ppMods [] = empty - ppMods (iface:ifaces) = - text " text (moduleHtmlFile mdl) <> text "\"/>" $$ - ppMods ifaces - where Module mdl = iface_module iface - - ppIndexFiles [] = empty - ppIndexFiles (c:cs) = - text "text (subIndexHtmlFile c)<>text "\"/>" $$ - ppIndexFiles cs - - ppLibFiles [] = empty - ppLibFiles (path:paths) = - ppLibFile cssFile $$ - ppLibFile iconFile $$ - ppLibFile jsFile $$ - ppLibFile plusFile $$ - ppLibFile minusFile $$ - ppLibFiles paths - where - toPath fname | null path = fname - | otherwise = pathJoin [path, fname] - ppLibFile fname = text "text (toPath fname)<>text "\"/>" - - chars :: [Char] - chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) - - getIfaceIndex iface fm = - Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm - where mdl = iface_module iface - ------------------------------------------------------------------------------------ - -ppHH2Collection :: FilePath -> String -> Maybe String -> IO () -ppHH2Collection odir doctitle maybe_package = do - let - package = fromMaybe "pkg" maybe_package - collectionHH2File = package++".HxC" - - doc = - text "" $$ - text "" $$ - text " text doctitle <> text "\">" $$ - nest 4 (text "" $$ - nest 4 (text " text package <> text ".HxF\"/>") $$ - text "" $$ - text " text package <> text ".HxT\"/>" $$ - text " text package <> text "K.HxK\"/>" $$ - text " text package <> text "N.HxK\"/>" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "") $$ - text "" - writeFile (pathJoin [odir, collectionHH2File]) (render doc) --} diff --git a/src/Haddock/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs --- a/src/Haddock/Backends/HaddockDB.hs +++ b/src/Haddock/Backends/HaddockDB.hs @@ -8,7 +8,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Backends.HaddockDB (ppDocBook) where {- diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -11,7 +11,6 @@ -- Write out Hoogle compatible documentation -- http://www.haskell.org/hoogle/ ----------------------------------------------------------------------------- - module Haddock.Backends.Hoogle ( ppHoogle ) where @@ -145,10 +144,7 @@ f t = HsForAllTy Implicit [] (reL [context]) (reL t) context = reL $ HsClassP (unL $ tcdLName x) - (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x)) - - tyVar (UserTyVar v) = v - tyVar (KindedTyVar v _) = v + (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x)) ppInstance :: Instance -> [String] @@ -191,7 +187,7 @@ name = out $ unL $ con_name con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [x | UserTyVar x <- map unL $ tcdTyVars dat] + ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [hsTyVarName v | v@UserTyVar {} <- map unL $ tcdTyVars dat] ResTyGADT x -> x @@ -243,7 +239,8 @@ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, markupURL = box (TagInline "a") . str, - markupAName = const $ str "" + markupAName = const $ str "", + markupExample = box TagPre . str . unlines . (map exampleToString) } diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs deleted file mode 100644 --- a/src/Haddock/Backends/Html.hs +++ /dev/null @@ -1,1993 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ - -module Haddock.Backends.Html ( - ppHtml, copyHtmlBits, - ppHtmlIndex, ppHtmlContents, - ppHtmlHelpFiles -) where - - -import Prelude hiding (div) - -import Haddock.Backends.DevHelp -import Haddock.Backends.HH -import Haddock.Backends.HH2 -import Haddock.ModuleTree -import Haddock.Types -import Haddock.Version -import Haddock.Utils -import Haddock.Utils.Html hiding ( name, title, p ) -import qualified Haddock.Utils.Html as Html -import Haddock.GhcUtils - -import Control.Exception ( bracket ) -import Control.Monad ( when, unless, join ) -import Data.Char ( toUpper ) -import Data.List ( sortBy, groupBy ) -import Data.Maybe -import Foreign.Marshal.Alloc ( allocaBytes ) -import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) -import System.Directory hiding ( copyFile ) -import Data.Map ( Map ) -import qualified Data.Map as Map hiding ( Map ) -import Data.Function -import Data.Ord ( comparing ) - -import GHC hiding ( NoLink, moduleInfo ) -import Name -import Module -import RdrName hiding ( Qual, is_explicit ) -import FastString ( unpackFS ) -import BasicTypes ( IPName(..), Boxity(..) ) -import Outputable ( ppr, showSDoc, Outputable ) - --- the base, module and entity URLs for the source code and wiki links. -type SourceURLs = (Maybe String, Maybe String, Maybe String) -type WikiURLs = (Maybe String, Maybe String, Maybe String) - - --- ----------------------------------------------------------------------------- --- Generating HTML documentation - -ppHtml :: String - -> Maybe String -- package - -> [Interface] - -> FilePath -- destination directory - -> Maybe (Doc GHC.RdrName) -- prologue text, maybe - -> Maybe String -- the Html Help format (--html-help) - -> SourceURLs -- the source URL (--source) - -> WikiURLs -- the wiki URL (--wiki) - -> Maybe String -- the contents URL (--use-contents) - -> Maybe String -- the index URL (--use-index) - -> Bool -- whether to use unicode in output (--use-unicode) - -> IO () - -ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode = do - let - visible_ifaces = filter visible ifaces - visible i = OptHide `notElem` ifaceOptions i - when (not (isJust maybe_contents_url)) $ - ppHtmlContents odir doctitle maybe_package - maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) - False -- we don't want to display the packages in a single-package contents - prologue - - when (not (isJust maybe_index_url)) $ - ppHtmlIndex odir doctitle maybe_package maybe_html_help_format - maybe_contents_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) - - when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ - ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format [] - - mapM_ (ppHtmlModule odir doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode) visible_ifaces - -ppHtmlHelpFiles - :: String -- doctitle - -> Maybe String -- package - -> [Interface] - -> FilePath -- destination directory - -> Maybe String -- the Html Help format (--html-help) - -> [FilePath] -- external packages paths - -> IO () -ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths = do - let - visible_ifaces = filter visible ifaces - visible i = OptHide `notElem` ifaceOptions i - - -- Generate index and contents page for Html Help if requested - case maybe_html_help_format of - Nothing -> return () - Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths - Just "mshelp2" -> do - ppHH2Files odir maybe_package visible_ifaces pkg_paths - ppHH2Collection odir doctitle maybe_package - Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces - Just format -> fail ("The "++format++" format is not implemented") - -copyFile :: FilePath -> FilePath -> IO () -copyFile fromFPath toFPath = - (bracket (openFile fromFPath ReadMode) hClose $ \hFrom -> - bracket (openFile toFPath WriteMode) hClose $ \hTo -> - allocaBytes bufferSize $ \buffer -> - copyContents hFrom hTo buffer) - where - bufferSize = 1024 - - copyContents hFrom hTo buffer = do - count <- hGetBuf hFrom buffer bufferSize - when (count > 0) $ do - hPutBuf hTo buffer count - copyContents hFrom hTo buffer - - -copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO () -copyHtmlBits odir libdir maybe_css = do - let - libhtmldir = pathJoin [libdir, "html"] - css_file = case maybe_css of - Nothing -> pathJoin [libhtmldir, cssFile] - Just f -> f - css_destination = pathJoin [odir, cssFile] - copyLibFile f = do - copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f]) - copyFile css_file css_destination - mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ] - -footer :: HtmlTable -footer = - tda [theclass "botbar"] << - ( toHtml "Produced by" <+> - (anchor ! [href projectUrl] << toHtml projectName) <+> - toHtml ("version " ++ projectVersion) - ) - -srcButton :: SourceURLs -> Maybe Interface -> HtmlTable -srcButton (Just src_base_url, _, _) Nothing = - topButBox (anchor ! [href src_base_url] << toHtml "Source code") - -srcButton (_, Just src_module_url, _) (Just iface) = - let url = spliceURL (Just $ ifaceOrigFilename iface) - (Just $ ifaceMod iface) Nothing Nothing src_module_url - in topButBox (anchor ! [href url] << toHtml "Source code") - -srcButton _ _ = - Html.emptyTable - -spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> - Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url - where - file = fromMaybe "" maybe_file - mdl = case maybe_mod of - Nothing -> "" - Just m -> moduleString m - - (name, kind) = - case maybe_name of - Nothing -> ("","") - Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") - | otherwise -> (escapeStr (getOccString n), "t") - - line = case maybe_loc of - Nothing -> "" - Just span_ -> show $ srcSpanStartLine span_ - - run "" = "" - run ('%':'M':rest) = mdl ++ run rest - run ('%':'F':rest) = file ++ run rest - run ('%':'N':rest) = name ++ run rest - run ('%':'K':rest) = kind ++ run rest - run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = "%" ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest - run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest - run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest - run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest - - run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = - map (\x -> if x == '.' then c else x) mdl ++ run rest - - run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = - map (\x -> if x == '/' then c else x) file ++ run rest - - run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest - - run (c:rest) = c : run rest - -wikiButton :: WikiURLs -> Maybe Module -> HtmlTable -wikiButton (Just wiki_base_url, _, _) Nothing = - topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments") - -wikiButton (_, Just wiki_module_url, _) (Just mdl) = - let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url - in topButBox (anchor ! [href url] << toHtml "User Comments") - -wikiButton _ _ = - Html.emptyTable - -contentsButton :: Maybe String -> HtmlTable -contentsButton maybe_contents_url - = topButBox (anchor ! [href url] << toHtml "Contents") - where url = maybe contentsHtmlFile id maybe_contents_url - -indexButton :: Maybe String -> HtmlTable -indexButton maybe_index_url - = topButBox (anchor ! [href url] << toHtml "Index") - where url = maybe indexHtmlFile id maybe_index_url - -simpleHeader :: String -> Maybe String -> Maybe String - -> SourceURLs -> WikiURLs -> HtmlTable -simpleHeader doctitle maybe_contents_url maybe_index_url - maybe_source_url maybe_wiki_url = - (tda [theclass "topbar"] << - vanillaTable << ( - (td << - image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] - ) <-> - (tda [theclass "title"] << toHtml doctitle) <-> - srcButton maybe_source_url Nothing <-> - wikiButton maybe_wiki_url Nothing <-> - contentsButton maybe_contents_url <-> indexButton maybe_index_url - )) - -pageHeader :: String -> Interface -> String - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> HtmlTable -pageHeader mdl iface doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url = - (tda [theclass "topbar"] << - vanillaTable << ( - (td << - image ! [src "haskell_icon.gif", width "16", height 16, alt " "] - ) <-> - (tda [theclass "title"] << toHtml doctitle) <-> - srcButton maybe_source_url (Just iface) <-> - wikiButton maybe_wiki_url (Just $ ifaceMod iface) <-> - contentsButton maybe_contents_url <-> - indexButton maybe_index_url - ) - ) - tda [theclass "modulebar"] << - (vanillaTable << ( - (td << font ! [size "6"] << toHtml mdl) <-> - moduleInfo iface - ) - ) - -moduleInfo :: Interface -> HtmlTable -moduleInfo iface = - let - info = ifaceInfo iface - - doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable - doOneEntry (fieldName,field) = case field info of - Nothing -> Nothing - Just fieldValue -> - Just ((tda [theclass "infohead"] << toHtml fieldName) - <-> (tda [theclass "infoval"]) << toHtml fieldValue) - - entries :: [HtmlTable] - entries = mapMaybe doOneEntry [ - ("Portability",hmi_portability), - ("Stability",hmi_stability), - ("Maintainer",hmi_maintainer) - ] - in - case entries of - [] -> Html.emptyTable - _ -> tda [align "right"] << narrowTable << (foldl1 () entries) - --- --------------------------------------------------------------------------- --- Generate the module contents - -ppHtmlContents - :: FilePath - -> String - -> Maybe String - -> Maybe String - -> Maybe String - -> SourceURLs - -> WikiURLs - -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) - -> IO () -ppHtmlContents odir doctitle - maybe_package maybe_html_help_format maybe_index_url - maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do - let tree = mkModuleTree showPkgs - [(instMod iface, toInstalledDescription iface) | iface <- ifaces] - html = - header - (documentCharacterEncoding +++ - thetitle (toHtml doctitle) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ - body << vanillaTable << ( - simpleHeader doctitle Nothing maybe_index_url - maybe_source_url maybe_wiki_url - ppPrologue doctitle prologue - ppModuleTree doctitle tree - s15 - footer - ) - createDirectoryIfMissing True odir - writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html) - - -- XXX: think of a better place for this? - ppHtmlContentsFrame odir doctitle ifaces - - -- Generate contents page for Html Help if requested - case maybe_html_help_format of - Nothing -> return () - Just "mshelp" -> ppHHContents odir doctitle maybe_package tree - Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree - Just "devhelp" -> return () - Just format -> fail ("The "++format++" format is not implemented") - -ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> HtmlTable -ppPrologue _ Nothing = Html.emptyTable -ppPrologue title (Just doc) = - (tda [theclass "section1"] << toHtml title) - docBox (rdrDocToHtml doc) - -ppModuleTree :: String -> [ModuleTree] -> HtmlTable -ppModuleTree _ ts = - tda [theclass "section1"] << toHtml "Modules" - td << vanillaTable2 << htmlTable - where - genTable tbl id_ [] = (tbl, id_) - genTable tbl id_ (x:xs) = genTable (tbl u) id' xs - where - (u,id') = mkNode [] x 0 id_ - - (htmlTable,_) = genTable emptyTable 0 ts - -mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int) -mkNode ss (Node s leaf pkg short ts) depth id_ = htmlNode - where - htmlNode = case ts of - [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id_) - _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg - (td_subtree << sub_tree), id') - - mod_width = 50::Int {-em-} - - td_pad_w :: Double -> Int -> Html -> HtmlTable - td_pad_w pad depth_ = - tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++ - "width: " ++ show (mod_width - depth_*2) ++ "em")] - - td_w depth_ = - tda [thestyle ("width: " ++ show (mod_width - depth_*2) ++ "em")] - - td_subtree = - tda [thestyle ("padding: 0; padding-left: 2em")] - - shortDescr :: HtmlTable - shortDescr = case short of - Nothing -> td empty - Just doc -> tda [theclass "rdoc"] (origDocToHtml doc) - - htmlModule - | leaf = ppModule (mkModule (stringToPackageId pkgName) - (mkModuleName mdl)) "" - | otherwise = toHtml s - - -- ehm.. TODO: change the ModuleTree type - (htmlPkg, pkgName) = case pkg of - Nothing -> (td << empty, "") - Just p -> (td << toHtml p, p) - - mdl = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - - id_s = "n." ++ show id_ - - (sub_tree,id') = genSubTree emptyTable (id_+1) ts - - genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int) - genSubTree htmlTable id__ [] = (sub_tree_, id__) - where - sub_tree_ = collapsed vanillaTable2 id_s htmlTable - genSubTree htmlTable id__ (x:xs) = genSubTree (htmlTable u) id__' xs - where - (u,id__') = mkNode (s:ss) x (depth+1) id__ - --- The URL for source and wiki links, and the current module -type LinksInfo = (SourceURLs, WikiURLs) - --- | Turn a module tree into a flat list of full module names. E.g., --- @ --- A --- +-B --- +-C --- @ --- becomes --- @["A", "A.B", "A.B.C"]@ -flatModuleTree :: [InstalledInterface] -> [Html] -flatModuleTree ifaces = - map (uncurry ppModule' . head) - . groupBy ((==) `on` fst) - . sortBy (comparing fst) - $ mods - where - mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] - ppModule' txt mdl = - anchor ! [href ((moduleHtmlFile mdl)), target mainFrameName] - << toHtml txt - -ppHtmlContentsFrame :: FilePath -> String -> [InstalledInterface] -> IO () -ppHtmlContentsFrame odir doctitle ifaces = do - let mods = flatModuleTree ifaces - html = - header - (documentCharacterEncoding +++ - thetitle (toHtml doctitle) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ - body << vanillaTable << Html.p << ( - foldr (+++) noHtml (map (+++br) mods)) - createDirectoryIfMissing True odir - writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderHtml html) - --- --------------------------------------------------------------------------- --- Generate the index - -ppHtmlIndex :: FilePath - -> String - -> Maybe String - -> Maybe String - -> Maybe String - -> SourceURLs - -> WikiURLs - -> [InstalledInterface] - -> IO () -ppHtmlIndex odir doctitle maybe_package maybe_html_help_format - maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do - let html = - header (documentCharacterEncoding +++ - thetitle (toHtml (doctitle ++ " (Index)")) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ - body << vanillaTable << ( - simpleHeader doctitle maybe_contents_url Nothing - maybe_source_url maybe_wiki_url - index_html - ) - - createDirectoryIfMissing True odir - - when split_indices $ - mapM_ (do_sub_index index) initialChars - - writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html) - - -- Generate index and contents page for Html Help if requested - case maybe_html_help_format of - Nothing -> return () - Just "mshelp" -> ppHHIndex odir maybe_package ifaces - Just "mshelp2" -> ppHH2Index odir maybe_package ifaces - Just "devhelp" -> return () - Just format -> fail ("The "++format++" format is not implemented") - where - - index_html - | split_indices = - tda [theclass "section1"] << - toHtml ("Index") - indexInitialLetterLinks - | otherwise = - td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] << - aboves (map indexElt index)) - - -- an arbitrary heuristic: - -- too large, and a single-page will be slow to load - -- too small, and we'll have lots of letter-indexes with only one - -- or two members in them, which seems inefficient or - -- unnecessarily hard to use. - split_indices = length index > 150 - - setTrClass :: Html -> Html - setTrClass (Html xs) = Html $ map f xs - where - f (HtmlTag name attrs inner) - | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner - | otherwise = HtmlTag name attrs (setTrClass inner) - f x = x - - indexInitialLetterLinks = - td << setTrClass (table ! [cellpadding 0, cellspacing 5] << - besides [ td << anchor ! [href (subIndexHtmlFile c)] << - toHtml [c] - | c <- initialChars - , any ((==c) . toUpper . head . fst) index ]) - - -- todo: what about names/operators that start with Unicode - -- characters? - -- Exports beginning with '_' can be listed near the end, - -- presumably they're not as important... but would be listed - -- with non-split index! - initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" - - do_sub_index this_ix c - = unless (null index_part) $ - writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html) - where - html = header (documentCharacterEncoding +++ - thetitle (toHtml (doctitle ++ " (Index)")) +++ - styleSheet) +++ - body << vanillaTable << ( - simpleHeader doctitle maybe_contents_url Nothing - maybe_source_url maybe_wiki_url - indexInitialLetterLinks - tda [theclass "section1"] << - toHtml ("Index (" ++ c:")") - td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] << - aboves (map indexElt index_part) ) - ) - - index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] - - - index :: [(String, Map GHC.Name [(Module,Bool)])] - index = sortBy cmp (Map.toAscList full_index) - where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2 - - -- for each name (a plain string), we have a number of original HsNames that - -- it can refer to, and for each of those we have a list of modules - -- that export that entity. Each of the modules exports the entity - -- in a visible or invisible way (hence the Bool). - full_index :: Map String (Map GHC.Name [(Module,Bool)]) - full_index = Map.fromListWith (flip (Map.unionWith (++))) - (concat (map getIfaceIndex ifaces)) - - getIfaceIndex iface = - [ (getOccString name - , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])]) - | name <- instExports iface ] - where mdl = instMod iface - - indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable - indexElt (str, entities) = - case Map.toAscList entities of - [(nm,entries)] -> - tda [ theclass "indexentry" ] << toHtml str <-> - indexLinks nm entries - many_entities -> - tda [ theclass "indexentry" ] << toHtml str - aboves (map doAnnotatedEntity (zip [1..] many_entities)) - - doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable - doAnnotatedEntity (j,(nm,entries)) - = tda [ theclass "indexannot" ] << - toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> - indexLinks nm entries - - ppAnnot n | not (isValOcc n) = toHtml "Type/Class" - | isDataOcc n = toHtml "Data Constructor" - | otherwise = toHtml "Function" - - indexLinks nm entries = - tda [ theclass "indexlinks" ] << - hsep (punctuate comma - [ if visible then - linkId mdl (Just nm) << toHtml (moduleString mdl) - else - toHtml (moduleString mdl) - | (mdl, visible) <- entries ]) - --- --------------------------------------------------------------------------- --- Generate the HTML page for a module - -ppHtmlModule - :: FilePath -> String - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool - -> Interface -> IO () -ppHtmlModule odir doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url unicode iface = do - let - mdl = ifaceMod iface - mdl_str = moduleString mdl - html = - header (documentCharacterEncoding +++ - thetitle (toHtml mdl_str) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml) +++ - (script ! [thetype "text/javascript"] - -- XXX: quoting errors possible? - << Html [HtmlString ("window.onload = function () {setSynopsis(\"mini_" - ++ moduleHtmlFile mdl ++ "\")};")]) - ) +++ - body << vanillaTable << ( - pageHeader mdl_str iface doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url s15 - ifaceToHtml maybe_source_url maybe_wiki_url iface unicode s15 - footer - ) - createDirectoryIfMissing True odir - writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html) - ppHtmlModuleMiniSynopsis odir doctitle iface unicode - -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO () -ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do - let mdl = ifaceMod iface - html = - header - (documentCharacterEncoding +++ - thetitle (toHtml $ moduleString mdl) +++ - styleSheet +++ - (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ - body << thediv ! [ theclass "outer" ] << ( - (thediv ! [theclass "mini-topbar"] - << toHtml (moduleString mdl)) +++ - miniSynopsis mdl iface unicode) - createDirectoryIfMissing True odir - writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderHtml html) - -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> HtmlTable -ifaceToHtml maybe_source_url maybe_wiki_url iface unicode - = abovesSep s15 (contents ++ description: synopsis: maybe_doc_hdr: bdy) - where - 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 _ doc _ _) = isJust (fst doc) - has_doc (ExportNoDecl _ _) = False - has_doc (ExportModule _) = False - has_doc _ = True - - no_doc_at_all = not (any has_doc exports) - - contents = case ppModuleContents exports of - Nothing -> [] - Just x -> [td << vanillaTable << x] - - description - = case ifaceRnDoc iface of - Nothing -> Html.emptyTable - Just doc -> (tda [theclass "section1"] << toHtml "Description") - docBox (docToHtml doc) - - -- omit the synopsis if there are no documentation annotations at all - synopsis - | no_doc_at_all = Html.emptyTable - | otherwise - = (tda [theclass "section1"] << toHtml "Synopsis") - s15 - (tda [theclass "body"] << vanillaTable << - abovesSep s8 (map (processExport True linksInfo unicode) - (filter forSummary exports)) - ) - - -- if the documentation doesn't begin with a section header, then - -- add one ("Documentation"). - maybe_doc_hdr - = case exports of - [] -> Html.emptyTable - ExportGroup _ _ _ : _ -> Html.emptyTable - _ -> tda [ theclass "section1" ] << toHtml "Documentation" - - bdy = map (processExport False linksInfo unicode) exports - linksInfo = (maybe_source_url, maybe_wiki_url) - -miniSynopsis :: Module -> Interface -> Bool -> Html -miniSynopsis mdl iface unicode = - thediv ! [ theclass "mini-synopsis" ] - << hsep (map (processForMiniSynopsis mdl unicode) $ exports) - where - exports = numberSectionHeadings (ifaceRnExportItems iface) - -processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Html -processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) = - thediv ! [theclass "decl" ] << - case decl0 of - TyClD d@(TyFamily{}) -> ppTyFamHeader True False d unicode - TyClD d@(TyData{tcdTyPats = ps}) - | Nothing <- ps -> keyword "data" <++> ppTyClBinderWithVarsMini mdl d - | Just _ <- ps -> keyword "data" <++> keyword "instance" - <++> ppTyClBinderWithVarsMini mdl d - TyClD d@(TySynonym{tcdTyPats = ps}) - | Nothing <- ps -> keyword "type" <++> ppTyClBinderWithVarsMini mdl d - | Just _ <- ps -> keyword "type" <++> keyword "instance" - <++> ppTyClBinderWithVarsMini mdl d - TyClD d@(ClassDecl {}) -> - keyword "class" <++> ppTyClBinderWithVarsMini mdl d - SigD (TypeSig (L _ n) (L _ _)) -> - let nm = docNameOcc n - in ppNameMini mdl nm - _ -> noHtml -processForMiniSynopsis _ _ (ExportGroup lvl _id txt) = - let heading - | lvl == 1 = h1 - | lvl == 2 = h2 - | lvl >= 3 = h3 - | otherwise = error "bad group level" - in heading << docToHtml txt -processForMiniSynopsis _ _ _ = noHtml - -ppNameMini :: Module -> OccName -> Html -ppNameMini mdl nm = - anchor ! [ href ( moduleHtmlFile mdl ++ "#" - ++ (escapeStr (anchorNameStr nm))) - , target mainFrameName ] - << ppBinder' nm - -ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html -ppTyClBinderWithVarsMini mdl decl = - let n = unLoc $ tcdLName decl - ns = tyvarNames $ tcdTyVars decl - in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName - -ppModuleContents :: [ExportItem DocName] -> Maybe HtmlTable -ppModuleContents exports - | length sections == 0 = Nothing - | otherwise = Just (tda [theclass "section4"] << bold << toHtml "Contents" - td << dlist << concatHtml sections) - where - (sections, _leftovers{-should be []-}) = process 0 exports - - process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) - process _ [] = ([], []) - process n items@(ExportGroup lev id0 doc : rest) - | lev <= n = ( [], items ) - | otherwise = ( html:secs, rest2 ) - where - html = (dterm << linkedAnchor id0 << docToHtml doc) - +++ mk_subsections ssecs - (ssecs, rest1) = process lev rest - (secs, rest2) = process n rest1 - process n (_ : rest) = process n rest - - mk_subsections [] = noHtml - mk_subsections ss = ddef << dlist << concatHtml ss - --- we need to assign a unique id to each section heading so we can hyperlink --- them from the contents: -numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] -numberSectionHeadings exports = go 1 exports - where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] - go _ [] = [] - go n (ExportGroup lev _ doc : es) - = ExportGroup lev (show n) doc : go (n+1) es - go n (other:es) - = other : go n es - -processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> HtmlTable -processExport _ _ _ (ExportGroup lev id0 doc) - = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary links unicode (ExportDecl decl doc subdocs insts) - = ppDecl summary links decl doc insts subdocs unicode -processExport _ _ _ (ExportNoDecl y []) - = declBox (ppDocName y) -processExport _ _ _ (ExportNoDecl y subs) - = declBox (ppDocName y <+> parenList (map ppDocName subs)) -processExport _ _ _ (ExportDoc doc) - = docBox (docToHtml doc) -processExport _ _ _ (ExportModule mdl) - = declBox (toHtml "module" <+> ppModule mdl "") - -forSummary :: (ExportItem DocName) -> Bool -forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True - -ppDocGroup :: Int -> Html -> HtmlTable -ppDocGroup lev doc - | lev == 1 = tda [ theclass "section1" ] << doc - | lev == 2 = tda [ theclass "section2" ] << doc - | lev == 3 = tda [ theclass "section3" ] << doc - | otherwise = tda [ theclass "section4" ] << doc - -declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> HtmlTable -declWithDoc True _ _ _ _ html_decl = declBox html_decl -declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl -declWithDoc False links loc nm (Just doc) html_decl = - topDeclBox links loc nm html_decl docBox (docToHtml doc) - - --- TODO: use DeclInfo DocName or something -ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable -ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of - TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode - TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode - | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d - TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode - | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode - SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode - InstD _ -> Html.emptyTable - _ -> error "declaration not supported by ppDecl" - -ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> HsType DocName -> Bool -> HtmlTable -ppFunSig summary links loc doc docname typ unicode = - ppTypeOrFunSig summary links loc docname typ doc - (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode - where - occname = docNameOcc docname - -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> - DocForDecl DocName -> (Html, Html, Html) -> Bool -> HtmlTable -ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode - | summary || Map.null argDocs = declWithDoc summary links loc docname doc pref1 - | otherwise = topDeclBox links loc docname pref2 - (tda [theclass "body"] << vanillaTable << ( - do_args 0 sep typ - (case doc of - Just d -> ndocBox (docToHtml d) - Nothing -> Html.emptyTable) - )) - where - argDocHtml n = case Map.lookup n argDocs of - Just adoc -> docToHtml adoc - Nothing -> noHtml - - do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> (HsType DocName) -> HtmlTable - do_args n leader (HsForAllTy Explicit tvs lctxt ltype) - = (argBox ( - leader <+> - hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> - ppLContextNoArrow lctxt unicode) - <-> rdocBox noHtml) - do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Implicit _ lctxt ltype) - | not (null (unLoc lctxt)) - = (argBox (leader <+> ppLContextNoArrow lctxt unicode) - <-> rdocBox noHtml) - 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) - = (argBox (leader <+> ppLFunLhType unicode lt) <-> rdocBox (argDocHtml n)) - do_largs (n+1) (arrow unicode) r - do_args n leader t - = argBox (leader <+> ppType unicode t) <-> rdocBox (argDocHtml n) - - -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] -ppTyVars tvs = map ppTyName (tyvarNames tvs) - - -tyvarNames :: [LHsTyVarBndr DocName] -> [Name] -tyvarNames = map (getName . hsTyVarName . unLoc) - - -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> HtmlTable -ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode - = ppFunSig summary links loc doc name typ unicode -ppFor _ _ _ _ _ _ = error "ppFor" - - --- we skip type patterns for now -ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> HtmlTable -ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode - = ppTypeOrFunSig summary links loc name (unLoc ltype) doc - (full, hdr, spaceHtml +++ equals) unicode - where - hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) - full = hdr <+> equals <+> ppLType unicode ltype - occ = docNameOcc name -ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn" - - -ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html -ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty - - -ppTyName :: Name -> Html -ppTyName name - | isNameSym name = parens (ppName name) - | otherwise = ppName name - - --------------------------------------------------------------------------------- --- Type families --------------------------------------------------------------------------------- - - -ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html -ppTyFamHeader summary associated decl unicode = - - (case tcdFlavour decl of - TypeFamily - | associated -> keyword "type" - | otherwise -> keyword "type family" - DataFamily - | associated -> keyword "data" - | otherwise -> keyword "data family" - ) <+> - - ppTyClBinderWithVars summary decl <+> - - case tcdKind decl of - Just kind -> dcolon unicode <+> ppKind kind - Nothing -> empty - - -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> HtmlTable -ppTyFam summary associated links loc mbDoc decl unicode - - | summary = declWithDoc summary links loc docname mbDoc - (ppTyFamHeader True associated decl unicode) - - | associated, isJust mbDoc = header_ bodyBox << doc - | associated = header_ - | null instances, isJust mbDoc = header_ bodyBox << doc - | null instances = header_ - | isJust mbDoc = header_ bodyBox << (doc instancesBit) - | otherwise = header_ bodyBox << instancesBit - - where - docname = tcdName decl - - header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode) - - doc = ndocBox . docToHtml . fromJust $ mbDoc - - instId = collapseId (getName docname) - - instancesBit = instHdr instId - tda [theclass "body"] << - collapsed thediv instId ( - spacedTable1 << ( - aboves (map (ppDocInstance unicode) instances) - ) - ) - - -- TODO: get the instances - instances = [] - - --------------------------------------------------------------------------------- --- Indexed data types --------------------------------------------------------------------------------- - - -ppDataInst :: a -ppDataInst = undefined - - --------------------------------------------------------------------------------- --- Indexed newtypes --------------------------------------------------------------------------------- - --- TODO --- ppNewTyInst = undefined - - --------------------------------------------------------------------------------- --- Indexed types --------------------------------------------------------------------------------- - - -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> HtmlTable -ppTyInst summary associated links loc mbDoc decl unicode - - | summary = declWithDoc summary links loc docname mbDoc - (ppTyInstHeader True associated decl unicode) - - | isJust mbDoc = header_ bodyBox << doc - | otherwise = header_ - - where - docname = tcdName decl - - header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode) - - doc = case mbDoc of - Just d -> ndocBox (docToHtml d) - Nothing -> Html.emptyTable - - -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html -ppTyInstHeader _ _ decl unicode = - keyword "type instance" <+> - ppAppNameTypes (tcdName decl) typeArgs unicode - where - typeArgs = map unLoc . fromJust . tcdTyPats $ decl - - --------------------------------------------------------------------------------- --- Associated Types --------------------------------------------------------------------------------- - - -ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> HtmlTable -ppAssocType summ links doc (L loc decl) unicode = - case decl of - TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode - TySynonym {} -> ppTySyn summ links loc doc decl unicode - _ -> error "declaration type not supported by ppAssocType" - - --------------------------------------------------------------------------------- --- TyClDecl helpers --------------------------------------------------------------------------------- - - --- | Print a type family / newtype / data / class binder and its variables -ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html -ppTyClBinderWithVars summ decl = - ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) - - --------------------------------------------------------------------------------- --- Type applications --------------------------------------------------------------------------------- - - --- | Print an application of a DocName and a list of HsTypes -ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html -ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) - - --- | Print an application of a DocName and a list of Names -ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html -ppAppDocNameNames summ n ns = - ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName - - --- | General printing of type applications -ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html -ppTypeApp n (t1:t2:rest) ppDN ppT - | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) - | operator = opApp - where - operator = isNameSym . getName $ n - opApp = ppT t1 <+> ppDN n <+> ppT t2 - -ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) - - -------------------------------------------------------------------------------- --- Contexts -------------------------------------------------------------------------------- - - -ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html -ppLContext = ppContext . unLoc -ppLContextNoArrow = ppContextNoArrow . unLoc - - -ppContextNoArrow :: HsContext DocName -> Bool -> Html -ppContextNoArrow [] _ = empty -ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode - - -ppContextNoLocs :: [HsPred DocName] -> Bool -> Html -ppContextNoLocs [] _ = empty -ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode - - -ppContext :: HsContext DocName -> Bool -> Html -ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode - - -pp_hs_context :: [HsPred DocName] -> Bool -> Html -pp_hs_context [] _ = empty -pp_hs_context [p] unicode = ppPred unicode p -pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) - - -ppPred :: Bool -> HsPred DocName -> Html -ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode -ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2 -ppPred unicode (HsIParam (IPName n) t) - = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t - - -------------------------------------------------------------------------------- --- Class declarations -------------------------------------------------------------------------------- - - -ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName - -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] - -> Bool -> Html -ppClassHdr summ lctxt n tvs fds unicode = - keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode - - -ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html -ppFds fds unicode = - if null fds then noHtml else - char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) - where - fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> - hsep (map ppDocName vars2) - -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = - if null sigs && null ats - then (if summary then declBox else topDeclBox links loc nm) hdr - else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") - - ( - bodyBox << - aboves - ( - [ ppAssocType summary links doc at unicode | at <- ats - , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ - - [ ppFunSig summary links loc doc n typ unicode - | L _ (TypeSig (L _ n) (L _ typ)) <- sigs - , let doc = lookupAnySubdoc n subdocs ] - ) - ) - where - hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode - nm = unLoc lname -ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - - - -ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] - -> TyClDecl DocName -> Bool -> HtmlTable -ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode - | summary = ppShortClassDecl summary links decl loc subdocs unicode - | otherwise = classheader bodyBox << (classdoc body_ instancesBit) - where - classheader - | null lsigs = topDeclBox links loc nm (hdr unicode) - | otherwise = topDeclBox links loc nm (hdr unicode <+> keyword "where") - - nm = unLoc $ tcdLName decl - - hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds - - classdoc = case mbDoc of - Nothing -> Html.emptyTable - Just d -> ndocBox (docToHtml d) - - body_ - | null lsigs, null ats = Html.emptyTable - | null ats = s8 methHdr bodyBox << methodTable - | otherwise = s8 atHdr bodyBox << atTable - s8 methHdr bodyBox << methodTable - - methodTable = - abovesSep s8 [ ppFunSig summary links loc doc n typ unicode - | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs - , let doc = lookupAnySubdoc n subdocs ] - - atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats - , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] - - instId = collapseId (getName nm) - instancesBit - | null instances = Html.emptyTable - | otherwise - = s8 instHdr instId - tda [theclass "body"] << - collapsed thediv instId ( - spacedTable1 << aboves (map (ppDocInstance unicode) instances) - ) -ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" - - --- | 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 -> HtmlTable -ppDocInstance unicode (instHead, maybeDoc) = - argBox (ppInstHead unicode instHead) <-> maybeRDocBox maybeDoc - - -ppInstHead :: Bool -> InstHead DocName -> Html -ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode -ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode - - -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 - - --- TODO: print contexts -ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html -ppShortDataDecl summary links loc dataDecl unicode - - | [lcon] <- cons, ResTyH98 <- resTy = - ppDataHeader summary dataDecl unicode - <+> equals <+> ppShortConstr summary (unLoc lcon) unicode - - | [] <- cons = ppDataHeader summary dataDecl unicode - - | otherwise = vanillaTable << ( - case resTy of - ResTyH98 -> dataHeader - tda [theclass "body"] << vanillaTable << ( - aboves (zipWith doConstr ('=':repeat '|') cons) - ) - ResTyGADT _ -> dataHeader - tda [theclass "body"] << vanillaTable << ( - aboves (map doGADTConstr cons) - ) - ) - - where - dataHeader = - (if summary then declBox else topDeclBox links loc docname) - ((ppDataHeader summary dataDecl unicode) <+> - case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) - - doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode) - doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode) - - docname = unLoc . tcdLName $ dataDecl - cons = tcdCons dataDecl - resTy = (con_res . unLoc . head) cons - -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable -ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode - - | summary = declWithDoc summary links loc docname mbDoc - (ppShortDataDecl summary links loc dataDecl unicode) - - | otherwise - = (if validTable then () else const) header_ $ - tda [theclass "body"] << vanillaTable << ( - datadoc - constrBit - instancesBit - ) - - - where - docname = unLoc . tcdLName $ dataDecl - cons = tcdCons dataDecl - resTy = (con_res . unLoc . head) cons - - header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode - <+> whereBit) - - whereBit - | null cons = empty - | otherwise = case resTy of - ResTyGADT _ -> keyword "where" - _ -> empty - - constrTable - | any isRecCon cons = spacedTable5 - | otherwise = spacedTable1 - - datadoc = case mbDoc of - Just doc -> ndocBox (docToHtml doc) - Nothing -> Html.emptyTable - - constrBit - | null cons = Html.emptyTable - | otherwise = constrHdr ( - tda [theclass "body"] << constrTable << - aboves (map (ppSideBySideConstr subdocs unicode) cons) - ) - - instId = collapseId (getName docname) - - instancesBit - | null instances = Html.emptyTable - | otherwise - = instHdr instId - tda [theclass "body"] << - collapsed thediv instId ( - spacedTable1 << aboves (map (ppDocInstance unicode) instances - ) - ) - - validTable = isJust mbDoc || not (null cons) || not (null instances) - - -isRecCon :: Located (ConDecl a) -> Bool -isRecCon lcon = case con_details (unLoc lcon) of - RecCon _ -> True - _ -> False - - -ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html -ppShortConstr summary con unicode = case con_res con of - ResTyH98 -> case con_details con of - PrefixCon args -> header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args) - RecCon fields -> header_ unicode +++ ppBinder summary occ <+> - doRecordFields fields - InfixCon arg1 arg2 -> header_ unicode +++ - hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2] - - ResTyGADT resTy -> case con_details con of - -- prefix & infix could use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - -- display GADT records with the new syntax, - -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) - -- (except each field gets its own line in docs, to match - -- non-GADT records) - RecCon fields -> ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode, - doRecordFields fields, - arrow unicode <+> ppLType unicode resTy ] - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = braces (vanillaTable << - aboves (map (ppShortField summary unicode) fields)) - doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode, - ppLType unicode (foldr mkFunTy resTy args) ] - - header_ = ppConstrHdr forall tyVars context - occ = docNameOcc . unLoc . con_name $ con - ltvs = con_qvars con - tyVars = tyvarNames ltvs - lcontext = con_cxt con - context = unLoc (con_cxt con) - forall = con_explicit con - mkFunTy a b = noLoc (HsFunTy a b) - --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html -ppConstrHdr forall tvs ctxt unicode - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ") - where - ppForall = case forall of - Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " - Implicit -> empty - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable -ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of - - ResTyH98 -> case con_details con of - - PrefixCon args -> - argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) - <-> maybeRDocBox mbDoc - - RecCon fields -> - argBox (header_ unicode +++ ppBinder False occ) <-> - maybeRDocBox mbDoc - - doRecordFields fields - - InfixCon arg1 arg2 -> - argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2]) - <-> maybeRDocBox mbDoc - - ResTyGADT resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - (tda [theclass "body"] << spacedTable1 << - aboves (map (ppSideBySideField subdocs unicode) fields)) - doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs (con_cxt con) unicode, - ppLType unicode (foldr mkFunTy resTy args) ] - ) <-> maybeRDocBox mbDoc - - - header_ = ppConstrHdr forall tyVars context - occ = docNameOcc . unLoc . con_name $ con - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - forall = con_explicit con - -- 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. - -- 'join' is in Maybe. - mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs - mkFunTy a b = noLoc (HsFunTy a b) - -ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable -ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = - argBox (ppBinder False (docNameOcc name) - <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc - where - -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = join $ fmap fst $ lookup name subdocs - -{- -ppHsFullConstr :: HsConDecl -> Html -ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = - declWithDoc False doc ( - hsep ((ppHsConstrHdr tvs ctxt +++ - ppHsBinder False nm) : map ppHsBangType typeList) - ) -ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = - td << vanillaTable << ( - case doc of - Nothing -> aboves [hdr, fields_html] - Just _ -> aboves [hdr, constr_doc, fields_html] - ) - - where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) - - constr_doc - | isJust doc = docBox (docToHtml (fromJust doc)) - | otherwise = Html.emptyTable - - fields_html = - td << - table ! [width "100%", cellpadding 0, cellspacing 8] << ( - aboves (map ppFullField (concat (map expandField fields))) - ) --} - -ppShortField :: Bool -> Bool -> ConDeclField DocName -> HtmlTable -ppShortField summary unicode (ConDeclField (L _ name) ltype _) - = tda [theclass "recfield"] << ( - ppBinder summary (docNameOcc name) - <+> dcolon unicode <+> ppLType unicode ltype - ) - -{- -ppFullField :: HsFieldDecl -> Html -ppFullField (HsFieldDecl [n] ty doc) - = declWithDoc False doc ( - ppHsBinder False n <+> dcolon <+> ppHsBangType ty - ) -ppFullField _ = error "ppFullField" - -expandField :: HsFieldDecl -> [HsFieldDecl] -expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --} - --- | Print the LHS of a data\/newtype declaration. --- Currently doesn't handle 'data instance' decls or kind signatures -ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html -ppDataHeader summary decl unicode - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> - -- context - ppLContext (tcdCtxt decl) unicode <+> - -- T a b c ..., or a :+: b - ppTyClBinderWithVars summary decl - - --- ---------------------------------------------------------------------------- --- Types and contexts - - -ppKind :: Outputable a => a -> Html -ppKind k = toHtml $ showSDoc (ppr k) - - -{- -ppForAll Implicit _ lctxt = ppCtxtPart lctxt -ppForAll Explicit ltvs lctxt = - hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt --} - - -ppBang :: HsBang -> Html -ppBang HsNoBang = empty -ppBang HsStrict = toHtml "!" -ppBang HsUnbox = toHtml "!" -- unboxed args is an implementation detail, - -- so we just show the strictness annotation - - -tupleParens :: Boxity -> [Html] -> Html -tupleParens Boxed = parenList -tupleParens Unboxed = ubxParenList -{- -ppType :: HsType DocName -> Html -ppType t = case t of - t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype - HsTyVar n -> ppDocName n - HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt - HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt - HsAppTy a b -> ppLType a <+> ppLType b - HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b] - HsListTy t -> brackets $ ppLType t - HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]" - HsTupleTy Boxed ts -> parenList $ map ppLType ts - HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts - HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b - HsParTy t -> parens $ ppLType t - HsNumTy n -> toHtml (show n) - HsPredTy p -> ppPred p - HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k] - HsSpliceTy _ -> error "ppType" - HsDocTy t _ -> ppLType t --} - - --------------------------------------------------------------------------------- --- Rendering of HsType --------------------------------------------------------------------------------- - - -pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> Html -> Html -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html -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 -> Html -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 - - --- Drop top-level for-all type variables in user style --- since they are implicit in Haskell - -ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] - -> Located (HsContext DocName) -> Bool -> Html -ppForAll expl tvs cxt unicode - | show_forall = forall_part <+> ppLContext cxt unicode - | otherwise = ppLContext cxt unicode - where - show_forall = not (null tvs) && is_explicit - is_explicit = case expl of {Explicit -> True; Implicit -> False} - forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot - - -ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html -ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode - - -ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html -ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] - --- gaw 2004 -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b +++ ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) -ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only -ppr_mono_ty _ (HsSpliceTy _) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsSpliceTyOut _) _ = error "ppr_mono_ty HsSpliceTyOut" -ppr_mono_ty _ (HsRecTy _) _ = error "ppr_mono_ty HsRecTy" - - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode - where - ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op - occName = docNameOcc . unLoc $ op - -ppr_mono_ty ctxt_prec (HsParTy ty) unicode --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode - - -ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode - p2 = ppr_mono_lty pREC_TOP ty2 unicode - in - maybeParen ctxt_prec pREC_FUN $ - hsep [p1, arrow unicode <+> p2] - - --- ---------------------------------------------------------------------------- --- Names - -ppOccName :: OccName -> Html -ppOccName = toHtml . occNameString - -ppRdrName :: RdrName -> Html -ppRdrName = ppOccName . rdrNameOcc - -ppLDocName :: Located DocName -> Html -ppLDocName (L _ d) = ppDocName d - -ppDocName :: DocName -> Html -ppDocName (Documented name mdl) = - linkIdOcc mdl (Just occName) << ppOccName occName - where occName = nameOccName name -ppDocName (Undocumented name) = toHtml (getOccString name) - -linkTarget :: OccName -> Html -linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" - -ppName :: Name -> Html -ppName name = toHtml (getOccString name) - - -ppBinder :: Bool -> OccName -> Html --- The Bool indicates whether we are generating the summary, in which case --- the binder will be a link to the full definition. -ppBinder True n = linkedAnchor (anchorNameStr n) << ppBinder' n -ppBinder False n = linkTarget n +++ bold << ppBinder' n - - -ppBinder' :: OccName -> Html -ppBinder' n - | isVarSym n = parens $ ppOccName n - | otherwise = ppOccName n - - -linkId :: Module -> Maybe Name -> Html -> Html -linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) - - -linkIdOcc :: Module -> Maybe OccName -> Html -> Html -linkIdOcc mdl mbName = anchor ! [href uri] - where - uri = case mbName of - Nothing -> moduleHtmlFile mdl - Just name -> nameHtmlRef mdl name - -ppModule :: Module -> String -> Html -ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)] - << toHtml (moduleString mdl) - --- ----------------------------------------------------------------------------- --- * Doc Markup - -parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html -parHtmlMarkup ppId isTyCon = Markup { - markupParagraph = paragraph, - markupEmpty = toHtml "", - markupString = toHtml, - markupAppend = (+++), - markupIdentifier = tt . ppId . choose, - markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref, - markupEmphasis = emphasize . toHtml, - markupMonospaced = tt . toHtml, - markupUnorderedList = ulist . concatHtml . map (li <<), - markupPic = \path -> image ! [src path], - markupOrderedList = olist . concatHtml . map (li <<), - markupDefList = dlist . concatHtml . map markupDef, - markupCodeBlock = pre, - markupURL = \url -> anchor ! [href url] << toHtml url, - markupAName = \aname -> namedAnchor aname << toHtml "" - } - where - -- If an id can refer to multiple things, we give precedence to type - -- constructors. This should ideally be done during renaming from RdrName - -- to Name, but since we will move this process from GHC into Haddock in - -- the future, we fix it here in the meantime. - -- TODO: mention this rule in the documentation. - choose [] = error "empty identifier list in HsDoc" - choose [x] = x - choose (x:y:_) - | isTyCon x = x - | otherwise = y - - -markupDef :: (HTML a, HTML b) => (a, b) -> Html -markupDef (a,b) = dterm << a +++ ddef << b - - -htmlMarkup :: DocMarkup DocName Html -htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName) - -htmlOrigMarkup :: DocMarkup Name Html -htmlOrigMarkup = parHtmlMarkup ppName isTyConName - -htmlRdrMarkup :: DocMarkup RdrName Html -htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc - --- If the doc is a single paragraph, don't surround it with

    (this causes --- ugly extra whitespace with some browsers). -docToHtml :: Doc DocName -> Html -docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) - -origDocToHtml :: Doc Name -> Html -origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) - -rdrDocToHtml :: Doc RdrName -> Html -rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) - --- If there is a single paragraph, then surrounding it with

    ..

    --- can add too much whitespace in some browsers (eg. IE). However if --- we have multiple paragraphs, then we want the extra whitespace to --- separate them. So we catch the single paragraph case and transform it --- here. -unParagraph :: Doc a -> Doc a -unParagraph (DocParagraph d) = d ---NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) ---unParagraph (DocCodeBlock d) = (DocMonospaced d) -unParagraph doc = doc - -htmlCleanup :: DocMarkup a (Doc a) -htmlCleanup = idMarkup { - markupUnorderedList = DocUnorderedList . map unParagraph, - markupOrderedList = DocOrderedList . map unParagraph - } - --- ----------------------------------------------------------------------------- --- * Misc - - -hsep :: [Html] -> Html -hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls - -infixr 8 <+>, <++> -(<+>) :: Html -> Html -> Html -a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (toHtml b)) - -(<++>) :: Html -> Html -> Html -a <++> b = a +++ spaceHtml +++ b - -keyword :: String -> Html -keyword s = thespan ! [theclass "keyword"] << toHtml s - -equals, comma :: Html -equals = char '=' -comma = char ',' - -char :: Char -> Html -char c = toHtml [c] - -empty :: Html -empty = noHtml - - -quote :: Html -> Html -quote h = char '`' +++ h +++ '`' - - -parens, brackets, pabrackets, braces :: Html -> Html -parens h = char '(' +++ h +++ char ')' -brackets h = char '[' +++ h +++ char ']' -pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" -braces h = char '{' +++ h +++ char '}' - -punctuate :: Html -> [Html] -> [Html] -punctuate _ [] = [] -punctuate h (d0:ds) = go d0 ds - where - go d [] = [d] - go d (e:es) = (d +++ h) : go e es - -abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable -abovesSep _ [] = Html.emptyTable -abovesSep h (d0:ds) = go d0 ds - where - go d [] = d - go d (e:es) = d h go e es - -parenList :: [Html] -> Html -parenList = parens . hsep . punctuate comma - -ubxParenList :: [Html] -> Html -ubxParenList = ubxparens . hsep . punctuate comma - -ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" - -{- -text :: Html -text = strAttr "TEXT" --} - --- a box for displaying code -declBox :: Html -> HtmlTable -declBox html = tda [theclass "decl"] << html - --- a box for top level documented names --- it adds a source and wiki link at the right hand side of the box -topDeclBox :: LinksInfo -> SrcSpan -> DocName -> Html -> HtmlTable -topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html -topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) - loc name html = - tda [theclass "topdecl"] << - ( table ! [theclass "declbar"] << - ((tda [theclass "declname"] << html) - <-> srcLink - <-> wikiLink) - ) - where srcLink = - case maybe_source_url of - Nothing -> Html.emptyTable - Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just origMod) - (Just n) (Just loc) url - in anchor ! [href url'] << toHtml "Source" - - wikiLink = - case maybe_wiki_url of - Nothing -> Html.emptyTable - Just url -> tda [theclass "declbut"] << - let url' = spliceURL (Just fname) (Just mdl) - (Just n) (Just loc) url - in anchor ! [href url'] << toHtml "Comments" - - -- For source links, we want to point to the original module, - -- because only that will have the source. - -- TODO: do something about type instances. They will point to - -- the module defining the type family, which is wrong. - origMod = nameModule n - - -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = name - - fname = unpackFS (srcSpanFile loc) - - --- a box for displaying an 'argument' (some code which has text to the --- right of it). Wrapping is not allowed in these boxes, whereas it is --- in a declBox. -argBox :: Html -> HtmlTable -argBox html = tda [theclass "arg"] << html - --- a box for displaying documentation, --- indented and with a little padding at the top -docBox :: Html -> HtmlTable -docBox html = tda [theclass "doc"] << html - --- a box for displaying documentation, not indented. -ndocBox :: Html -> HtmlTable -ndocBox html = tda [theclass "ndoc"] << html - --- a box for displaying documentation, padded on the left a little -rdocBox :: Html -> HtmlTable -rdocBox html = tda [theclass "rdoc"] << html - -maybeRDocBox :: Maybe (Doc DocName) -> HtmlTable -maybeRDocBox Nothing = rdocBox (noHtml) -maybeRDocBox (Just doc) = rdocBox (docToHtml doc) - --- a box for the buttons at the top of the page -topButBox :: Html -> HtmlTable -topButBox html = tda [theclass "topbut"] << html - -bodyBox :: Html -> HtmlTable -bodyBox html = tda [theclass "body"] << vanillaTable << html - --- a vanilla table has width 100%, no border, no padding, no spacing --- a narrow table is the same but without width 100%. -vanillaTable, vanillaTable2, narrowTable :: Html -> Html -vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] -vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0] -narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] - -spacedTable1, spacedTable5 :: Html -> Html -spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] -spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] - -constrHdr, methHdr, atHdr :: HtmlTable -constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" -methHdr = tda [ theclass "section4" ] << toHtml "Methods" -atHdr = tda [ theclass "section4" ] << toHtml "Associated Types" - -instHdr :: String -> HtmlTable -instHdr id_ = - tda [ theclass "section4" ] << (collapsebutton id_ +++ toHtml " Instances") - -dcolon, arrow, darrow, forallSymbol :: Bool -> Html -dcolon unicode = toHtml (if unicode then "∷" else "::") -arrow unicode = toHtml (if unicode then "→" else "->") -darrow unicode = toHtml (if unicode then "⇒" else "=>") -forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" - - -dot :: Html -dot = toHtml "." - - -s8, s15 :: HtmlTable -s8 = tda [ theclass "s8" ] << noHtml -s15 = tda [ theclass "s15" ] << noHtml - - --- | Generate a named anchor --- --- This actually generates two anchor tags, one with the name unescaped, and one --- with the name URI-escaped. This is needed because Opera 9.52 (and later --- versions) needs the name to be unescaped, while IE 7 needs it to be escaped. --- -namedAnchor :: String -> Html -> Html -namedAnchor n = (anchor ! [Html.name n]) . (anchor ! [Html.name (escapeStr n)]) - - --- --- A section of HTML which is collapsible via a +/- button. --- - --- TODO: Currently the initial state is non-collapsed. Change the 'minusFile' --- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we --- use cookies from JavaScript to have a more persistent state. - -collapsebutton :: String -> Html -collapsebutton id_ = - image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] - -collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html -collapsed fn id_ html = - fn ! [identifier id_, thestyle "display:block;"] << html - --- A quote is a valid part of a Haskell identifier, but it would interfere with --- the ECMA script string delimiter used in collapsebutton above. -collapseId :: Name -> String -collapseId nm = "i:" ++ escapeStr (getOccString nm) - -linkedAnchor :: String -> Html -> Html -linkedAnchor frag = anchor ! [href hr_] - where hr_ | null frag = "" - | otherwise = '#': escapeStr frag - -documentCharacterEncoding :: Html -documentCharacterEncoding = - meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] - -styleSheet :: Html -styleSheet = - thelink ! [href cssFile, rel "stylesheet", thetype "text/css"] diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/LaTeX.hs @@ -0,0 +1,1170 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.LaTeX +-- Copyright : (c) Simon Marlow 2010 +-- 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) +import qualified Pretty + +import GHC +import OccName +import Name ( isTyConName, nameOccName ) +import RdrName ( rdrNameOcc, isRdrTc ) +import BasicTypes ( IPName(..), Boxity(..) ) +import Outputable ( Outputable, ppr, showSDoc ) +import FastString ( unpackFS, unpackLitString ) + +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 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 (render 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 + = case ifaceRnDoc iface of + Nothing -> empty + Just doc -> docToLaTeX doc + + 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 (LStr s1 _) s2 = unpackLitString s1 ++ s2 + + +exportListItem :: ExportItem DocName -> LaTeX +exportListItem (ExportDecl decl _doc subdocs _insts) + = ppDocBinder (declName 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 (getName name) typ False + | (name,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 (L _ (SigD (TypeSig (L _ n) (L _ t)))) + (Nothing, argDocs) _ _) + | Map.null argDocs = Just (n, 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) + = ppDecl decl doc insts subdocs +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" + + +declName :: LHsDecl DocName -> DocName +declName (L _ decl) = case decl of + TyClD d -> unLoc $ tcdLName d + SigD (TypeSig (L _ n) _) -> n + _ -> error "declaration not supported by declName" + + +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)] + -> LaTeX + +ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of + TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode + TyClD d@(TyData {}) + | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode + | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d + TyClD d@(TySynonym {}) + | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode + | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode + SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) n t unicode + ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode + InstD _ -> empty + _ -> error "declaration not supported by ppDecl" + where + unicode = False + + +ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) -> + TyClDecl DocName -> Bool -> LaTeX +ppTyFam _ _ _ _ _ = + error "type family declarations are currently not supported by --latex" + + +ppDataInst :: a +ppDataInst = + error "data instance declarations are currently not supported by --latex" + + +ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) -> + TyClDecl DocName -> Bool -> LaTeX +ppTyInst _ _ _ _ _ = + error "type instance declarations are currently not supported by --latex" + + +ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX +ppFor _ _ _ _ = + 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 (TySynonym (L _ name) ltyvars _ 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 docname typ unicode = + ppTypeOrFunSig loc docname typ doc + (ppTypeSig name typ False, ppSymName name, dcolon unicode) + unicode + where + name = getName docname + + +ppTypeOrFunSig :: SrcSpan -> DocName -> HsType DocName -> + DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) + -> Bool -> LaTeX +ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0) + unicode + | Map.null argDocs = + declWithDoc pref1 (fmap docToLaTeX doc) + | otherwise = + declWithDoc pref2 $ Just $ + text "\\haddockbeginargs" $$ + do_args 0 sep0 typ $$ + text "\\end{tabulary}\\par" $$ + maybe empty docToLaTeX 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 nm ty unicode = + ppSymName nm <+> dcolon unicode <+> ppType unicode ty + + +ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars tvs = map ppSymName (tyvarNames tvs) + + +tyvarNames :: [LHsTyVarBndr DocName] -> [Name] +tyvarNames = map (getName . hsTyVarName . unLoc) + + +declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX +declWithDoc decl doc = + text "\\begin{haddockdesc}" $$ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (render 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 (render 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 [LHsPred DocName] -> DocName + -> [Located (HsTyVarBndr 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 + -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> LaTeX +ppClassDecl instances loc mbDoc subdocs + (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) 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 [fmap docToLaTeX mbDoc, body_] + + body_ + | null lsigs, null ats = Nothing + | null ats = Just methodTable +--- | otherwise = atTable $$ methodTable + | otherwise = error "LaTeX.ppClassDecl" + + methodTable = + text "\\haddockpremethods{}\\textbf{Methods}" $$ + vcat [ ppFunSig loc doc n typ unicode + | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc n subdocs ] + +-- atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats +-- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] + + 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, mbDoc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc) + + +ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead + + +ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode +ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode + + +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 (Doc DocName) -> TyClDecl DocName -> Bool -> + LaTeX +ppDataDecl instances subdocs _loc mbDoc dataDecl unicode + + = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + + where + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + + body = catMaybes [constrBit, fmap docToLaTeX mbDoc] + + (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 +#if __GLASGOW_HASKELL__ == 612 +ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> LaTeX +#else +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +#endif +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 = docNameOcc . 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. + -- 'join' is in Maybe. + mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mkFunTy a b = noLoc (HsFunTy a b) + + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX +ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = + decltt (ppBinder (docNameOcc 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 = join $ fmap fst $ lookup name subdocs + +-- {- +-- 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 decl unicode + | not (isDataDecl decl) = error "ppDataHeader: illegal argument" + | otherwise = + -- newtype or data + (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> + -- context + ppLContext (tcdCtxt decl) unicode <+> + -- T a b c ..., or a :+: b + ppTyClBinderWithVars False decl + + +-------------------------------------------------------------------------------- +-- * TyClDecl helpers +-------------------------------------------------------------------------------- + + +-- | Print a type family / newtype / data / class binder and its variables +ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX +ppTyClBinderWithVars summ decl = + ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) + + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and a list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> LaTeX +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX +ppAppDocNameNames _summ n ns = + ppTypeApp n ns (ppBinder . docNameOcc) ppSymName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [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 ts ppDN ppT = ppDN n <+> hsep (map ppT 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 :: [HsPred 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 :: [HsPred DocName] -> Bool -> LaTeX +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppPred unicode p +pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) + + +ppPred :: Bool -> HsPred DocName -> LaTeX +ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode +ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <> text "~" <> ppLType unicode t2 +ppPred unicode (HsIParam (IPName n) t) + = char '?' <> ppDocName n <> dcolon unicode <> ppLType unicode t + + +------------------------------------------------------------------------------- +-- * Types and contexts +------------------------------------------------------------------------------- + + +ppKind :: Outputable a => a -> LaTeX +ppKind k = text (showSDoc (ppr k)) + + +ppBang :: HsBang -> LaTeX +ppBang HsNoBang = empty +ppBang _ = char '!' -- Unpacked args is an implementation detail, + + +tupleParens :: Boxity -> [LaTeX] -> LaTeX +tupleParens Boxed = parenList +tupleParens Unboxed = ubxParenList + + +------------------------------------------------------------------------------- +-- * 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 + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +#if __GLASGOW_HASKELL__ == 612 +ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] +#else +ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] +#endif + -> 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 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 <+> ppKind kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) +ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only +ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +#if __GLASGOW_HASKELL__ == 612 +ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +#else +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +#endif +ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" + +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 = docNameOcc . unLoc $ op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> 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 + | isVarSym n = parens $ ppOccName n + | otherwise = ppOccName n + + +ppSymName :: Name -> LaTeX +ppSymName name + | isNameSym name = parens $ ppName name + | otherwise = ppName name + + +ppVerbOccName :: OccName -> LaTeX +ppVerbOccName = text . latexFilter . occNameString + + +ppOccName :: OccName -> LaTeX +ppOccName = text . occNameString + + +ppVerbDocName :: DocName -> LaTeX +ppVerbDocName = ppVerbOccName . docNameOcc + + +ppVerbRdrName :: RdrName -> LaTeX +ppVerbRdrName = ppVerbOccName . rdrNameOcc + + +ppDocName :: DocName -> LaTeX +ppDocName = ppOccName . docNameOcc + + +ppLDocName :: Located DocName -> LaTeX +ppLDocName (L _ d) = ppDocName d + + +ppDocBinder :: DocName -> LaTeX +ppDocBinder = ppBinder . docNameOcc + + +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) -> (a -> Bool) + -> DocMarkup a (StringContext -> LaTeX) +parLatexMarkup ppId isTyCon = 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, + markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupEmphasis = \p v -> emph (p v), + markupMonospaced = \p _ -> tt (p Mono), + markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", + markupPic = \path _ -> parens (text "image: " <> text path), + 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 "", + markupURL = \u _ -> text "\\url" <> braces (text u), + markupAName = \_ _ -> empty, + markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e + } + where + fixString Plain s = latexFilter s + fixString Verb s = s + fixString Mono s = latexMonoFilter s + + markupId id v = + case v of + Verb -> theid + Mono -> theid + Plain -> text "\\haddockid" <> braces theid + where theid = ppId (choose id) + + -- If an id can refer to multiple things, we give precedence to type + -- constructors. This should ideally be done during renaming from RdrName + -- to Name, but since we will move this process from GHC into Haddock in + -- the future, we fix it here in the meantime. + -- TODO: mention this rule in the documentation. + choose [] = error "empty identifier list in HsDoc" + choose [x] = x + choose (x:y:_) + | isTyCon x = x + | otherwise = y + + +latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup = parLatexMarkup ppVerbDocName (isTyConName . getName) + + +rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup = parLatexMarkup ppVerbRdrName isRdrTc + + +docToLaTeX :: Doc DocName -> LaTeX +docToLaTeX doc = markup latexMarkup doc Plain + + +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 + + +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 new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml.hs @@ -0,0 +1,652 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html +-- 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 ( + 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 ) +import Control.Monad.Instances ( ) -- for Functor Either a +import Data.Char ( toUpper ) +import Data.List ( sortBy, groupBy ) +import Data.Maybe +import System.FilePath hiding ( () ) +import System.Directory +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Data.List ( intercalate ) +import Data.Function +import Data.Ord ( comparing ) + +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) + -> IO () + +ppHtml doctitle maybe_package ifaces odir prologue + themes maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + when (not (isJust maybe_contents_url)) $ + ppHtmlContents odir doctitle maybe_package + 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 + + when (not (isJust maybe_index_url)) $ + ppHtmlIndex odir doctitle maybe_package + themes maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) + + mapM_ (ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode) visible_ifaces + + +copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () +copyHtmlBits odir libdir themes = do + let + libhtmldir = joinPath [libdir, "html"] + copyCssFile f = do + copyFile f (combine odir (takeFileName f)) + copyLibFile f = do + 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 = maybe contentsHtmlFile id maybe_contents_url + + +indexButton :: Maybe String -> Maybe Html +indexButton maybe_index_url + = Just (anchor ! [href url] << "Index") + where url = maybe indexHtmlFile id 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 `fmap` iface), + contentsButton maybe_contents_url, + indexButton maybe_index_url]) + ! [theclass "links", identifier "page-menu"], + nonEmpty sectionName << 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 [ + ("Portability",hmi_portability), + ("Stability",hmi_stability), + ("Maintainer",hmi_maintainer) + ] + 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) + -> IO () +ppHtmlContents odir doctitle _maybe_package + themes maybe_index_url + maybe_source_url maybe_wiki_url ifaces showPkgs prologue = 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 doctitle prologue, + ppModuleTree tree + ] + createDirectoryIfMissing True odir + writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html) + + -- XXX: think of a better place for this? + ppHtmlContentsFrame odir doctitle themes ifaces + + +ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html +ppPrologue _ Nothing = noHtml +ppPrologue title (Just doc) = + docElement divDescription << (h1 << title +++ rdrDocToHtml doc) + + +ppModuleTree :: [ModuleTree] -> Html +ppModuleTree ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts) + + +mkNodeList :: [String] -> String -> [ModuleTree] -> Html +mkNodeList ss p ts = case ts of + [] -> noHtml + _ -> unordList (zipWith (mkNode ss) ps ts) + where + ps = [ p ++ '.' : show i | i <- [(1::Int)..]] + + +mkNode :: [String] -> String -> ModuleTree -> Html +mkNode 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 short + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + + subtree = mkNodeList (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] -> IO () +ppHtmlContentsFrame odir doctitle themes ifaces = 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 html) + + +-------------------------------------------------------------------------------- +-- * Generate the index +-------------------------------------------------------------------------------- + + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] + -> IO () +ppHtmlIndex odir doctitle _maybe_package themes + maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do + let html = indexPage split_indices Nothing + (if split_indices then [] else index) + + createDirectoryIfMissing True odir + + when split_indices $ + mapM_ (do_sub_index index) initialChars + + writeFile (joinPath [odir, indexHtmlFile]) (renderToString 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 + + 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 [ anchor ! [href (subIndexHtmlFile c)] << [c] + | c <- initialChars + , any ((==c) . toUpper . head . fst) index ] + + -- todo: what about names/operators that start with Unicode + -- characters? + -- Exports beginning with '_' can be listed near the end, + -- presumably they're not as important... but would be listed + -- with non-split index! + initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" + + do_sub_index this_ix c + = unless (null index_part) $ + writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString 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,_) = map toUpper n1 `compare` map toUpper n2 + + -- for each name (a plain string), we have a number of original HsNames that + -- it can refer to, and for each of those we have a list of modules + -- that export that entity. Each of the modules exports the entity + -- in a visible or invisible way (hence the Bool). + full_index :: Map String (Map GHC.Name [(Module,Bool)]) + full_index = Map.fromListWith (flip (Map.unionWith (++))) + (concat (map getIfaceIndex ifaces)) + + getIfaceIndex iface = + [ (getOccString name + , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])]) + | name <- instExports iface ] + where mdl = instMod iface + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + td ! [ theclass "src" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml + aboves (map doAnnotatedEntity (zip [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 + -> Interface -> IO () +ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode iface = do + let + mdl = ifaceMod iface + mdl_str = moduleString 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 + ] + + createDirectoryIfMissing True odir + writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html) + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode + + +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes + -> Interface -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do + let mdl = ifaceMod iface + html = + headHtml (moduleString mdl) Nothing themes +++ + miniBody << + (divModuleHeader << sectionName << moduleString mdl +++ + miniSynopsis mdl iface unicode) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html) + + +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode + = ppModuleContents 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 _ doc _ _) = isJust (fst doc) + has_doc (ExportNoDecl _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description + = case ifaceRnDoc iface of + Nothing -> noHtml + Just doc -> divDescription $ + sectionName << "Description" +++ docSection doc + + -- 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) 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) exports + + linksInfo = (maybe_source_url, maybe_wiki_url) + + +miniSynopsis :: Module -> Interface -> Bool -> Html +miniSynopsis mdl iface unicode = + divInterface << mapMaybe (processForMiniSynopsis mdl unicode) exports + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + +processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Maybe Html +processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) = + ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of + TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of + (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode + (TyData{tcdTyPats = ps}) + | Nothing <- ps -> Just $ keyword "data" <+> b + | Just _ <- ps -> Just $ keyword "data" <+> keyword "instance" <+> b + (TySynonym{tcdTyPats = ps}) + | Nothing <- ps -> Just $ keyword "type" <+> b + | Just _ <- ps -> Just $ keyword "type" <+> keyword "instance" <+> b + (ClassDecl {}) -> Just $ keyword "class" <+> b + _ -> Nothing + SigD (TypeSig (L _ n) (L _ _)) -> + Just $ ppNameMini mdl (docNameOcc n) + _ -> Nothing +processForMiniSynopsis _ _ (ExportGroup lvl _id txt) = + Just $ groupTag lvl << docToHtml txt +processForMiniSynopsis _ _ _ = Nothing + + +ppNameMini :: Module -> OccName -> Html +ppNameMini mdl nm = + anchor ! [ href (moduleNameUrl mdl nm) + , target mainFrameName ] + << ppBinder' nm + + +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini mdl decl = + let n = unLoc $ tcdLName decl + ns = tyvarNames $ tcdTyVars decl + in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName + + +ppModuleContents :: [ExportItem DocName] -> Html +ppModuleContents 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 id0 << docToHtml doc +++ mk_subsections ssecs + (ssecs, rest1) = process lev rest + (secs, rest2) = process n rest1 + process n (_ : rest) = process n rest + + mk_subsections [] = noHtml + mk_subsections ss = 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 exports = go 1 exports + where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + go _ [] = [] + go n (ExportGroup lev _ doc : es) + = ExportGroup lev (show n) doc : go (n+1) es + go n (other:es) + = other : go n es + + +processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> Maybe Html +processExport summary _ _ (ExportGroup lev id0 doc) + = nothingIf summary $ groupTag lev ! [identifier id0] << docToHtml doc +processExport summary links unicode (ExportDecl decl doc subdocs insts) + = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode +processExport summary _ _ (ExportNoDecl y []) + = processDeclOneLiner summary $ ppDocName y +processExport summary _ _ (ExportNoDecl y subs) + = processDeclOneLiner summary $ ppDocName y +++ parenList (map ppDocName subs) +processExport summary _ _ (ExportDoc doc) + = nothingIf summary $ docSection 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 + + +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 new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -0,0 +1,734 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Control.Monad ( join ) +import qualified Data.Map as Map +import Data.Maybe +import Text.XHtml hiding ( name, title, p, quote ) + +import BasicTypes ( IPName(..), Boxity(..) ) +import GHC +import Name +import Outputable ( ppr, showSDoc, Outputable ) + + +-- TODO: use DeclInfo DocName or something +ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html +ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of + TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode + TyClD d@(TyData {}) + | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode + | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d + TyClD d@(TySynonym {}) + | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode + | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode + SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode + InstD _ -> noHtml + _ -> error "declaration not supported by ppDecl" + + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + DocName -> HsType DocName -> Bool -> Html +ppFunSig summary links loc doc docname typ unicode = + ppTypeOrFunSig summary links loc docname typ doc + (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode + where + occname = docNameOcc docname + + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> + DocForDecl DocName -> (Html, Html, Html) -> Bool -> Html +ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode + | summary = pref1 + | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection doc + | otherwise = topDeclElem links loc docname pref2 +++ + subArguments (do_args 0 sep typ) +++ maybeDocSection 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, + Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = (leader <+> ppLContextNoArrow lctxt unicode, + 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 lt, argDoc n, []) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = (leader <+> ppType unicode t, argDoc n, []) : [] + + +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map ppTyName (tyvarNames tvs) + + +tyvarNames :: [LHsTyVarBndr DocName] -> [Name] +tyvarNames = map (getName . hsTyVarName . unLoc) + + +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> Html +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode + = ppFunSig summary links loc doc name typ unicode +ppFor _ _ _ _ _ _ = error "ppFor" + + +-- we skip type patterns for now +ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Html +ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode + = ppTypeOrFunSig summary links loc name (unLoc ltype) doc + (full, hdr, spaceHtml +++ equals) unicode + where + hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + full = hdr <+> equals <+> ppLType unicode ltype + occ = docNameOcc name +ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn" + + +ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html +ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty + + +ppTyName :: Name -> Html +ppTyName name + | isNameSym name = parens (ppName name) + | otherwise = ppName name + + +-------------------------------------------------------------------------------- +-- * Type families +-------------------------------------------------------------------------------- + + +ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html +ppTyFamHeader summary associated decl unicode = + + (case tcdFlavour decl of + TypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ) <+> + + ppTyClBinderWithVars summary decl <+> + + case tcdKind decl of + Just kind -> dcolon unicode <+> ppKind kind + Nothing -> noHtml + + +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> + TyClDecl DocName -> Bool -> Html +ppTyFam summary associated links loc mbDoc decl unicode + + | summary = ppTyFamHeader True associated decl unicode + | otherwise = header_ +++ maybeDocSection mbDoc +++ instancesBit + + where + docname = tcdName decl + + header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode) + + instancesBit = ppInstances instances docname unicode + + -- TODO: get the instances + instances = [] + + +-------------------------------------------------------------------------------- +-- * Indexed data types +-------------------------------------------------------------------------------- + + +ppDataInst :: a +ppDataInst = undefined + + +-------------------------------------------------------------------------------- +-- * Indexed newtypes +-------------------------------------------------------------------------------- + +-- TODO +-- ppNewTyInst = undefined + + +-------------------------------------------------------------------------------- +-- * Indexed types +-------------------------------------------------------------------------------- + + +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> + TyClDecl DocName -> Bool -> Html +ppTyInst summary associated links loc mbDoc decl unicode + + | summary = ppTyInstHeader True associated decl unicode + | otherwise = header_ +++ maybeDocSection mbDoc + + where + docname = tcdName decl + + header_ = topDeclElem links loc docname (ppTyInstHeader summary associated decl unicode) + + +ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html +ppTyInstHeader _ _ decl unicode = + keyword "type instance" <+> + ppAppNameTypes (tcdName decl) typeArgs unicode + where + typeArgs = map unLoc . fromJust . tcdTyPats $ decl + + +-------------------------------------------------------------------------------- +-- * Associated Types +-------------------------------------------------------------------------------- + + +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> Html +ppAssocType summ links doc (L loc decl) unicode = + case decl of + TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode + TySynonym {} -> ppTySyn summ links loc doc decl unicode + _ -> error "declaration type not supported by ppAssocType" + + +-------------------------------------------------------------------------------- +-- * TyClDecl helpers +-------------------------------------------------------------------------------- + + +-- | Print a type family / newtype / data / class binder and its variables +ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppTyClBinderWithVars summ decl = + ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) + + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and a list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html +ppAppDocNameNames summ n ns = + ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN n <+> ppT t2 + +ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Bool -> Html +ppContextNoArrow [] _ = noHtml +ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsPred DocName] -> Bool -> Html +ppContextNoLocs [] _ = noHtml +ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode + + +ppContext :: HsContext DocName -> Bool -> Html +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsPred DocName] -> Bool -> Html +pp_hs_context [] _ = noHtml +pp_hs_context [p] unicode = ppPred unicode p +pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) + + +ppPred :: Bool -> HsPred DocName -> Html +ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode +ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2 +ppPred unicode (HsIParam (IPName n) t) + = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName + -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] + -> Bool -> Html +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else noHtml) + <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppFds fds unicode + + +ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html +ppFds fds unicode = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> + hsep (map ppDocName vars2) + + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Html +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = + if null sigs && null ats + then (if summary then id else topDeclElem links loc nm) hdr + else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where") + +++ shortSubDecls + ( + [ ppAssocType summary links doc at unicode | at <- ats + , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + + [ ppFunSig summary links loc doc n typ unicode + | L _ (TypeSig (L _ n) (L _ typ)) <- sigs + , let doc = lookupAnySubdoc n subdocs ] + ) + where + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode + nm = unLoc lname +ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + + +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan + -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> Html +ppClassDecl summary links instances loc mbDoc subdocs + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode + | summary = ppShortClassDecl summary links decl loc subdocs unicode + | otherwise = classheader +++ maybeDocSection mbDoc + +++ atBit +++ methodBit +++ instancesBit + where + classheader + | null lsigs = topDeclElem links loc nm (hdr unicode) + | otherwise = topDeclElem links loc nm (hdr unicode <+> keyword "where") + + nm = unLoc $ tcdLName decl + + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + + atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode + | at <- ats + , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] + + methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode + | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc n subdocs ] + + instancesBit = ppInstances instances nm unicode + +ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + +ppInstances :: [DocInstance DocName] -> DocName -> Bool -> Html +ppInstances instances baseName unicode + = subInstances instName (map instDecl instances) + where + instName = getOccString $ getName baseName + instDecl :: DocInstance DocName -> SubDecl + instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) + instHead ([], n, ts) = ppAppNameTypes n ts unicode + instHead (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode + + +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 +------------------------------------------------------------------------------- + + +-- TODO: print contexts +ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html +ppShortDataDecl summary _links _loc dataDecl unicode + + | [] <- cons = dataHeader + + | [lcon] <- cons, ResTyH98 <- resTy, + (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode + = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot + + | ResTyH98 <- resTy = dataHeader + +++ shortSubDecls (zipWith doConstr ('=':repeat '|') cons) + + | otherwise = (dataHeader <+> keyword "where") + +++ shortSubDecls (map doGADTConstr cons) + + where + dataHeader = ppDataHeader summary dataDecl unicode + doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode + doGADTConstr con = ppShortConstr summary (unLoc con) unicode + + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + + +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> + [(DocName, DocForDecl DocName)] -> + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> Html +ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode + + | summary = ppShortDataDecl summary links loc dataDecl unicode + | otherwise = header_ +++ maybeDocSection mbDoc +++ constrBit +++ instancesBit + + where + docname = unLoc . tcdLName $ dataDecl + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + + header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode + <+> whereBit) + + whereBit + | null cons = noHtml + | otherwise = case resTy of + ResTyGADT _ -> keyword "where" + _ -> noHtml + + constrBit = subConstructors + (map (ppSideBySideConstr subdocs unicode) cons) + + instancesBit = ppInstances instances docname unicode + + + +ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html +ppShortConstr summary con unicode = cHead <+> cBody <+> cFoot + where + (cHead,cBody,cFoot) = ppShortConstrParts summary con unicode + + +-- returns three pieces: header, body, footer so that header & footer can be +-- incorporated into the declaration +ppShortConstrParts :: Bool -> ConDecl DocName -> Bool -> (Html, Html, Html) +ppShortConstrParts summary con unicode = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + (header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args), + noHtml, noHtml) + RecCon fields -> + (header_ unicode +++ ppBinder summary occ <+> char '{', + doRecordFields fields, + char '}') + InfixCon arg1 arg2 -> + (header_ unicode +++ hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode 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 <+> char '{', + doRecordFields fields, + char '}' <+> arrow unicode <+> ppLType unicode resTy) + InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + + where + doRecordFields fields = shortSubDecls (map (ppShortField summary unicode) fields) + doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs lcontext unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall tyVars context + occ = docNameOcc . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames ltvs + lcontext = con_cxt con + context = unLoc (con_cxt con) + forall = con_explicit con + mkFunTy a b = noLoc (HsFunTy a b) + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +#if __GLASGOW_HASKELL__ == 612 +ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html +#else +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html +#endif +ppConstrHdr forall tvs ctxt unicode + = (if null tvs then noHtml else ppForall) + +++ + (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ") + where + ppForall = case forall of + Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " + Implicit -> noHtml + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> SubDecl +ppSideBySideConstr subdocs unicode (L _ con) = (decl, mbDoc, fieldPart) + where + decl = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + hsep ((header_ unicode +++ ppBinder False occ) + : map (ppLParendType unicode) args) + + RecCon _ -> header_ unicode +++ ppBinder False occ + + InfixCon arg1 arg2 -> + hsep [header_ unicode+++ppLParendType unicode arg1, + ppBinder False occ, + ppLParendType unicode arg2] + + 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 + (map (ppSideBySideField subdocs unicode) fields) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html + doGADTCon args resTy = + ppBinder False occ <+> dcolon unicode + <+> hsep [ppForAll forall ltvs (con_cxt con) unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall tyVars context + occ = docNameOcc . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall = con_explicit con + -- 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. + -- 'join' is in Maybe. + mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mkFunTy a b = noLoc (HsFunTy a b) + + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> SubDecl +ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = + (ppBinder False (docNameOcc name) <+> dcolon unicode <+> ppLType unicode ltype, + mbDoc, + []) + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = join $ fmap fst $ lookup name subdocs + + +ppShortField :: Bool -> Bool -> ConDeclField DocName -> Html +ppShortField summary unicode (ConDeclField (L _ name) ltype _) + = ppBinder summary (docNameOcc name) + <+> dcolon unicode <+> ppLType unicode ltype + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html +ppDataHeader summary decl unicode + | not (isDataDecl decl) = error "ppDataHeader: illegal argument" + | otherwise = + -- newtype or data + (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> + -- context + ppLContext (tcdCtxt decl) unicode <+> + -- T a b c ..., or a :+: b + ppTyClBinderWithVars summary decl + + +-------------------------------------------------------------------------------- +-- * Types and contexts +-------------------------------------------------------------------------------- + + +ppKind :: Outputable a => a -> Html +ppKind k = toHtml $ showSDoc (ppr k) + + +ppBang :: HsBang -> Html +ppBang HsNoBang = noHtml +ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, + -- so we just show the strictness annotation + + +tupleParens :: Boxity -> [Html] -> Html +tupleParens Boxed = parenList +tupleParens Unboxed = ubxParenList + + +-------------------------------------------------------------------------------- +-- * Rendering of HsType +-------------------------------------------------------------------------------- + + +pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC +pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> Html -> Html -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html +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 -> Html +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 + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +#if __GLASGOW_HASKELL__ == 612 +ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] +#else +ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] +#endif + -> Located (HsContext DocName) -> Bool -> Html +ppForAll expl tvs cxt unicode + | show_forall = forall_part <+> ppLContext cxt unicode + | otherwise = ppLContext cxt unicode + where + show_forall = not (null tvs) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html +ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode + + +ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + +ppr_mono_ty _ (HsBangTy b ty) u = ppBang b +++ ppLParendType u ty +ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) +ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only +ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +#if __GLASGOW_HASKELL__ == 612 +ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +#else +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +#endif +ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode + where + ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op + occName = docNameOcc . unLoc $ op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode + p2 = ppr_mono_lty pREC_TOP ty2 unicode + in + maybeParen ctxt_prec pREC_FUN $ + hsep [p1, arrow unicode <+> p2] + + diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,124 @@ +----------------------------------------------------------------------------- +-- | +-- 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, + + docElement, docSection, maybeDocSection, +) where + + +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC +import Name +import RdrName + + +parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html +parHtmlMarkup ppId isTyCon = Markup { + markupEmpty = noHtml, + markupString = toHtml, + markupParagraph = paragraph, + markupAppend = (+++), + markupIdentifier = thecode . ppId . choose, + markupModule = \m -> let (mdl,ref) = break (=='#') m + in ppModuleRef (mkModuleNoPackage mdl) ref, + markupEmphasis = emphasize, + markupMonospaced = thecode, + markupUnorderedList = unordList, + markupOrderedList = ordList, + markupDefList = defList, + markupCodeBlock = pre, + markupURL = \url -> anchor ! [href url] << url, + markupAName = \aname -> namedAnchor aname << "", + markupPic = \path -> image ! [src path], + markupExample = examplesToHtml + } + where + -- If an id can refer to multiple things, we give precedence to type + -- constructors. This should ideally be done during renaming from RdrName + -- to Name, but since we will move this process from GHC into Haddock in + -- the future, we fix it here in the meantime. + -- TODO: mention this rule in the documentation. + choose [] = error "empty identifier list in HsDoc" + choose [x] = x + choose (x:y:_) + | isTyCon x = x + | otherwise = y + + 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 :: Doc DocName -> Html +docToHtml = markup fmt . cleanup + where fmt = parHtmlMarkup ppDocName (isTyConName . getName) + + +origDocToHtml :: Doc Name -> Html +origDocToHtml = markup fmt . cleanup + where fmt = parHtmlMarkup ppName isTyConName + + +rdrDocToHtml :: Doc RdrName -> Html +rdrDocToHtml = markup fmt . cleanup + where fmt = parHtmlMarkup ppRdrName isRdrTc + + +docElement :: (Html -> Html) -> Html -> Html +docElement el content_ = + if isNoHtml content_ + then el ! [theclass "doc empty"] << spaceHtml + else el ! [theclass "doc"] << content_ + + +docSection :: Doc DocName -> Html +docSection = (docElement thediv <<) . docToHtml + + +maybeDocSection :: Maybe (Doc DocName) -> Html +maybeDocSection = maybe noHtml docSection + + +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 new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -0,0 +1,206 @@ +----------------------------------------------------------------------------- +-- | +-- 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, + + shortDeclList, + shortSubDecls, + + divTopDecl, + + SubDecl, + subArguments, + subAssociatedTypes, + subConstructors, + subFields, + subInstances, + subMethods, + + 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"] + + +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 :: [Html] -> Html +shortSubDecls items = ulist ! [theclass "subs"] << map (li <<) items + + +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 :: [SubDecl] -> Maybe Html +subDlist [] = Nothing +subDlist decls = Just $ dlist << map subEntry decls +++ clearDiv + where + subEntry (decl, mdoc, subs) = + dterm ! [theclass "src"] << decl + +++ + docElement ddef << (fmap docToHtml mdoc +++ subs) + clearDiv = thediv ! [ theclass "clear" ] << noHtml + + +subTable :: [SubDecl] -> Maybe Html +subTable [] = Nothing +subTable decls = Just $ table << aboves (concatMap subRow decls) + where + subRow (decl, mdoc, subs) = + (td ! [theclass "src"] << decl + <-> + docElement td << fmap docToHtml mdoc) + : map (cell . (td <<)) subs + + +subBlock :: [Html] -> Maybe Html +subBlock [] = Nothing +subBlock hs = Just $ toHtml hs + + +subArguments :: [SubDecl] -> Html +subArguments = divSubDecls "arguments" "Arguments" . subTable + + +subAssociatedTypes :: [Html] -> Html +subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock + + +subConstructors :: [SubDecl] -> Html +subConstructors = divSubDecls "constructors" "Constructors" . subTable + + +subFields :: [SubDecl] -> Html +subFields = divSubDecls "fields" "Fields" . subDlist + + +subInstances :: String -> [SubDecl] -> Html +subInstances nm = maybe noHtml wrap . instTable + where + wrap = (subSection <<) . (subCaption +++) + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable + subSection = thediv ! [theclass $ "subs instances"] + subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + id_ = makeAnchorId $ "i:" ++ nm + +subMethods :: [Html] -> Html +subMethods = divSubDecls "methods" "Methods" . subBlock + + +-- 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 -> DocName -> Html -> Html +topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html = + declElem << (html +++ srcLink +++ wikiLink) + where srcLink = + case Map.lookup origPkg sourceMap 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 = name + + fname = unpackFS (srcSpanFile loc) + diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- | +-- 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, + ppBinder, ppBinder', + ppModule, ppModuleRef, + linkId +) where + + +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC +import Name +import RdrName + + +ppOccName :: OccName -> Html +ppOccName = toHtml . occNameString + + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + + +ppLDocName :: Located DocName -> Html +ppLDocName (L _ d) = ppDocName d + + +ppDocName :: DocName -> Html +ppDocName (Documented name mdl) = + linkIdOcc mdl (Just occName) << ppOccName occName + where occName = nameOccName name +ppDocName (Undocumented name) = toHtml (getOccString name) + + +ppName :: Name -> Html +ppName name = toHtml (getOccString name) + + +ppBinder :: Bool -> OccName -> Html +-- The Bool indicates whether we are generating the summary, in which case +-- the binder will be a link to the full definition. +ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' n +ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' n + + +ppBinder' :: OccName -> Html +ppBinder' n + | isVarSym n = parens $ ppOccName n + | otherwise = ppOccName n + + +linkId :: Module -> Maybe Name -> Html -> Html +linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) + + +linkIdOcc :: Module -> Maybe OccName -> Html -> Html +linkIdOcc mdl mbName = anchor ! [href url] + where + url = case mbName of + Nothing -> moduleUrl mdl + Just name -> moduleNameUrl mdl name + + +ppModule :: Module -> Html +ppModule mdl = anchor ! [href (moduleUrl mdl)] + << toHtml (moduleString mdl) + + +ppModuleRef :: Module -> String -> Html +ppModuleRef mdl ref = anchor ! [href (moduleUrl mdl ++ ref)] + << toHtml (moduleString 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 new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Themes.hs @@ -0,0 +1,207 @@ +----------------------------------------------------------------------------- +-- | +-- 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.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 = pts >>= return . either (const False) test + where test = isJust . findTheme s + + +-- | Find a built in theme +builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme +builtInTheme pts s = pts >>= return . either Left fetch + 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 = + getDirectoryContents path >>= return . map (combine path) . filter notDot + 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 new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Types.hs @@ -0,0 +1,29 @@ +----------------------------------------------------------------------------- +-- | +-- 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 +) 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) +type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) + + +-- The URL for source and wiki links +type LinksInfo = (SourceURLs, WikiURLs) diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- | +-- 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, + + (<+>), char, nonEmpty, + keyword, punctuate, + + braces, brackets, pabrackets, parens, parenList, ubxParenList, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + + hsep, + + 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 url = run url + where + file = fromMaybe "" maybe_file + mdl = case maybe_mod of + Nothing -> "" + Just m -> moduleString m + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + line = case maybe_loc of + Nothing -> "" + Just span_ -> show $ srcSpanStartLine span_ + + run "" = "" + run ('%':'M':rest) = mdl ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + run ('%':'L':rest) = line ++ run rest + run ('%':'%':rest) = "%" ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest + run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest + run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest + run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = + map (\x -> if x == '.' then c else x) mdl ++ run rest + + run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = + map (\x -> if x == '/' then c else x) file ++ run rest + + run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest + + run (c:rest) = c : run rest + + +renderToString :: Html -> String +renderToString = showHtml -- for production +--renderToString = prettyHtml -- for debugging + + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + + +infixr 8 <+> +(<+>) :: Html -> Html -> Html +a <+> b = a +++ toHtml " " +++ b + + +keyword :: String -> Html +keyword s = thespan ! [theclass "keyword"] << toHtml s + + +equals, comma :: Html +equals = char '=' +comma = char ',' + + +char :: Char -> Html +char c = toHtml [c] + + +-- | 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" +nonEmpty :: (Html -> Html) -> Html -> Html +nonEmpty el content_ = + if isNoHtml content_ + then el ! [theclass "empty"] << spaceHtml + else el << content_ + + +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)] + + +-- +-- 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 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -12,26 +12,31 @@ -- 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. -module Haddock.Convert where + import HsSyn import TcType ( tcSplitSigmaTy ) import TypeRep +#if __GLASGOW_HASKELL__ == 612 import Type ( splitKindFunTys ) +import BasicTypes +#else +import Coercion ( splitKindFunTys ) +#endif import Name import Var import Class import TyCon import DataCon -import BasicTypes import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName ) import Bag ( emptyBag ) import SrcLoc ( Located, noLoc, unLoc ) + -- the main function here! yay! tyThingToLHsDecl :: TyThing -> LHsDecl Name tyThingToLHsDecl t = noLoc $ case t of @@ -65,11 +70,13 @@ (map synifyClassAT (classATs cl)) [] --we don't have any docs at this point + -- class associated-types are a subset of TyCon -- (mainly only type/data-families) synifyClassAT :: TyCon -> LTyClDecl Name synifyClassAT = noLoc . synifyTyCon + synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc | isFunTyCon tc || isPrimTyCon tc = @@ -145,6 +152,7 @@ then TySynonym name tyvars typats syn_type else TyData alg_nd alg_ctx name tyvars typats alg_kindSig alg_cons alg_deriv + -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. @@ -164,14 +172,21 @@ else synifyTyVars (dataConExTyVars dc) -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx (dataConDictTheta dc) - linear_tys = zipWith (\ty strict -> + linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty - in case strict of - MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn - MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn - NotMarkedStrict -> + in case bang of +#if __GLASGOW_HASKELL__ >= 613 + HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn + HsNoBang -> tySyn -- HsNoBang never appears, it's implied instead. - tySyn + _ -> noLoc $ HsBangTy bang tySyn +#else + MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn + MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn + NotMarkedStrict -> tySyn + -- HsNoBang never appears, it's implied instead. +#endif + ) (dataConOrigArgTys dc) (dataConStrictMarks dc) field_tys = zipWith (\field synTy -> ConDeclField @@ -192,9 +207,11 @@ qvars ctx tys 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)) @@ -202,6 +219,7 @@ synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map synifyPred + synifyPred :: PredType -> LHsPred Name synifyPred (ClassP cls tys) = let sTys = map (synifyType WithinType) tys @@ -219,6 +237,7 @@ in noLoc $ HsEqualP s1 s2 + synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name] synifyTyVars = map synifyTyVar where @@ -226,9 +245,14 @@ kind = tyVarKind tv name = getName tv in if isLiftedTypeKind kind +#if __GLASGOW_HASKELL__ == 612 then UserTyVar name +#else + then UserTyVar name placeHolderKind +#endif else KindedTyVar name kind + --states of what to do with foralls: data SynifyTypeState = WithinType @@ -244,6 +268,7 @@ -- 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 _ (PredTy{}) = --should never happen. error "synifyType: PredTys are not, in themselves, source-level types." @@ -282,6 +307,7 @@ sTau = synifyType WithinType tau in noLoc $ HsForAllTy forallPlicitness sTvs sCtx sTau + synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> ([HsPred Name], Name, [HsType Name]) diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs --- a/src/Haddock/Doc.hs +++ b/src/Haddock/Doc.hs @@ -27,6 +27,7 @@ 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 diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -13,7 +13,6 @@ -- -- Utils for dealing with types from the GHC API ----------------------------------------------------------------------------- - module Haddock.GhcUtils where @@ -25,23 +24,23 @@ import Distribution.Compat.ReadP import Distribution.Text +import Exception import Outputable import Name import Packages import Module import RdrName (GlobalRdrEnv) import HscTypes +#if __GLASGOW_HASKELL__ >= 613 +import UniqFM +#else import LazyUniqFM +#endif import GHC moduleString :: Module -> String -moduleString = moduleNameString . moduleName - - --- return the name of the package, with version info -modulePackageString :: Module -> String -modulePackageString = packageIdString . modulePackageId +moduleString = moduleNameString . moduleName -- return the (name,version) of the package @@ -90,10 +89,18 @@ getMainDeclBinder :: HsDecl name -> Maybe name getMainDeclBinder (TyClD d) = Just (tcdName d) -getMainDeclBinder (ValD d) - = case collectAcc d [] of - [] -> Nothing - (name:_) -> Just (unLoc name) +getMainDeclBinder (ValD d) = +#if __GLASGOW_HASKELL__ == 612 + case collectAcc d [] of + [] -> Nothing + (name:_) -> Just (unLoc name) +#else + case collectHsBindBinders d of + [] -> Nothing + (name:_) -> Just name +#endif + + getMainDeclBinder (SigD d) = sigNameNoLoc d getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing @@ -135,7 +142,7 @@ ------------------------------------------------------------------------------- --- Located +-- * Located ------------------------------------------------------------------------------- @@ -152,11 +159,11 @@ instance Traversable Located where - mapM f (L l x) = (return . L l) =<< f x + mapM f (L l x) = (return . L l) =<< f x ------------------------------------------------------------------------------- --- NamedThing instances +-- * NamedThing instances ------------------------------------------------------------------------------- @@ -169,7 +176,7 @@ ------------------------------------------------------------------------------- --- Subordinates +-- * Subordinates ------------------------------------------------------------------------------- @@ -216,3 +223,36 @@ 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) + + +------------------------------------------------------------------------------- +-- * 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 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -2,73 +2,84 @@ -- | -- Module : Haddock.Interface -- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009 +-- David Waern 2006-2010 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org -- Stability : experimental -- Portability : portable -- --- Here we build the actual module interfaces. By interface we mean the --- information that is used to render a Haddock page for a module. Parts of --- this information are also stored in the .haddock files. +-- 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 ( - createInterfaces + 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.Options -import Haddock.GhcUtils import Haddock.Utils -import Haddock.InterfaceFile -import qualified Data.Map as Map -import Data.List -import Data.Maybe import Control.Monad -import Control.Exception ( evaluate ) +import Data.List +import qualified Data.Map as Map import Distribution.Verbosity +import System.Directory +import System.FilePath -import GHC hiding (verbosity, flags) import Digraph +import Exception +import GHC hiding (verbosity, flags) import HscTypes --- | Create 'Interface' structures by typechecking the list of modules --- using the GHC API and processing the resulting syntax trees. -createInterfaces - :: 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 -createInterfaces verbosity modules flags extIfaces = do - -- part 1, create interfaces +-- | 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 ] - out verbosity verbose "Creating interfaces..." - interfaces <- createInterfaces' verbosity modules flags instIfaceMap + interfaces <- createIfaces0 verbosity modules flags instIfaceMap - -- part 2, build link environment - out verbosity verbose "Building link environment..." - -- combine the link envs of the external packages into one + out verbosity verbose "Attaching instances..." + interfaces' <- attachInstances 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 + homeLinks = buildHomeLinks interfaces -- Build the environment for the home -- package links = homeLinks `Map.union` extLinks - -- part 3, attach instances - out verbosity verbose "Attaching instances..." - interfaces' <- attachInstances interfaces instIfaceMap - - -- part 4, rename interfaces out verbosity verbose "Renaming interfaces..." let warnings = Flag_NoWarnings `notElem` flags let (interfaces'', msgs) = @@ -78,53 +89,77 @@ return (interfaces'', homeLinks) -createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] -createInterfaces' verbosity modules flags instIfaceMap = do - targets <- mapM (\f -> guessTarget f Nothing) modules - setTargets targets - modgraph <- depanal [] False +-------------------------------------------------------------------------------- +-- * Module typechecking and Interface creation +-------------------------------------------------------------------------------- - -- If template haskell is used by the package, we can not use - -- HscNothing as target since we might need to run code generated from - -- one or more of the modules during typechecking. - modgraph' <- if needsTemplateHaskell modgraph - then do - dflags <- getSessionDynFlags - _ <- setSessionDynFlags dflags { hscTarget = defaultObjectTarget } - -- we need to set defaultObjectTarget on all the ModSummaries as well - let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } } - return (map addHscAsm modgraph) - else return modgraph - let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing - (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do - x <- processModule verbosity modsum flags modMap instIfaceMap - case x of - Just interface -> - return $ (interface : ifaces , Map.insert (ifaceMod interface) interface modMap) - Nothing -> return (ifaces, modMap) - ) ([], Map.empty) orderedMods +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 = d { hscTarget = defaultObjectTarget } + 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 + (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] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface) +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) ++ "..." - tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum + tm <- loadModule =<< typecheckModule =<< parseModule modsum if not $ isBootSummary modsum then do - let filename = msHsFilePath modsum - let dynflags = ms_hspp_opts modsum - let Just renamed_src = renamedSource tc_mod - let ghcMod = mkGhcModule (ms_mod modsum, - filename, - (parsedSource tc_mod, - renamed_src, - typecheckedSource tc_mod, - moduleInfo tc_mod)) - dynflags out verbosity verbose "Creating interface..." - (interface, msg) <- runWriterGhc $ createInterface ghcMod flags modMap instIfaceMap + (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap liftIO $ mapM_ putStrLn msg interface' <- liftIO $ evaluate interface return (Just interface') @@ -132,33 +167,9 @@ return Nothing -type CheckedMod = (Module, FilePath, FullyCheckedMod) - - -type FullyCheckedMod = (ParsedSource, - RenamedSource, - TypecheckedSource, - ModuleInfo) - - --- | Dig out what we want from the typechecker output -mkGhcModule :: CheckedMod -> DynFlags -> GhcModule -mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule { - ghcModule = mdl, - ghcFilename = file, - ghcMbDocOpts = mbOpts, - ghcMbDocHdr = mbDocHdr, - ghcGroup = group_, - ghcMbExports = mbExports, - ghcExportedNames = modInfoExports modInfo, - ghcDefinedNames = map getName $ modInfoTyThings modInfo, - ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, - ghcInstances = modInfoInstances modInfo -} - where - mbOpts = haddockOptions dynflags - (group_, _, mbExports, mbDocHdr) = renamed - (_, renamed, _, modInfo) = checkedMod +-------------------------------------------------------------------------------- +-- * Building of cross-linking environment +-------------------------------------------------------------------------------- -- | Build a mapping which for each original name, points to the "best" @@ -182,3 +193,14 @@ 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 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -11,7 +11,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Interface.AttachInstances (attachInstances) where @@ -39,33 +38,54 @@ attachInstances :: [Interface] -> InstIfaceMap -> Ghc [Interface] attachInstances 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 attachExport $ ifaceExportItems iface + newItems <- mapM (attachToExportItem iface ifaceMap instIfaceMap) + (ifaceExportItems iface) return $ iface { ifaceExportItems = newItems } - where - attachExport export@ExportDecl{expItemDecl = L _ (TyClD d)} = do - mb_info <- getAllInfo (unLoc (tcdLName d)) - return $ export { expItemInstances = case mb_info of - Just (_, _, instances) -> - let insts = map (first synifyInstHead) $ sortImage (first instHead) - [ (instanceHead i, getName i) | i <- instances ] - in [ (inst, lookupInstDoc name iface instIfaceMap) - | (inst, name) <- insts ] - Nothing -> [] + + +attachToExportItem :: Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name) +attachToExportItem iface ifaceMap instIfaceMap export = + case export of + ExportDecl { expItemDecl = L _ (TyClD d) } -> do + mb_info <- getAllInfo (unLoc (tcdLName d)) + let export' = + export { + expItemInstances = + case mb_info of + Just (_, _, instances) -> + let insts = map (first synifyInstHead) $ sortImage (first instHead) + [ (instanceHead i, getName i) | i <- instances ] + in [ (inst, lookupInstDoc name iface ifaceMap instIfaceMap) + | (inst, name) <- insts ] + Nothing -> [] } - attachExport export = return export + return export' + _ -> return export -lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (Doc Name) +lookupInstDoc :: Name -> Interface -> IfaceMap -> InstIfaceMap -> Maybe (Doc Name) -- TODO: capture this pattern in a function (when we have streamlined the -- handling of instances) -lookupInstDoc name iface ifaceMap = +lookupInstDoc name iface ifaceMap instIfaceMap = case Map.lookup name (ifaceInstanceDocMap iface) of Just doc -> Just doc - Nothing -> do -- in Maybe - instIface <- Map.lookup modName ifaceMap - (Just doc, _) <- Map.lookup name (instDocMap instIface) - return doc + Nothing -> + case Map.lookup modName ifaceMap of + Just iface2 -> + case Map.lookup name (ifaceInstanceDocMap iface2) of + Just doc -> Just doc + Nothing -> Nothing + Nothing -> + case Map.lookup modName instIfaceMap of + Just instIface -> + case Map.lookup name (instDocMap instIface) of + Just (doc, _) -> doc + Nothing -> Nothing + Nothing -> Nothing where modName = nameModule name diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -9,7 +9,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Interface.Create (createInterface) where @@ -30,48 +29,53 @@ import qualified Data.Traversable as Traversable import GHC hiding (flags) +import HscTypes import Name import Bag import RdrName (GlobalRdrEnv) --- | Process the data in the GhcModule to produce an interface. +-- | Process the data in a GhcModule to produce an interface. -- To do this, we need access to already processed modules in the topological --- sort. That's what's in the module map. -createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap +-- sort. That's what's in the interface map. +createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface -createInterface ghcMod flags modMap instIfaceMap = do +createInterface tm flags modMap instIfaceMap = do - let mdl = ghcModule ghcMod + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + mdl = ms_mod ms + dflags = ms_hspp_opts ms + instances = modInfoInstances mi + exportedNames = modInfoExports mi + -- XXX: confirm always a Just. + Just (group_, _, optExports, optDocHeader) = renamedSource tm -- The pattern-match should not fail, because createInterface is only -- done on loaded modules. Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl) - opts0 <- liftErrMsg $ mkDocOpts (ghcMbDocOpts ghcMod) flags mdl + opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl let opts | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader - gre (ghcMbDocHdr ghcMod) - decls0 <- liftErrMsg $ declInfos gre (topDecls (ghcGroup ghcMod)) + (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre optDocHeader + decls0 <- liftErrMsg $ declInfos dflags gre (topDecls group_) - let instances = ghcInstances ghcMod - localInsts = filter (nameIsLocalOrFrom mdl . getName) instances + let localInsts = filter (nameIsLocalOrFrom mdl . getName) instances declDocs = [ (decl, doc) | (L _ decl, (Just doc, _), _) <- decls0 ] instanceDocMap = mkInstanceDocMap localInsts declDocs decls = filterOutInstances decls0 declMap = mkDeclMap decls - exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) + exports = fmap (reverse . map unLoc) optExports ignoreExps = Flag_IgnoreAllExports `elem` flags - exportedNames = ghcExportedNames ghcMod liftErrMsg $ warnAboutFilteredDecls mdl decls0 - exportItems <- mkExportItems modMap mdl gre (ghcExportedNames ghcMod) decls declMap - opts exports ignoreExps instances instIfaceMap + exportItems <- mkExportItems modMap mdl gre exportedNames decls declMap + opts exports ignoreExps instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -84,7 +88,7 @@ return Interface { ifaceMod = mdl, - ifaceOrigFilename = ghcFilename ghcMod, + ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, ifaceDoc = mbDoc, ifaceRnDoc = Nothing, @@ -168,22 +172,22 @@ , not (isDocD d), not (isInstD d) ] -declInfos :: GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo] -declInfos gre decls = +declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo] +declInfos dflags gre decls = forM decls $ \(parent@(L _ d), mbDocString) -> do - mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment + mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbDocString fnArgsDoc <- fmap (Map.mapMaybe id) $ Traversable.forM (getDeclFnArgDocs d) $ - \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc + \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc let subs_ = subordinates d subs <- forM subs_ $ \(subName, mbSubDocStr, subFnArgsDocStr) -> do - mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment + mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr subFnArgsDoc <- fmap (Map.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ - \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc + \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc return (subName, (mbSubDoc, subFnArgsDoc)) return (parent, (mbDoc, fnArgsDoc), subs) @@ -420,7 +424,7 @@ -- We create the export items even if the module is hidden, since they -- might be useful when creating the export items for other modules. mkExportItems - :: ModuleMap + :: IfaceMap -> Module -- this module -> GlobalRdrEnv -> [Name] -- exported names (orig) @@ -431,10 +435,11 @@ -> Bool -- --ignore-all-exports flag -> [Instance] -> InstIfaceMap + -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems modMap this_mod gre exported_names decls declMap - opts maybe_exps ignore_all_exports _ instIfaceMap + opts maybe_exps ignore_all_exports _ instIfaceMap dflags | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps) @@ -442,7 +447,7 @@ everything_local_exported = -- everything exported - liftErrMsg $ fullContentsOfThisModule gre decls + liftErrMsg $ fullContentsOfThisModule dflags gre decls lookupExport (IEVar x) = declWith x @@ -451,15 +456,15 @@ lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = fullContentsOf m lookupExport (IEGroup lev docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr) + ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) lookupExport (IEDoc docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr) + ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]) lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ]) (\docStr -> - ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr) + ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ])) @@ -558,8 +563,12 @@ -- But I might be missing something obvious. What's important -- /here/ is that we behave reasonably when we run into one of -- those exported type-inferenced values. - isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ - isLoaded (moduleName (nameModule t)) + isLocalAndTypeInferenced <- liftGhcToErrMsgGhc $ do + let mdl = nameModule t + if modulePackageId mdl == thisPackage dflags + then isLoaded (moduleName mdl) + else return False + if isLocalAndTypeInferenced then do -- I don't think there can be any subs in this case, @@ -618,7 +627,7 @@ fullContentsOf modname - | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls + | m == this_mod = liftErrMsg $ fullContentsOfThisModule dflags gre decls | otherwise = case Map.lookup m modMap of Just iface @@ -666,14 +675,14 @@ -- (For more information, see Trac #69) -fullContentsOfThisModule :: GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name] -fullContentsOfThisModule gre decls = liftM catMaybes $ mapM mkExportItem decls +fullContentsOfThisModule :: DynFlags -> GlobalRdrEnv -> [DeclInfo] -> ErrMsgM [ExportItem Name] +fullContentsOfThisModule dflags gre decls = liftM catMaybes $ mapM mkExportItem decls where mkExportItem (L _ (DocD (DocGroup lev docStr)), _, _) = do - mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr + mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr return $ fmap (ExportGroup lev "") mbDoc mkExportItem (L _ (DocD (DocCommentNamed _ docStr)), _, _) = do - mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr + mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr return $ fmap ExportDoc mbDoc mkExportItem (decl, doc, subs) = return $ Just $ ExportDecl decl doc subs [] diff --git a/src/Haddock/Interface/ExtractFnArgDocs.hs b/src/Haddock/Interface/ExtractFnArgDocs.hs --- a/src/Haddock/Interface/ExtractFnArgDocs.hs +++ b/src/Haddock/Interface/ExtractFnArgDocs.hs @@ -8,7 +8,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Interface.ExtractFnArgDocs ( getDeclFnArgDocs, getSigFnArgDocs, getTypeFnArgDocs ) where diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,4 +1,3 @@ - ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn @@ -9,7 +8,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Interface.LexParseRn ( HaddockCommentType(..), lexParseRnHaddockComment, @@ -31,20 +29,20 @@ data HaddockCommentType = NormalHaddockComment | DocSectionComment -lexParseRnHaddockCommentList :: HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockCommentList hty gre docStrs = do - docMbs <- mapM (lexParseRnHaddockComment hty gre) docStrs +lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) +lexParseRnHaddockCommentList dflags hty gre docStrs = do + docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs let docs = catMaybes docMbs let doc = foldl docAppend DocEmpty docs case doc of DocEmpty -> return Nothing _ -> return (Just doc) -lexParseRnHaddockComment :: HaddockCommentType -> +lexParseRnHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockComment hty gre (HsDocString fs) = do +lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do let str = unpackFS fs - let toks = tokenise str + let toks = tokenise dflags str (0,0) -- TODO: real position let parse = case hty of NormalHaddockComment -> parseParas DocSectionComment -> parseString @@ -54,19 +52,19 @@ return Nothing Just doc -> return (Just (rnDoc gre doc)) -lexParseRnMbHaddockComment :: HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnMbHaddockComment _ _ Nothing = return Nothing -lexParseRnMbHaddockComment hty gre (Just d) = lexParseRnHaddockComment hty gre d +lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) +lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing +lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d -- yes, you always get a HaddockModInfo though it might be empty -lexParseRnHaddockModHeader :: GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) -lexParseRnHaddockModHeader gre mbStr = do +lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +lexParseRnHaddockModHeader dflags gre mbStr = do let failure = (emptyHaddockModInfo, Nothing) case mbStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs - case parseModuleHeader str of + case parseModuleHeader dflags str of Left mess -> do tell ["haddock module header parse failed: " ++ mess] return failure diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,4 +1,3 @@ - ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader @@ -9,7 +8,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where import Haddock.Types @@ -17,6 +15,7 @@ import Haddock.Parse import RdrName +import DynFlags import Data.Char @@ -26,8 +25,8 @@ -- 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 :: String -> Either String (HaddockModInfo RdrName, Doc RdrName) -parseModuleHeader str0 = +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 @@ -46,13 +45,15 @@ description1 :: Either String (Maybe (Doc RdrName)) description1 = case descriptionOpt of Nothing -> Right Nothing - Just description -> case parseString . tokenise $ description of + -- TODO: pass real file position + Just description -> case parseString $ tokenise dflags description (0,0) of Nothing -> Left ("Cannot parse Description: " ++ description) Just doc -> Right (Just doc) in case description1 of Left mess -> Left mess - Right docOpt -> case parseParas . tokenise $ str8 of + -- TODO: pass real file position + Right docOpt -> case parseParas $ tokenise dflags str8 (0,0) of Nothing -> Left "Cannot parse header documentation paragraphs" Just doc -> Right (HaddockModInfo { hmi_description = docOpt, diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -9,7 +9,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Interface.Rename (renameInterface) where @@ -202,6 +201,7 @@ DocURL str -> return (DocURL str) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) + DocExamples e -> return (DocExamples e) renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs --- a/src/Haddock/Interface/Rn.hs +++ b/src/Haddock/Interface/Rn.hs @@ -1,4 +1,3 @@ - module Haddock.Interface.Rn ( rnDoc, rnHaddockModInfo ) where import Haddock.Types @@ -43,7 +42,7 @@ let gres = concatMap (\rdrName -> map gre_name (lookupGRE_RdrName rdrName gre)) choices case gres of - [] -> return (DocString (ids2string ids)) + [] -> return (DocMonospaced (DocString (ids2string ids))) ids' -> return (DocIdentifier ids') DocModule str -> return (DocModule str) @@ -80,3 +79,5 @@ DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) + + DocExamples e -> return (DocExamples e) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -11,9 +11,8 @@ -- -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- - module Haddock.InterfaceFile ( - InterfaceFile(..), + InterfaceFile(..), ifPackageId, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile ) where @@ -40,12 +39,20 @@ import FastString 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 @@ -58,6 +65,10 @@ binaryInterfaceVersion = 15 #elif __GLASGOW_HASKELL__ == 613 binaryInterfaceVersion = 15 +#elif __GLASGOW_HASKELL__ == 614 +binaryInterfaceVersion = 16 +#elif __GLASGOW_HASKELL__ == 615 +binaryInterfaceVersion = 16 #else #error Unknown GHC version #endif @@ -103,7 +114,7 @@ -- 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 + seekBin bh symtab_p -- write the symbol table itself symtab_next' <- readFastMutInt symtab_next @@ -124,6 +135,7 @@ writeBinMem bh filename return () + type NameCacheAccessor m = (m NameCache, NameCache -> m ()) @@ -145,6 +157,7 @@ u <- mkSplitUniqSupply 'a' -- ?? return (initNameCache u []) + -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. -- @@ -205,8 +218,9 @@ seekBin bh1 data_p' return (nc', symtab) + ------------------------------------------------------------------------------- --- Symbol table +-- * Symbol table ------------------------------------------------------------------------------- @@ -261,42 +275,46 @@ let names = elems (array (0,next_off-1) (eltsUFM symtab)) mapM_ (\n -> serialiseName bh n symtab) names + getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) getSymbolTable bh namecache = do sz <- get bh od_names <- sequence (replicate sz (get bh)) - let + let arr = listArray (0,sz-1) names - (namecache', 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 + let modu = mkModule pid mod_name cache = nsNames nc in case lookupOrigNameCache cache modu occ of Just name -> (nc, name) - Nothing -> - let + 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',_) -> + 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 @@ -304,11 +322,10 @@ ------------------------------------------------------------------------------- --- GhcBinary instances +-- * GhcBinary instances ------------------------------------------------------------------------------- --- Hmm, why didn't we dare to make this instance already? It makes things --- much easier. + 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) @@ -343,7 +360,7 @@ visExps <- get bh opts <- get bh subMap <- get bh - + return (InstalledInterface modu info docMap exps visExps opts subMap) @@ -371,6 +388,16 @@ _ -> 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) + + {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary id) => Binary (Doc id) where put_ bh DocEmpty = do @@ -418,6 +445,9 @@ put_ bh (DocAName an) = do putByte bh 14 put_ bh an + put_ bh (DocExamples ao) = do + putByte bh 15 + put_ bh ao get bh = do h <- getByte bh case h of @@ -466,6 +496,9 @@ 14 -> do an <- get bh return (DocAName an) + 15 -> do + ao <- get bh + return (DocExamples ao) _ -> fail "invalid binary data found" @@ -475,7 +508,7 @@ put_ bh (hmi_portability hmi) put_ bh (hmi_stability hmi) put_ bh (hmi_maintainer hmi) - + get bh = do descr <- get bh porta <- get bh diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -17,6 +17,7 @@ module Haddock.Lex ( Token(..), + LToken, tokenise ) where @@ -32,12 +33,14 @@ import System.IO.Unsafe } +%wrapper "posn" + $ws = $white # \n $digit = [0-9] $hexdigit = [0-9a-fA-F] $special = [\"\@] $alphanum = [A-Za-z0-9] -$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~] +$ident = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~\:] :- @@ -45,15 +48,18 @@ <0,para> { $ws* \n ; $ws* \> { begin birdtrack } + $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* [\*\-] { token TokBullet `andBegin` string } $ws* \[ { token TokDefStart `andBegin` def } $ws* \( $digit+ \) { token TokNumber `andBegin` string } + $ws* $digit+ \. { token TokNumber `andBegin` string } $ws* { begin string } } -- beginning of a line { $ws* \> { begin birdtrack } + $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } $ws* \n { token TokPara `andBegin` para } -- Here, we really want to be able to say -- $ws* (\n | ) { token TokPara `andBegin` para} @@ -66,11 +72,21 @@ .* \n? { strtokenNL TokBirdTrack `andBegin` line } + { + $ws* \n { token TokPara `andBegin` para } + $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr } + () { begin exampleresult } +} + + .* \n { strtokenNL TokExampleExpression `andBegin` example } + + .* \n { strtokenNL TokExampleResult `andBegin` example } + { $special { strtoken $ \s -> TokSpecial (head s) } - \<\<.*\>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } - \<.*\> { strtoken $ \s -> TokURL (init (tail s)) } - \#.*\# { strtoken $ \s -> TokAName (init (tail s)) } + \<\< [^\>]* \>\> { strtoken $ \s -> TokPic (init $ init $ tail $ tail s) } + \< [^\>]* \> { strtoken $ \s -> TokURL (init (tail s)) } + \# [^\#]* \# { strtoken $ \s -> TokAName (init (tail s)) } \/ [^\/]* \/ { strtoken $ \s -> TokEmphasis (init (tail s)) } [\'\`] $ident+ [\'\`] { ident } \\ . { strtoken (TokString . tail) } @@ -94,6 +110,9 @@ } { +-- | A located token +type LToken = (Token, AlexPosn) + data Token = TokPara | TokNumber @@ -108,63 +127,69 @@ | TokEmphasis String | TokAName String | TokBirdTrack String + | TokExamplePrompt String + | TokExampleExpression String + | TokExampleResult String -- deriving Show +tokenPos :: LToken -> (Int, Int) +tokenPos t = let AlexPn _ line col = snd t in (line, col) + -- ----------------------------------------------------------------------------- -- Alex support stuff type StartCode = Int -type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token] - -type AlexInput = (Char,String) - -alexGetChar (_, []) = Nothing -alexGetChar (_, c:cs) = Just (c, (c,cs)) +type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken] -alexInputPrevChar (c,_) = c +tokenise :: DynFlags -> String -> (Int, Int) -> [LToken] +tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks + where + posn = AlexPn 0 line col -tokenise :: String -> [Token] -tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks - where go inp@(_,str) sc = + go inp@(pos, _, str) sc = case alexScan inp sc of AlexEOF -> [] AlexError _ -> error "lexical error" AlexSkip inp' _ -> go inp' sc - AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc) + AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags -- NB. we add a final \n to the string, (see comment in the beginning of line -- production above). eofHack str = str++"\n" andBegin :: Action -> StartCode -> Action -andBegin act new_sc = \str _ cont -> act str new_sc cont +andBegin act new_sc = \pos str _ cont dflags -> act pos str new_sc cont dflags token :: Token -> Action -token t = \_ sc cont -> t : cont sc +token t = \pos _ sc cont _ -> (t, pos) : cont sc strtoken, strtokenNL :: (String -> Token) -> Action -strtoken t = \str sc cont -> t str : cont sc -strtokenNL t = \str sc cont -> t (filter (/= '\r') str) : cont sc +strtoken t = \pos str sc cont _ -> (t str, pos) : cont sc +strtokenNL t = \pos str sc cont _ -> (t (filter (/= '\r') str), pos) : cont sc -- ^ We only want LF line endings in our internal doc string format, so we -- filter out all CRs. begin :: StartCode -> Action -begin sc = \_ _ cont -> cont sc +begin sc = \_ _ _ cont _ -> cont sc -- ----------------------------------------------------------------------------- -- Lex a string as a Haskell identifier ident :: Action -ident str sc cont = - case strToHsQNames id of - Just names -> TokIdent names : cont sc - Nothing -> TokString str : cont sc +ident pos str sc cont dflags = + case strToHsQNames dflags id of + Just names -> (TokIdent names, pos) : cont sc + Nothing -> (TokString str, pos) : cont sc where id = init (tail str) -strToHsQNames :: String -> Maybe [RdrName] -strToHsQNames str0 = +strToHsQNames :: DynFlags -> String -> Maybe [RdrName] +strToHsQNames dflags str0 = let buffer = unsafePerformIO (stringToStringBuffer str0) - pstate = mkPState buffer noSrcLoc defaultDynFlags +#if MIN_VERSION_ghc(6,13,0) + pstate = mkPState dflags buffer noSrcLoc +#else + pstate = mkPState buffer noSrcLoc dflags +#endif result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs --- a/src/Haddock/ModuleTree.hs +++ b/src/Haddock/ModuleTree.hs @@ -9,25 +9,28 @@ -- 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 = +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 @@ -39,13 +42,15 @@ 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] + (s1, '.':s2) -> s1 : split s2 + (s1, _) -> [s1] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -9,59 +9,37 @@ -- Stability : experimental -- Portability : portable -- --- Definition of the command line interface of Haddock +-- Definition of the command line interface of Haddock. ----------------------------------------------------------------------------- - - module Haddock.Options ( parseHaddockOpts, Flag(..), getUsage, + optTitle, + outputDir, + optContentsUrl, + optIndexUrl, + optCssFile, + sourceUrls, + wikiUrls, + optDumpInterfaceFile, + optLaTeXStyle, + verbosity, ghcFlags, - ifacePairs + readIfaceArgs ) where +import Data.Maybe +import Distribution.Verbosity import Haddock.Utils import Haddock.Types -import System.Console.GetOpt - - -getUsage :: IO String -getUsage = do - prog <- getProgramName - return $ usageInfo (usageHeader prog) (options False) - where - usageHeader :: String -> String - usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" - - -parseHaddockOpts :: [String] -> IO ([Flag], [String]) -parseHaddockOpts params = - case getOpt Permute (options True) params of - (flags, args, []) -> return (flags, args) - (_, _, errors) -> do - usage <- getUsage - throwE (concat errors ++ usage) - - -ghcFlags :: [Flag] -> [String] -ghcFlags flags = [ option | Flag_OptGhc option <- flags ] - - -ifacePairs :: [Flag] -> [(FilePath, FilePath)] -ifacePairs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] - - -parseIfaceOption :: String -> (FilePath, FilePath) -parseIfaceOption s = - case break (==',') s of - (fpath,',':file) -> (fpath, file) - (file, _) -> ("", file) +import System.Console.GetOpt data Flag - = Flag_CSS String + = Flag_BuiltInThemes + | Flag_CSS String | Flag_Debug -- | Flag_DocBook | Flag_ReadInterface String @@ -69,7 +47,6 @@ | Flag_Heading String | Flag_Html | Flag_Hoogle - | Flag_HtmlHelp String | Flag_Lib String | Flag_OutputDir FilePath | Flag_Prologue FilePath @@ -79,6 +56,8 @@ | Flag_WikiBaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String + | Flag_LaTeX + | Flag_LaTeXStyle String | Flag_Help | Flag_Verbosity String | Flag_Version @@ -94,75 +73,179 @@ | Flag_PrintGhcLibDir | Flag_NoWarnings | Flag_UseUnicode + | Flag_NoTmpCompDir deriving (Eq) options :: Bool -> [OptDescr Flag] options backwardsCompat = [ - Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR") - "path to a GHC lib dir, to override the default path", - Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") - "directory in which to put the output files", - Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") - "location of Haddock's auxiliary files", - Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") - "read an interface from FILE", - Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") - "interface file name", + Option ['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", +-- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) - "output in 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 [] ["html-help"] (ReqArg Flag_HtmlHelp "format") - "produce index and table of contents in\nmshelp, mshelp2 or devhelp format (with -h)", - Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") - "URL for a source code link on the contents\nand index pages", + "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)", + (ReqArg Flag_SourceModuleURL "URL") + "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)", + Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL") + "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") - "URL for a comments link on the contents\nand index pages", - Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") - "URL for a comments link for each module\n(using the %{MODULE} var)", - Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") - "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", - Option ['c'] ["css"] (ReqArg Flag_CSS "FILE") - "the CSS file to use for HTML output", + "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", + "file containing prologue text", Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") - "page heading", + "page heading", Option ['d'] ["debug"] (NoArg Flag_Debug) - "extra debugging output", + "extra debugging output", Option ['?'] ["help"] (NoArg Flag_Help) - "display this help and exit", + "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) - "output version information and exit", + "output version information and exit", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") - "set verbosity level", + "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") - "use a separately-generated HTML contents page", + "use a separately-generated HTML contents page", Option [] ["gen-contents"] (NoArg Flag_GenContents) - "generate an HTML contents from specified\ninterfaces", + "generate an HTML contents from specified\ninterfaces", Option [] ["use-index"] (ReqArg Flag_UseIndex "URL") - "use a separately-generated HTML index", + "use a separately-generated HTML index", Option [] ["gen-index"] (NoArg Flag_GenIndex) - "generate an HTML index from specified\ninterfaces", + "generate an HTML index from specified\ninterfaces", Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", + "behave as if all modules have the\nignore-exports atribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") - "behave as if MODULE has the hide attribute", + "behave as if MODULE has the hide attribute", Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") - "option to be forwarded to GHC", + "option to be forwarded to GHC", Option [] ["ghc-version"] (NoArg Flag_GhcVersion) - "output GHC version in numeric format", + "output GHC version in numeric format", Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) - "output GHC lib dir", - Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings" - ] + "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" + ] + + +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) +sourceUrls flags = + (listToMaybe [str | Flag_SourceBaseURL str <- flags] + ,listToMaybe [str | Flag_SourceModuleURL str <- flags] + ,listToMaybe [str | Flag_SourceEntityURL str <- flags]) + + +wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String) +wikiUrls flags = + (listToMaybe [str | Flag_WikiBaseURL str <- flags] + ,listToMaybe [str | Flag_WikiModuleURL str <- flags] + ,listToMaybe [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 ] + + +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/Parse.y b/src/Haddock/Parse.y --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -9,31 +9,37 @@ module Haddock.Parse where import Haddock.Lex -import Haddock.Types (Doc(..)) +import Haddock.Types (Doc(..), Example(Example)) import Haddock.Doc import HsSyn import RdrName +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import Data.List (stripPrefix) } %expect 0 -%tokentype { Token } +%tokentype { LToken } -%token '/' { TokSpecial '/' } - '@' { TokSpecial '@' } - '[' { TokDefStart } - ']' { TokDefEnd } - DQUO { TokSpecial '\"' } - URL { TokURL $$ } - PIC { TokPic $$ } - ANAME { TokAName $$ } - '/../' { TokEmphasis $$ } - '-' { TokBullet } - '(n)' { TokNumber } - '>..' { TokBirdTrack $$ } - IDENT { TokIdent $$ } - PARA { TokPara } - STRING { TokString $$ } +%token '/' { (TokSpecial '/',_) } + '@' { (TokSpecial '@',_) } + '[' { (TokDefStart,_) } + ']' { (TokDefEnd,_) } + DQUO { (TokSpecial '\"',_) } + URL { (TokURL $$,_) } + PIC { (TokPic $$,_) } + ANAME { (TokAName $$,_) } + '/../' { (TokEmphasis $$,_) } + '-' { (TokBullet,_) } + '(n)' { (TokNumber,_) } + '>..' { (TokBirdTrack $$,_) } + PROMPT { (TokExamplePrompt $$,_) } + RESULT { (TokExampleResult $$,_) } + EXP { (TokExampleExpression $$,_) } + IDENT { (TokIdent $$,_) } + PARA { (TokPara,_) } + STRING { (TokString $$,_) } %monad { Maybe } @@ -66,11 +72,24 @@ para :: { Doc RdrName } : seq { docParagraph $1 } | codepara { DocCodeBlock $1 } + | examples { DocExamples $1 } codepara :: { Doc RdrName } : '>..' codepara { docAppend (DocString $1) $2 } | '>..' { DocString $1 } +examples :: { [Example] } + : example examples { $1 : $2 } + | example { [$1] } + +example :: { Example } + : PROMPT EXP result { makeExample $1 $2 (lines $3) } + | PROMPT EXP { makeExample $1 $2 [] } + +result :: { String } + : RESULT result { $1 ++ $2 } + | RESULT { $1 } + seq :: { Doc RdrName } : elem seq { docAppend $1 $2 } | elem { $1 } @@ -98,6 +117,26 @@ | STRING strings { $1 ++ $2 } { -happyError :: [Token] -> Maybe a +happyError :: [LToken] -> Maybe a happyError toks = Nothing + +-- | Create an 'Example', stripping superfluous characters as appropriate +makeExample :: String -> String -> [String] -> Example +makeExample prompt expression result = + Example + (strip expression) -- we do not care about leading and trailing + -- whitespace in expressions, so drop them + result' + where + -- drop trailing whitespace from the prompt, remember the prefix + (prefix, _) = span isSpace prompt + -- drop, if possible, the exact same sequence of whitespace characters + -- from each result line + result' = map (tryStripPrefix prefix) result + where + tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys + +-- | Remove all leading and trailing whitespace +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse } diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -14,7 +14,6 @@ -- 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 @@ -29,141 +28,31 @@ import GHC hiding (NoLink) import Name -#ifdef TEST -import Test.QuickCheck -#endif --- convenient short-hands -type Decl = LHsDecl Name - - --- | An instance head that may have documentation. -type DocInstance name = (InstHead name, Maybe (Doc name)) - - --- | 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 = (Maybe (Doc name), FnArgsDoc name) - -noDocForDecl :: DocForDecl name -noDocForDecl = (Nothing, Map.empty) - --- | A declaration that may have documentation, including its subordinates, --- which may also have documentation -type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)]) - - --- | An extension of 'Name' that may contain the preferred place to link to in --- the documentation. -data DocName = Documented Name Module | Undocumented Name deriving Eq --- TODO: simplify to data DocName = DocName Name (Maybe Module) - - --- | The 'OccName' of this name. -docNameOcc :: DocName -> OccName -docNameOcc = nameOccName . getName - - -instance NamedThing DocName where - getName (Documented name _) = name - getName (Undocumented name) = name - - -{-! 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. - deriving (Eq, Show) - - -data ExportItem name - - = 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] - - } -- ^ An exported declaration - - | ExportNoDecl { - expItemName :: name, - - -- | Subordinate names - expItemSubs :: [name] - - } -- ^ An exported entity for which we have no - -- documentation (perhaps because it resides in - -- another package) - - | ExportGroup { - - -- | Section level (1, 2, 3, ... ) - expItemSectionLevel :: Int, - - -- | Section id (for hyperlinks) - expItemSectionId :: String, - - -- | Section heading text - expItemSectionText :: Doc name - - } -- ^ A section heading - - | ExportDoc (Doc name) -- ^ Some documentation - - | ExportModule Module -- ^ A cross-reference to another module - - --- | The head of an instance. Consists of a context, a class name and a list of --- instance types. -type InstHead name = ([HsPred name], name, [HsType name]) +----------------------------------------------------------------------------- +-- * Convenient synonyms +----------------------------------------------------------------------------- -type ModuleMap = Map Module Interface +type IfaceMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface type DocMap = Map Name (Doc DocName) - --- | An environment used to create hyper-linked syntax. -type LinkEnv = Map Name Module - - -type GhcDocHdr = Maybe LHsDocString +type SrcMap = Map PackageId FilePath +type Decl = LHsDecl Name +type GhcDocHdr = Maybe LHsDocString +type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources --- | This structure holds the module information we get from GHC's --- type checking phase -data GhcModule = GhcModule { - ghcModule :: Module, - ghcFilename :: FilePath, - ghcMbDocOpts :: Maybe String, - ghcMbDocHdr :: GhcDocHdr, - ghcGroup :: HsGroup Name, - ghcMbExports :: Maybe [LIE Name], - ghcExportedNames :: [Name], - ghcDefinedNames :: [Name], - ghcNamesInScope :: [Name], - ghcInstances :: [Instance] -} +----------------------------------------------------------------------------- +-- * Interface +----------------------------------------------------------------------------- --- | The data structure used to render a Haddock page for a module - it is --- the interface of the module. The core of Haddock lies in creating this --- structure (see Haddock.Interface). The structure also holds intermediate --- data needed during its creation. +-- | '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 represented by this interface. @@ -255,13 +144,126 @@ instSubMap = ifaceSubMap interface } -unrenameDoc :: Doc DocName -> Doc Name -unrenameDoc = fmap getName + +----------------------------------------------------------------------------- +-- * Export items & declarations +----------------------------------------------------------------------------- + + +data ExportItem name + + = 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] + + } -- ^ An exported declaration + + | ExportNoDecl { + expItemName :: name, + + -- | Subordinate names + expItemSubs :: [name] + + } -- ^ An exported entity for which we have no + -- documentation (perhaps because it resides in + -- another package) + + | ExportGroup { + + -- | Section level (1, 2, 3, ... ) + expItemSectionLevel :: Int, + + -- | Section id (for hyperlinks) + expItemSectionId :: String, + + -- | Section heading text + expItemSectionText :: Doc name + + } -- ^ A section heading + + | ExportDoc (Doc name) -- ^ Some documentation + + | ExportModule Module -- ^ A cross-reference to another module + + +-- | A declaration that may have documentation, including its subordinates, +-- which may also have documentation +type DeclInfo = (Decl, DocForDecl Name, [(Name, DocForDecl Name)]) + + +-- | 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 = (Maybe (Doc name), FnArgsDoc name) + + +noDocForDecl :: DocForDecl name +noDocForDecl = (Nothing, Map.empty) + + unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name unrenameDocForDecl (mbDoc, fnArgsDoc) = (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc) +----------------------------------------------------------------------------- +-- * Hyperlinking +----------------------------------------------------------------------------- + + +-- | An environment used to create hyper-linked syntax. +type LinkEnv = Map Name Module + + +-- | An extension of 'Name' that may contain the preferred place to link to in +-- the documentation. +data DocName = Documented Name Module | Undocumented Name deriving Eq +-- TODO: simplify to data DocName = DocName Name (Maybe Module) + + +-- | The 'OccName' of this name. +docNameOcc :: DocName -> OccName +docNameOcc = nameOccName . getName + + +instance NamedThing DocName where + getName (Documented name _) = name + getName (Undocumented name) = name + + +----------------------------------------------------------------------------- +-- * Instances +----------------------------------------------------------------------------- + + +-- | An instance head that may have documentation. +type DocInstance name = (InstHead name, Maybe (Doc name)) + + +-- | The head of an instance. Consists of a context, a class name and a list of +-- instance types. +type InstHead name = ([HsPred name], name, [HsType name]) + + +----------------------------------------------------------------------------- +-- * Documentation comments +----------------------------------------------------------------------------- + + +type LDoc id = Located (Doc id) + + data Doc id = DocEmpty | DocAppend (Doc id) (Doc id) @@ -278,34 +280,25 @@ | DocURL String | DocPic String | DocAName String + | DocExamples [Example] deriving (Eq, Show, Functor) -#ifdef TEST --- TODO: use derive -instance Arbitrary a => Arbitrary (Doc a) where - arbitrary = - oneof [ return DocEmpty - , do { a <- arbitrary; b <- arbitrary; return (DocAppend a b) } - , fmap DocString arbitrary - , fmap DocParagraph arbitrary - , fmap DocIdentifier arbitrary - , fmap DocModule arbitrary - , fmap DocEmphasis arbitrary - , fmap DocMonospaced arbitrary - , fmap DocUnorderedList arbitrary - , fmap DocOrderedList arbitrary - , fmap DocDefList arbitrary - , fmap DocCodeBlock arbitrary - , fmap DocURL arbitrary - , fmap DocPic arbitrary - , fmap DocAName arbitrary ] -#endif +unrenameDoc :: Doc DocName -> Doc Name +unrenameDoc = fmap getName -type LDoc id = Located (Doc id) +data Example = Example + { exampleExpression :: String + , exampleResult :: [String] + } deriving (Eq, Show) +exampleToString :: Example -> String +exampleToString (Example expression result) = + ">>> " ++ expression ++ "\n" ++ unlines result + + data DocMarkup id a = Markup { markupEmpty :: a, markupString :: String -> a, @@ -321,7 +314,8 @@ markupCodeBlock :: a -> a, markupURL :: String -> a, markupAName :: String -> a, - markupPic :: String -> a + markupPic :: String -> a, + markupExample :: [Example] -> a } @@ -342,15 +336,38 @@ } +----------------------------------------------------------------------------- +-- * 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. + deriving (Eq, Show) + + +----------------------------------------------------------------------------- +-- * Error handling +----------------------------------------------------------------------------- + + -- A monad which collects error messages, locally defined to avoid a dep on mtl -type ErrMsg = String +type ErrMsg = String newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } + instance Functor ErrMsgM where fmap f (Writer (a, msgs)) = Writer (f a, msgs) + instance Monad ErrMsgM where return a = Writer (a, []) m >>= k = Writer $ let @@ -358,12 +375,14 @@ (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 @@ -376,6 +395,7 @@ 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 @@ -392,8 +412,12 @@ -- 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 Monad ErrMsgGhc where return a = WriterGhc (return (a, [])) m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -10,77 +10,83 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - - module Haddock.Utils ( -- * Misc utilities - restrictTo, + restrictTo, toDescription, toInstalledDescription, -- * Filename utilities - moduleHtmlFile, nameHtmlRef, + moduleHtmlFile, contentsHtmlFile, indexHtmlFile, frameIndexHtmlFile, moduleIndexFrameName, mainFrameName, synopsisFrameName, - subIndexHtmlFile, pathJoin, - anchorNameStr, - cssFile, iconFile, jsFile, plusFile, minusFile, framesFile, + subIndexHtmlFile, + jsFile, framesFile, + -- * Anchor and URL utilities + moduleNameUrl, moduleUrl, + nameAnchorId, + makeAnchorId, + -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, - + -- * HTML cross reference mapping html_xrefs_ref, -- * Doc markup - markup, + markup, idMarkup, -- * List utilities replace, + spanWith, - -- * Binary extras --- FormatVersion, mkFormatVersion - -- * MTL stuff MonadIO(..), - + -- * Logging parseVerbosity, - out + out, + + -- * System tools + getProcessID ) where + import Haddock.Types import Haddock.GhcUtils import GHC import Name -import Binary import Control.Monad ( liftM ) -import Data.Char ( isAlpha, ord, chr ) +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 ( fromJust ) -import Data.Word ( Word8 ) -import Data.Bits ( testBit ) import System.Environment ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr ) -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe ( unsafePerformIO ) import System.FilePath import Distribution.Verbosity import Distribution.ReadE +#ifndef mingw32_HOST_OS +import qualified System.Posix.Internals +#endif + import MonadUtils ( MonadIO(..) ) --- ----------------------------------------------------------------------------- --- Logging +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- parseVerbosity :: String -> Either String Verbosity @@ -97,43 +103,48 @@ | otherwise = return () --- ----------------------------------------------------------------------------- --- Some Utilities +-------------------------------------------------------------------------------- +-- * Some Utilities +-------------------------------------------------------------------------------- --- | extract a module's short description. +-- | Extract a module's short description. toDescription :: Interface -> Maybe (Doc Name) toDescription = hmi_description . ifaceInfo --- | extract a module's short description. + +-- | Extract a module's short description. toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) toInstalledDescription = hmi_description . instInfo --- --------------------------------------------------------------------------- --- Making abstract declarations +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- -restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name) + +restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d && tcdND d == DataType -> - TyClD (d { tcdCons = restrictCons names (tcdCons d) }) - TyClD d | isDataDecl d && tcdND d == NewType -> + TyClD d | isDataDecl d && tcdND d == DataType -> + TyClD (d { tcdCons = restrictCons names (tcdCons d) }) + TyClD d | isDataDecl d && tcdND d == NewType -> case restrictCons names (tcdCons d) of - [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) + [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) [con] -> TyClD (d { tcdCons = [con] }) _ -> error "Should not happen" - TyClD d | isClassDecl d -> + TyClD d | isClassDecl d -> TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl - + + restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] -restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] - where - keep d | unLoc (con_name d) `elem` names = +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 + 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 @@ -143,10 +154,11 @@ InfixCon _ _ -> Just d where field_avail (ConDeclField n _ _) = unLoc n `elem` names - field_types flds = [ t | ConDeclField _ t _ <- flds ] - + field_types flds = [ t | ConDeclField _ t _ <- flds ] + keep _ | otherwise = Nothing + restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] restrictDecls names decls = filter keep decls where keep d = fromJust (sigName d) `elem` names @@ -157,102 +169,146 @@ restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ] --- ----------------------------------------------------------------------------- --- Filename mangling functions stolen from s main/DriverUtil.lhs. +-------------------------------------------------------------------------------- +-- * Filename mangling functions stolen from s main/DriverUtil.lhs. +-------------------------------------------------------------------------------- + moduleHtmlFile :: Module -> FilePath moduleHtmlFile mdl = case Map.lookup mdl html_xrefs of Nothing -> mdl' ++ ".html" - Just fp0 -> pathJoin [fp0, mdl' ++ ".html"] + Just fp0 -> joinPath [fp0, mdl' ++ ".html"] where - mdl' = map (\c -> if c == '.' then '-' else c) + mdl' = map (\c -> if c == '.' then '-' else c) (moduleNameString (moduleName mdl)) -nameHtmlRef :: Module -> OccName -> String -nameHtmlRef mdl n = moduleHtmlFile mdl ++ '#':escapeStr (anchorNameStr n) + contentsHtmlFile, indexHtmlFile :: String contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" + -- | The name of the module index file to be displayed inside a frame. -- Modules are display in full, but without indentation. Clicking opens in -- the main window. frameIndexHtmlFile :: String frameIndexHtmlFile = "index-frames.html" + moduleIndexFrameName, mainFrameName, synopsisFrameName :: String moduleIndexFrameName = "modules" mainFrameName = "main" synopsisFrameName = "synopsis" + subIndexHtmlFile :: Char -> String subIndexHtmlFile a = "doc-index-" ++ b ++ ".html" where b | isAlpha a = [a] | otherwise = show (ord a) -anchorNameStr :: OccName -> String -anchorNameStr name | isValOcc name = "v:" ++ occNameString name - | otherwise = "t:" ++ occNameString name -pathJoin :: [FilePath] -> FilePath -pathJoin = foldr join [] - where join :: FilePath -> FilePath -> FilePath - join path1 "" = path1 - join "" path2 = path2 - join path1 path2 - | isPathSeparator (last path1) = path1++path2 - | otherwise = path1++pathSeparator:path2 +------------------------------------------------------------------------------- +-- * 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. +------------------------------------------------------------------------------- + --- ----------------------------------------------------------------------------- --- Files we need to copy from our $libdir +moduleUrl :: Module -> String +moduleUrl = moduleHtmlFile -cssFile, iconFile, jsFile, plusFile, minusFile, framesFile :: String -cssFile = "haddock.css" -iconFile = "haskell_icon.gif" + +moduleNameUrl :: Module -> OccName -> String +moduleNameUrl mdl n = moduleUrl 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" -plusFile = "plus.gif" -minusFile = "minus.gif" framesFile = "frames.html" ------------------------------------------------------------------------------ --- misc. +------------------------------------------------------------------------------- +-- * Misc. +------------------------------------------------------------------------------- + + getProgramName :: IO String getProgramName = liftM (`withoutSuffix` ".bin") getProgName where str `withoutSuffix` suff | suff `isSuffixOf` str = take (length str - length suff) str | otherwise = str + bye :: String -> IO a bye s = putStr s >> exitWith ExitSuccess + die :: String -> IO a die s = hPutStr stderr s >> exitWith (ExitFailure 1) + dieMsg :: String -> IO a dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + noDieMsg :: String -> IO () noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) + mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] mapSnd _ [] = [] mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs + mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) mapMaybeM _ Nothing = return Nothing mapMaybeM f (Just a) = liftM Just (f a) + escapeStr :: String -> String escapeStr = escapeURIString isUnreserved + -- Following few functions are copy'n'pasted from Network.URI module -- to avoid depending on the network lib, since doing so gives a -- circular build dependency between haddock and network -- (at least if you want to build network with haddock docs) - +-- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs escapeURIChar :: (Char -> Bool) -> Char -> String escapeURIChar p c | p c = [c] @@ -267,9 +323,11 @@ | 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` "-_.~") @@ -281,36 +339,48 @@ ----------------------------------------------------------------------------- --- HTML cross references - +-- * HTML cross references +-- -- For each module, we need to know where its HTML documentation lives -- so that we can point hyperlinks to it. It is extremely -- inconvenient to plumb this information to all the places that need -- it (basically every function in HaddockHtml), and furthermore the -- mapping is constant for any single run of Haddock. So for the time -- being I'm going to use a write-once global variable. +----------------------------------------------------------------------------- + {-# NOINLINE html_xrefs_ref #-} html_xrefs_ref :: IORef (Map Module FilePath) html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) + {-# NOINLINE html_xrefs #-} html_xrefs :: Map Module FilePath html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) ----------------------------------------------------------------------------- --- List utils +-- * List utils ----------------------------------------------------------------------------- replace :: Eq a => a -> a -> [a] -> [a] -replace a b = map (\x -> if x == a then b else x) +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 +-- * 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) @@ -327,10 +397,13 @@ markup m (DocURL url) = markupURL m url markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img +markup m (DocExamples e) = markupExample m e + 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 { @@ -348,36 +421,20 @@ markupCodeBlock = DocCodeBlock, markupURL = DocURL, markupAName = DocAName, - markupPic = DocPic + markupPic = DocPic, + markupExample = DocExamples } ----------------------------------------------------------------------------- --- put here temporarily +-- * System tools +----------------------------------------------------------------------------- -newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) -nullFormatVersion :: FormatVersion -nullFormatVersion = mkFormatVersion 0 - -mkFormatVersion :: Int -> FormatVersion -mkFormatVersion = FormatVersion +#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 -instance Binary FormatVersion where - put_ bh (FormatVersion i) = - case compare i 0 of - EQ -> return () - GT -> put_ bh (-i) - LT -> error ( - "Binary.hs: negative FormatVersion " ++ show i - ++ " is not allowed") - get bh = - do - (w8 :: Word8) <- get bh - if testBit w8 7 - then - do - i <- get bh - return (FormatVersion (-i)) - else - return nullFormatVersion diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs deleted file mode 100644 --- a/src/Haddock/Utils/BlockTable.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- | - - Module : Text.Html.BlockTable - Copyright : (c) Andy Gill, and the Oregon Graduate Institute of - Science and Technology, 1999-2001 - License : BSD-style (see the file libraries/core/LICENSE) - - Maintainer : Andy Gill - Stability : experimental - Portability : portable - - $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $ - - An Html combinator library - --} - -module Haddock.Utils.BlockTable ( - --- Datatypes: - - BlockTable, -- abstract - --- Contruction Functions: - - single, - empty, - above, - beside, - --- Investigation Functions: - - getMatrix, - showsTable, - showTable, - - ) where - -import Prelude - -infixr 4 `beside` -infixr 3 `above` - --- These combinators can be used to build formated 2D tables. --- The specific target useage is for HTML table generation. - -{- - Examples of use: - - > table1 :: BlockTable String - > table1 = single "Hello" +-----+ - |Hello| - This is a 1x1 cell +-----+ - Note: single has type - - single :: a -> BlockTable a - - So the cells can contain anything. - - > table2 :: BlockTable String - > table2 = single "World" +-----+ - |World| - +-----+ - - - > table3 :: BlockTable String - > table3 = table1 %-% table2 +-----%-----+ - |Hello%World| - % is used to indicate +-----%-----+ - the join edge between - the two Tables. - - > table4 :: BlockTable String - > table4 = table3 %/% table2 +-----+-----+ - |Hello|World| - Notice the padding on the %%%%%%%%%%%%% - smaller (bottom) cell to |World | - force the table to be a +-----------+ - rectangle. - - > table5 :: BlockTable String - > table5 = table1 %-% table4 +-----%-----+-----+ - |Hello%Hello|World| - Notice the padding on the | %-----+-----+ - leftmost cell, again to | %World | - force the table to be a +-----%-----------+ - rectangle. - - Now the table can be rendered with processTable, for example: - Main> processTable table5 - [[("Hello",(1,2)), - ("Hello",(1,1)), - ("World",(1,1))], - [("World",(2,1))]] :: [[([Char],(Int,Int))]] - Main> --} - --- --------------------------------------------------------------------------- --- Contruction Functions - --- Perhaps one day I'll write the Show instance --- to show boxes aka the above ascii renditions. - -instance (Show a) => Show (BlockTable a) where - showsPrec _ = showsTable - -type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]] - -data BlockTable a = Table (Int -> Int -> TableI a) Int Int - - --- You can create a (1x1) table entry - -single :: a -> BlockTable a -single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1 - -empty :: BlockTable a -empty = Table (\ _ _ r -> r) 0 0 - - --- You can compose tables, horizonally and vertically - -above :: BlockTable a -> BlockTable a -> BlockTable a -beside :: BlockTable a -> BlockTable a -> BlockTable a - -t1 `above` t2 = trans (combine (trans t1) (trans t2) (.)) - -t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r -> - let - -- Note this depends on the fact that - -- that the result has the same number - -- of lines as the y dimention; one list - -- per line. This is not true in general - -- but is always true for these combinators. - -- I should assert this! - -- I should even prove this. - beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys - beside' (x:xs) [] = x : xs ++ r - beside' [] (y:ys) = y : ys ++ r - beside' [] [] = r - in - beside' (lst1 []) (lst2 [])) - --- trans flips (transposes) over the x and y axis of --- the table. It is only used internally, and typically --- in pairs, ie. (flip ... munge ... (un)flip). - -trans :: BlockTable a -> BlockTable a -trans (Table f1 x1 y1) = Table (flip f1) y1 x1 - -combine :: BlockTable a - -> BlockTable b - -> (TableI a -> TableI b -> TableI c) - -> BlockTable c -combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y - where - max_y = max y1 y2 - new_fn x y = - case compare y1 y2 of - EQ -> comb (f1 0 y) (f2 x y) - GT -> comb (f1 0 y) (f2 x (y + y1 - y2)) - LT -> comb (f1 0 (y + y2 - y1)) (f2 x y) - --- --------------------------------------------------------------------------- --- Investigation Functions - --- This is the other thing you can do with a Table; --- turn it into a 2D list, tagged with the (x,y) --- sizes of each cell in the table. - -getMatrix :: BlockTable a -> [[(a,(Int,Int))]] -getMatrix (Table r _ _) = r 0 0 [] - --- You can also look at a table - -showsTable :: (Show a) => BlockTable a -> ShowS -showsTable table = shows (getMatrix table) - -showTable :: (Show a) => BlockTable a -> String -showTable table = showsTable table "" diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs deleted file mode 100644 --- a/src/Haddock/Utils/Html.hs +++ /dev/null @@ -1,1037 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Text.Html --- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of --- Science and Technology, 1999-2001 --- License : BSD-style (see the file libraries/core/LICENSE) --- --- Maintainer : Andy Gill --- Stability : experimental --- Portability : portable --- --- An Html combinator library --- ------------------------------------------------------------------------------ - -module Haddock.Utils.Html ( - module Haddock.Utils.Html, - ) where - -import qualified Haddock.Utils.BlockTable as BT - -import Data.Char (isAscii, ord) -import Numeric (showHex) - -infixr 2 +++ -- combining Html -infixr 7 << -- nesting Html -infixl 8 ! -- adding optional arguments - - --- A important property of Html is that all strings inside the --- structure are already in Html friendly format. --- For example, use of >,etc. - -data HtmlElement -{- - - ..just..plain..normal..text... but using © and &amb;, etc. - -} - = HtmlString String -{- - - ..content.. - -} - | HtmlTag { -- tag with internal markup - markupTag :: String, - markupAttrs :: [HtmlAttr], - markupContent :: Html - } - -{- These are the index-value pairs. - - The empty string is a synonym for tags with no arguments. - - (not strictly HTML, but anyway). - -} - - -data HtmlAttr = HtmlAttr String String - - -newtype Html = Html { getHtmlElements :: [HtmlElement] } - --- Read MARKUP as the class of things that can be validly rendered --- inside MARKUP tag brackets. So this can be one or more Html's, --- or a String, for example. - -class HTML a where - toHtml :: a -> Html - toHtmlFromList :: [a] -> Html - - toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs]) - -instance HTML Html where - toHtml a = a - -instance HTML Char where - toHtml a = toHtml [a] - toHtmlFromList [] = Html [] - toHtmlFromList str = Html [HtmlString (stringToHtmlString str)] - -instance (HTML a) => HTML [a] where - toHtml xs = toHtmlFromList xs - -class ADDATTRS a where - (!) :: a -> [HtmlAttr] -> a - -instance (ADDATTRS b) => ADDATTRS (a -> b) where - (!) fn attr = \ arg -> fn arg ! attr - -instance ADDATTRS Html where - (!) (Html htmls) attr = Html (map addAttrs htmls) - where - addAttrs html = - case html of - HtmlTag { markupAttrs = markupAttrs0 - , markupTag = markupTag0 - , markupContent = markupContent0 } -> - HtmlTag { markupAttrs = markupAttrs0 ++ attr - , markupTag = markupTag0 - , markupContent = markupContent0 } - _ -> html - - -(<<) :: (HTML a) => (Html -> b) -> a -> b -fn << arg = fn (toHtml arg) - - -concatHtml :: (HTML a) => [a] -> Html -concatHtml as = Html (concat (map (getHtmlElements.toHtml) as)) - -(+++) :: (HTML a,HTML b) => a -> b -> Html -a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b)) - -noHtml :: Html -noHtml = Html [] - - -isNoHtml :: Html -> Bool -isNoHtml (Html xs) = null xs - - -tag :: String -> Html -> Html -tag str htmls = - Html [ HtmlTag { markupTag = str, - markupAttrs = [], - markupContent = htmls } - ] - -itag :: String -> Html -itag str = tag str noHtml - -emptyAttr :: String -> HtmlAttr -emptyAttr s = HtmlAttr s "" - -intAttr :: String -> Int -> HtmlAttr -intAttr s i = HtmlAttr s (show i) - -strAttr :: String -> String -> HtmlAttr -strAttr s t = HtmlAttr s t - - -{- -foldHtml :: (String -> [HtmlAttr] -> [a] -> a) - -> (String -> a) - -> Html - -> a -foldHtml f g (HtmlTag str attr fmls) - = f str attr (map (foldHtml f g) fmls) -foldHtml f g (HtmlString str) - = g str - --} --- Processing Strings into Html friendly things. --- This converts a String to a Html String. -stringToHtmlString :: String -> String -stringToHtmlString = concatMap fixChar - where - fixChar '<' = "<" - fixChar '>' = ">" - fixChar '&' = "&" - fixChar '"' = """ - fixChar c - | isAscii c = [c] - | otherwise = "&#x" ++ showHex (ord c) ";" - --- --------------------------------------------------------------------------- --- Classes - -instance Show Html where - showsPrec _ html = showString (prettyHtml html) - showList htmls = showString (concat (map show htmls)) - -instance Show HtmlAttr where - showsPrec _ (HtmlAttr str val) = - showString str . - showString "=" . - shows val - - --- --------------------------------------------------------------------------- --- Data types - -type URL = String - --- --------------------------------------------------------------------------- --- Basic primitives - --- This is not processed for special chars. --- use stringToHtml or lineToHtml instead, for user strings, --- because they understand special chars, like '<'. - -primHtml :: String -> Html -primHtml x = Html [HtmlString x] - --- --------------------------------------------------------------------------- --- Basic Combinators - -stringToHtml :: String -> Html -stringToHtml = primHtml . stringToHtmlString - --- This converts a string, but keeps spaces as non-line-breakable - -lineToHtml :: String -> Html -lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString - where - htmlizeChar2 ' ' = " " - htmlizeChar2 c = [c] - --- --------------------------------------------------------------------------- --- Html Constructors - --- (automatically generated) - -address :: Html -> Html -anchor :: Html -> Html -applet :: Html -> Html -area :: Html -basefont :: Html -big :: Html -> Html -blockquote :: Html -> Html -body :: Html -> Html -bold :: Html -> Html -br :: Html -button :: Html -> Html -caption :: Html -> Html -center :: Html -> Html -cite :: Html -> Html -ddef :: Html -> Html -define :: Html -> Html -dlist :: Html -> Html -dterm :: Html -> Html -emphasize :: Html -> Html -fieldset :: Html -> Html -font :: Html -> Html -form :: Html -> Html -frame :: Html -> Html -frameset :: Html -> Html -h1 :: Html -> Html -h2 :: Html -> Html -h3 :: Html -> Html -h4 :: Html -> Html -h5 :: Html -> Html -h6 :: Html -> Html -header :: Html -> Html -hr :: Html -image :: Html -input :: Html -italics :: Html -> Html -keyboard :: Html -> Html -legend :: Html -> Html -li :: Html -> Html -meta :: Html -noframes :: Html -> Html -olist :: Html -> Html -option :: Html -> Html -paragraph :: Html -> Html -param :: Html -pre :: Html -> Html -sample :: Html -> Html -script :: Html -> Html -select :: Html -> Html -small :: Html -> Html -strong :: Html -> Html -style :: Html -> Html -sub :: Html -> Html -sup :: Html -> Html -table :: Html -> Html -thetd :: Html -> Html -textarea :: Html -> Html -th :: Html -> Html -thebase :: Html -thecode :: Html -> Html -thediv :: Html -> Html -thehtml :: Html -> Html -thelink :: Html -themap :: Html -> Html -thespan :: Html -> Html -thetitle :: Html -> Html -tr :: Html -> Html -tt :: Html -> Html -ulist :: Html -> Html -underline :: Html -> Html -variable :: Html -> Html - -address = tag "ADDRESS" -anchor = tag "A" -applet = tag "APPLET" -area = itag "AREA" -basefont = itag "BASEFONT" -big = tag "BIG" -blockquote = tag "BLOCKQUOTE" -body = tag "BODY" -bold = tag "B" -br = itag "BR" -button = tag "BUTTON" -caption = tag "CAPTION" -center = tag "CENTER" -cite = tag "CITE" -ddef = tag "DD" -define = tag "DFN" -dlist = tag "DL" -dterm = tag "DT" -emphasize = tag "EM" -fieldset = tag "FIELDSET" -font = tag "FONT" -form = tag "FORM" -frame = tag "FRAME" -frameset = tag "FRAMESET" -h1 = tag "H1" -h2 = tag "H2" -h3 = tag "H3" -h4 = tag "H4" -h5 = tag "H5" -h6 = tag "H6" -header = tag "HEAD" -hr = itag "HR" -image = itag "IMG" -input = itag "INPUT" -italics = tag "I" -keyboard = tag "KBD" -legend = tag "LEGEND" -li = tag "LI" -meta = itag "META" -noframes = tag "NOFRAMES" -olist = tag "OL" -option = tag "OPTION" -paragraph = tag "P" -param = itag "PARAM" -pre = tag "PRE" -sample = tag "SAMP" -script = tag "SCRIPT" -select = tag "SELECT" -small = tag "SMALL" -strong = tag "STRONG" -style = tag "STYLE" -sub = tag "SUB" -sup = tag "SUP" -table = tag "TABLE" -thetd = tag "TD" -textarea = tag "TEXTAREA" -th = tag "TH" -thebase = itag "BASE" -thecode = tag "CODE" -thediv = tag "DIV" -thehtml = tag "HTML" -thelink = itag "LINK" -themap = tag "MAP" -thespan = tag "SPAN" -thetitle = tag "TITLE" -tr = tag "TR" -tt = tag "TT" -ulist = tag "UL" -underline = tag "U" -variable = tag "VAR" - --- --------------------------------------------------------------------------- --- Html Attributes - --- (automatically generated) - -action :: String -> HtmlAttr -align :: String -> HtmlAttr -alink :: String -> HtmlAttr -alt :: String -> HtmlAttr -altcode :: String -> HtmlAttr -archive :: String -> HtmlAttr -background :: String -> HtmlAttr -base :: String -> HtmlAttr -bgcolor :: String -> HtmlAttr -border :: Int -> HtmlAttr -bordercolor :: String -> HtmlAttr -cellpadding :: Int -> HtmlAttr -cellspacing :: Int -> HtmlAttr -checked :: HtmlAttr -clear :: String -> HtmlAttr -code :: String -> HtmlAttr -codebase :: String -> HtmlAttr -color :: String -> HtmlAttr -cols :: String -> HtmlAttr -colspan :: Int -> HtmlAttr -compact :: HtmlAttr -content :: String -> HtmlAttr -coords :: String -> HtmlAttr -enctype :: String -> HtmlAttr -face :: String -> HtmlAttr -frameborder :: Int -> HtmlAttr -height :: Int -> HtmlAttr -href :: String -> HtmlAttr -hspace :: Int -> HtmlAttr -httpequiv :: String -> HtmlAttr -identifier :: String -> HtmlAttr -ismap :: HtmlAttr -lang :: String -> HtmlAttr -link :: String -> HtmlAttr -marginheight :: Int -> HtmlAttr -marginwidth :: Int -> HtmlAttr -maxlength :: Int -> HtmlAttr -method :: String -> HtmlAttr -multiple :: HtmlAttr -name :: String -> HtmlAttr -nohref :: HtmlAttr -noresize :: HtmlAttr -noshade :: HtmlAttr -nowrap :: HtmlAttr -onclick :: String -> HtmlAttr -rel :: String -> HtmlAttr -rev :: String -> HtmlAttr -rows :: String -> HtmlAttr -rowspan :: Int -> HtmlAttr -rules :: String -> HtmlAttr -scrolling :: String -> HtmlAttr -selected :: HtmlAttr -shape :: String -> HtmlAttr -size :: String -> HtmlAttr -src :: String -> HtmlAttr -start :: Int -> HtmlAttr -target :: String -> HtmlAttr -text :: String -> HtmlAttr -theclass :: String -> HtmlAttr -thestyle :: String -> HtmlAttr -thetype :: String -> HtmlAttr -title :: String -> HtmlAttr -usemap :: String -> HtmlAttr -valign :: String -> HtmlAttr -value :: String -> HtmlAttr -version :: String -> HtmlAttr -vlink :: String -> HtmlAttr -vspace :: Int -> HtmlAttr -width :: String -> HtmlAttr - -action = strAttr "ACTION" -align = strAttr "ALIGN" -alink = strAttr "ALINK" -alt = strAttr "ALT" -altcode = strAttr "ALTCODE" -archive = strAttr "ARCHIVE" -background = strAttr "BACKGROUND" -base = strAttr "BASE" -bgcolor = strAttr "BGCOLOR" -border = intAttr "BORDER" -bordercolor = strAttr "BORDERCOLOR" -cellpadding = intAttr "CELLPADDING" -cellspacing = intAttr "CELLSPACING" -checked = emptyAttr "CHECKED" -clear = strAttr "CLEAR" -code = strAttr "CODE" -codebase = strAttr "CODEBASE" -color = strAttr "COLOR" -cols = strAttr "COLS" -colspan = intAttr "COLSPAN" -compact = emptyAttr "COMPACT" -content = strAttr "CONTENT" -coords = strAttr "COORDS" -enctype = strAttr "ENCTYPE" -face = strAttr "FACE" -frameborder = intAttr "FRAMEBORDER" -height = intAttr "HEIGHT" -href = strAttr "HREF" -hspace = intAttr "HSPACE" -httpequiv = strAttr "HTTP-EQUIV" -identifier = strAttr "ID" -ismap = emptyAttr "ISMAP" -lang = strAttr "LANG" -link = strAttr "LINK" -marginheight = intAttr "MARGINHEIGHT" -marginwidth = intAttr "MARGINWIDTH" -maxlength = intAttr "MAXLENGTH" -method = strAttr "METHOD" -multiple = emptyAttr "MULTIPLE" -name = strAttr "NAME" -nohref = emptyAttr "NOHREF" -noresize = emptyAttr "NORESIZE" -noshade = emptyAttr "NOSHADE" -nowrap = emptyAttr "NOWRAP" -onclick = strAttr "ONCLICK" -rel = strAttr "REL" -rev = strAttr "REV" -rows = strAttr "ROWS" -rowspan = intAttr "ROWSPAN" -rules = strAttr "RULES" -scrolling = strAttr "SCROLLING" -selected = emptyAttr "SELECTED" -shape = strAttr "SHAPE" -size = strAttr "SIZE" -src = strAttr "SRC" -start = intAttr "START" -target = strAttr "TARGET" -text = strAttr "TEXT" -theclass = strAttr "CLASS" -thestyle = strAttr "STYLE" -thetype = strAttr "TYPE" -title = strAttr "TITLE" -usemap = strAttr "USEMAP" -valign = strAttr "VALIGN" -value = strAttr "VALUE" -version = strAttr "VERSION" -vlink = strAttr "VLINK" -vspace = intAttr "VSPACE" -width = strAttr "WIDTH" - --- --------------------------------------------------------------------------- --- Html Constructors - --- (automatically generated) - -validHtmlTags :: [String] -validHtmlTags = [ - "ADDRESS", - "A", - "APPLET", - "BIG", - "BLOCKQUOTE", - "BODY", - "B", - "CAPTION", - "CENTER", - "CITE", - "DD", - "DFN", - "DL", - "DT", - "EM", - "FIELDSET", - "FONT", - "FORM", - "FRAME", - "FRAMESET", - "H1", - "H2", - "H3", - "H4", - "H5", - "H6", - "HEAD", - "I", - "KBD", - "LEGEND", - "LI", - "NOFRAMES", - "OL", - "OPTION", - "P", - "PRE", - "SAMP", - "SELECT", - "SMALL", - "STRONG", - "STYLE", - "SUB", - "SUP", - "TABLE", - "TD", - "TEXTAREA", - "TH", - "CODE", - "DIV", - "HTML", - "LINK", - "MAP", - "TITLE", - "TR", - "TT", - "UL", - "U", - "VAR"] - -validHtmlITags :: [String] -validHtmlITags = [ - "AREA", - "BASEFONT", - "BR", - "HR", - "IMG", - "INPUT", - "LINK", - "META", - "PARAM", - "BASE"] - -validHtmlAttrs :: [String] -validHtmlAttrs = [ - "ACTION", - "ALIGN", - "ALINK", - "ALT", - "ALTCODE", - "ARCHIVE", - "BACKGROUND", - "BASE", - "BGCOLOR", - "BORDER", - "BORDERCOLOR", - "CELLPADDING", - "CELLSPACING", - "CHECKED", - "CLEAR", - "CODE", - "CODEBASE", - "COLOR", - "COLS", - "COLSPAN", - "COMPACT", - "CONTENT", - "COORDS", - "ENCTYPE", - "FACE", - "FRAMEBORDER", - "HEIGHT", - "HREF", - "HSPACE", - "HTTP-EQUIV", - "ID", - "ISMAP", - "LANG", - "LINK", - "MARGINHEIGHT", - "MARGINWIDTH", - "MAXLENGTH", - "METHOD", - "MULTIPLE", - "NAME", - "NOHREF", - "NORESIZE", - "NOSHADE", - "NOWRAP", - "REL", - "REV", - "ROWS", - "ROWSPAN", - "RULES", - "SCROLLING", - "SELECTED", - "SHAPE", - "SIZE", - "SRC", - "START", - "TARGET", - "TEXT", - "CLASS", - "STYLE", - "TYPE", - "TITLE", - "USEMAP", - "VALIGN", - "VALUE", - "VERSION", - "VLINK", - "VSPACE", - "WIDTH"] - --- --------------------------------------------------------------------------- --- Html colors - -aqua :: String -black :: String -blue :: String -fuchsia :: String -gray :: String -green :: String -lime :: String -maroon :: String -navy :: String -olive :: String -purple :: String -red :: String -silver :: String -teal :: String -yellow :: String -white :: String - -aqua = "aqua" -black = "black" -blue = "blue" -fuchsia = "fuchsia" -gray = "gray" -green = "green" -lime = "lime" -maroon = "maroon" -navy = "navy" -olive = "olive" -purple = "purple" -red = "red" -silver = "silver" -teal = "teal" -yellow = "yellow" -white = "white" - --- --------------------------------------------------------------------------- --- Basic Combinators - -linesToHtml :: [String] -> Html - -linesToHtml [] = noHtml -linesToHtml (x:[]) = lineToHtml x -linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs - - --- --------------------------------------------------------------------------- --- Html abbriviations - -primHtmlChar :: String -> Html -copyright :: Html -spaceHtml :: Html -bullet :: Html -p :: Html -> Html - -primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";") -copyright = primHtmlChar "copy" -spaceHtml = primHtmlChar "nbsp" -bullet = primHtmlChar "#149" - -p = paragraph - --- --------------------------------------------------------------------------- --- Html tables - -cell :: Html -> HtmlTable -cell h = let - cellFn x y = h ! (add x colspan $ add y rowspan $ []) - add 1 _ rest = rest - add n fn rest = fn n : rest - r = BT.single cellFn - in - mkHtmlTable r - --- We internally represent the Cell inside a Table with an --- object of the type --- \pre{ --- Int -> Int -> Html --- } --- When we render it later, we find out how many columns --- or rows this cell will span over, and can --- include the correct colspan/rowspan command. - -newtype HtmlTable - = HtmlTable (BT.BlockTable (Int -> Int -> Html)) - -td :: Html -> HtmlTable -td = cell . thetd - -tda :: [HtmlAttr] -> Html -> HtmlTable -tda as = cell . (thetd ! as) - -above, beside :: HtmlTable -> HtmlTable -> HtmlTable -above a b = combine BT.above a b -beside a b = combine BT.beside a b - -infixr 3 -- combining table cells -infixr 4 <-> -- combining table cells -(), (<->) :: HtmlTable -> HtmlTable -> HtmlTable -() = above -(<->) = beside - -emptyTable :: HtmlTable -emptyTable = HtmlTable BT.empty - -aboves, besides :: [HtmlTable] -> HtmlTable -aboves = foldr above emptyTable -besides = foldr beside emptyTable - -mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable -mkHtmlTable r = HtmlTable r - -combine :: (BT.BlockTable (Int -> Int -> Html) - -> BT.BlockTable (Int -> Int -> Html) - -> BT.BlockTable (Int -> Int -> Html)) - -> HtmlTable -> HtmlTable -> HtmlTable -combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b) - --- renderTable takes the HtmlTable, and renders it back into --- and Html object. - -renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html -renderTable theTable - = concatHtml - [tr << [theCell x y | (theCell,(x,y)) <- theRow ] - | theRow <- BT.getMatrix theTable] - -instance HTML HtmlTable where - toHtml (HtmlTable tab) = renderTable tab - -instance Show HtmlTable where - showsPrec _ (HtmlTable tab) = shows (renderTable tab) - - --- If you can't be bothered with the above, then you --- can build simple tables with simpleTable. --- Just provide the attributes for the whole table, --- attributes for the cells (same for every cell), --- and a list of lists of cell contents, --- and this function will build the table for you. --- It does presume that all the lists are non-empty, --- and there is at least one list. --- --- Different length lists means that the last cell --- gets padded. If you want more power, then --- use the system above, or build tables explicitly. - -simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html -simpleTable attr cellAttr lst - = table ! attr - << (aboves - . map (besides . map (cell . (thetd ! cellAttr) . toHtml)) - ) lst - - --- --------------------------------------------------------------------------- --- Tree Displaying Combinators - --- The basic idea is you render your structure in the form --- of this tree, and then use treeHtml to turn it into a Html --- object with the structure explicit. - -data HtmlTree - = HtmlLeaf Html - | HtmlNode Html [HtmlTree] Html - -treeHtml :: [String] -> HtmlTree -> Html -treeHtml colors h = table ! [ - border 0, - cellpadding 0, - cellspacing 2] << treeHtml' colors h - where - manycolors = scanr (:) [] - - treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable - treeHtmls c ts = aboves (zipWith treeHtml' c ts) - - treeHtml' :: [String] -> HtmlTree -> HtmlTable - treeHtml' (_:_) (HtmlLeaf leaf) = cell - (thetd ! [width "100%"] - << bold - << leaf) - treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) = - if null ts && isNoHtml hclose - then - hd - else if null ts - then - hd bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml) - tl - else - hd (bar `beside` treeHtmls morecolors ts) - tl - where - -- This stops a column of colors being the same - -- color as the immeduately outside nesting bar. - morecolors = filter ((/= c).head) (manycolors cs) - bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml) - hd = cell (thetd ! [bgcolor c] << hopen) - tl = cell (thetd ! [bgcolor c] << hclose) - treeHtml' _ _ = error "The imposible happens" - -instance HTML HtmlTree where - toHtml x = treeHtml treeColors x - --- type "length treeColors" to see how many colors are here. -treeColors :: [String] -treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors - - --- --------------------------------------------------------------------------- --- Html Debugging Combinators - --- This uses the above tree rendering function, and displays the --- Html as a tree structure, allowing debugging of what is --- actually getting produced. - -debugHtml :: (HTML a) => a -> Html -debugHtml obj = table ! [border 0] << ( - cell (th ! [bgcolor "#008888"] - << underline - << "Debugging Output") - td << (toHtml (debug' (toHtml obj))) - ) - where - - debug' :: Html -> [HtmlTree] - debug' (Html markups) = map debug markups - - debug :: HtmlElement -> HtmlTree - debug (HtmlString str) = HtmlLeaf (spaceHtml +++ - linesToHtml (lines str)) - debug (HtmlTag { - markupTag = markupTag0, - markupContent = markupContent0, - markupAttrs = markupAttrs0 - }) = - case markupContent0 of - Html [] -> HtmlNode hd [] noHtml - Html xs -> HtmlNode hd (map debug xs) tl - where - args = if null markupAttrs0 - then "" - else " " ++ unwords (map show markupAttrs0) - hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">") - tl = font ! [size "1"] << ("") - --- --------------------------------------------------------------------------- --- Hotlink datatype - -data HotLink = HotLink { - hotLinkURL :: URL, - hotLinkContents :: [Html], - hotLinkAttributes :: [HtmlAttr] - } deriving Show - -instance HTML HotLink where - toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl) - << hotLinkContents hl - -hotlink :: URL -> [Html] -> HotLink -hotlink url h = HotLink { - hotLinkURL = url, - hotLinkContents = h, - hotLinkAttributes = [] } - - --- --------------------------------------------------------------------------- --- More Combinators - --- (Abridged from Erik Meijer's Original Html library) - -ordList :: (HTML a) => [a] -> Html -ordList items = olist << map (li <<) items - -unordList :: (HTML a) => [a] -> Html -unordList items = ulist << map (li <<) items - -defList :: (HTML a,HTML b) => [(a,b)] -> Html -defList items - = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ] - - -widget :: String -> String -> [HtmlAttr] -> Html -widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0) - -checkbox :: String -> String -> Html -hidden :: String -> String -> Html -radio :: String -> String -> Html -reset :: String -> String -> Html -submit :: String -> String -> Html -password :: String -> Html -textfield :: String -> Html -afile :: String -> Html -clickmap :: String -> Html - -checkbox n v = widget "CHECKBOX" n [value v] -hidden n v = widget "HIDDEN" n [value v] -radio n v = widget "RADIO" n [value v] -reset n v = widget "RESET" n [value v] -submit n v = widget "SUBMIT" n [value v] -password n = widget "PASSWORD" n [] -textfield n = widget "TEXT" n [] -afile n = widget "FILE" n [] -clickmap n = widget "IMAGE" n [] - -menu :: String -> [Html] -> Html -menu n choices - = select ! [name n] << [ option << p << choice | choice <- choices ] - -gui :: String -> Html -> Html -gui act = form ! [action act,method "POST"] - --- --------------------------------------------------------------------------- --- Html Rendering - --- Uses the append trick to optimize appending. --- The output is quite messy, because space matters in --- HTML, so we must not generate needless spaces. - -renderHtml :: (HTML html) => html -> String -renderHtml theHtml = - renderMessage ++ - foldr (.) id (map unprettyHtml - (getHtmlElements (tag "HTML" << theHtml))) "\n" - -renderMessage :: String -renderMessage = - "\n" ++ - "\n" - -unprettyHtml :: HtmlElement -> ShowS -unprettyHtml (HtmlString str) = (++) str -unprettyHtml (HtmlTag - { markupTag = name0, - markupContent = html, - markupAttrs = markupAttrs0 }) - = if isNoHtml html && elem name0 validHtmlITags - then renderTag True name0 markupAttrs0 0 - else (renderTag True name0 markupAttrs0 0 - . foldr (.) id (map unprettyHtml (getHtmlElements html)) - . renderTag False name0 [] 0) - --- Local Utilities -prettyHtml :: (HTML html) => html -> String -prettyHtml theHtml = - unlines - $ concat - $ map prettyHtml' - $ getHtmlElements - $ toHtml theHtml - -prettyHtml' :: HtmlElement -> [String] -prettyHtml' (HtmlString str) = [str] -prettyHtml' (HtmlTag - { markupTag = name0, - markupContent = html, - markupAttrs = markupAttrs0 }) - = if isNoHtml html && elem name0 validHtmlITags - then - [rmNL (renderTag True name0 markupAttrs0 0 "")] - else - [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ - shift (concat (map prettyHtml' (getHtmlElements html))) ++ - [rmNL (renderTag False name0 [] 0 "")] - where - shift = map (\x -> " " ++ x) - -rmNL :: [Char] -> [Char] -rmNL = filter (/= '\n') - --- This prints the Tags The lack of spaces in intentunal, because Html is --- actually space dependant. - -renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS -renderTag x name0 markupAttrs0 n r - = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r - where - open = if x then "<" else " String - showPair (HtmlAttr tag0 val) - = tag0 ++ "=\"" ++ val ++ "\"" - diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs --- a/src/Haddock/Version.hs +++ b/src/Haddock/Version.hs @@ -8,7 +8,6 @@ -- Stability : experimental -- Portability : portable ----------------------------------------------------------------------------- - module Haddock.Version ( projectName, projectVersion, projectUrl ) where diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ -- | -- Module : Main -- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009 +-- David Waern 2006-2010 -- License : BSD-like -- -- Maintainer : haddock@projects.haskell.org @@ -15,11 +15,12 @@ -- -- Program entry point and top-level code. ----------------------------------------------------------------------------- - -module Main (main) where +module Main (main, readPackagesAndProcessModules) where -import Haddock.Backends.Html +import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Themes (getThemes) +import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Interface import Haddock.Lex @@ -39,7 +40,6 @@ import System.IO import System.Exit import System.Environment -import Distribution.Verbosity #if defined(mingw32_HOST_OS) import Foreign @@ -58,10 +58,11 @@ import Config import DynFlags hiding (flags, verbosity) import Panic (handleGhcException) +import Module -------------------------------------------------------------------------------- --- Exception handling +-- * Exception handling -------------------------------------------------------------------------------- @@ -69,6 +70,7 @@ 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 @@ -101,187 +103,169 @@ hFlush stdout case e of PhaseFailed _ code -> exitWith code +#if ! MIN_VERSION_ghc(6,13,0) Interrupted -> exitFailure +#endif _ -> do print (e :: GhcException) exitFailure ------------------------------------------------------------------------------- --- Top level +-- * Top level ------------------------------------------------------------------------------- main :: IO () main = handleTopExceptions $ do - -- parse command-line flags and handle some of them initially + -- Parse command-line flags and handle some of them initially. args <- getArgs - (flags, fileArgs) <- parseHaddockOpts args - handleEasyFlags flags - verbosity <- getVerbosity flags - - let renderStep packages interfaces = do - updateHTMLXRefs packages - let ifaceFiles = map fst packages - installedIfaces = concatMap ifInstalledIfaces ifaceFiles - render flags interfaces installedIfaces + (flags, files) <- parseHaddockOpts args + shortcutFlags flags - if not (null fileArgs) + if not (null files) then do + (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files - libDir <- getGhcLibDir flags + -- Dump an "interface file" (.haddock file), if requested. + case optDumpInterfaceFile flags of + Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks + Nothing -> return () - -- We have one global error handler for all GHC source errors. Other kinds - -- of exceptions will be propagated to the top-level error handler. - let handleSrcErrors action = flip handleSourceError action $ \err -> do - printExceptionAndWarnings err - liftIO exitFailure + -- Render the interfaces. + renderStep flags packages ifaces - -- initialize GHC - startGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do + else do + when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ + throwE "No input file(s)." - -- get packages supplied with --read-interface - packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags) + -- Get packages supplied with --read-interface. + packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags) + -- Render even though there are no input files (usually contents/index). + renderStep flags packages [] - -- create the interfaces -- this is the core part of Haddock - (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags - (map fst packages) - liftIO $ do - -- render the interfaces - renderStep packages interfaces +readPackagesAndProcessModules :: [Flag] -> [String] + -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) +readPackagesAndProcessModules flags files = do + libDir <- getGhcLibDir flags - -- last but not least, dump the interface file - dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags + -- Catches all GHC source errors, then prints and re-throws them. + let handleSrcErrors action' = flip handleSourceError action' $ \err -> do + printExceptionAndWarnings err + liftIO exitFailure - else do - -- get packages supplied with --read-interface - packages <- readInterfaceFiles freshNameCache (ifacePairs flags) + -- Initialize GHC. + withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do - -- render even though there are no input files (usually contents/index) - renderStep packages [] + -- 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 -------------------------------------------------------------------------------- --- Rendering -------------------------------------------------------------------------------- + return (packages, ifaces, homeLinks) --- | Render the interfaces with whatever backend is specified in the flags -render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO () -render flags ifaces installedIfaces = do +renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep flags pkgs interfaces = do + updateHTMLXRefs pkgs let - title = case [str | Flag_Heading str <- flags] of - [] -> "" - (t:_) -> t + ifaceFiles = map snd pkgs + installedIfaces = concatMap ifInstalledIfaces ifaceFiles + srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] + render flags interfaces installedIfaces srcMap - maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags] - ,listToMaybe [str | Flag_SourceModuleURL str <- flags] - ,listToMaybe [str | Flag_SourceEntityURL str <- flags]) - maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL str <- flags] - ,listToMaybe [str | Flag_WikiModuleURL str <- flags] - ,listToMaybe [str | Flag_WikiEntityURL str <- flags]) - - libDir <- getHaddockLibDir flags - let unicode = Flag_UseUnicode `elem` flags - let css_file = case [str | Flag_CSS str <- flags] of - [] -> Nothing - fs -> Just (last fs) - - odir <- case [str | Flag_OutputDir str <- flags] of - [] -> return "." - fs -> return (last fs) +-- | Render the interfaces with whatever backend is specified in the flags. +render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render flags ifaces installedIfaces srcMap = do let - maybe_contents_url = - case [url | Flag_UseContents url <- flags] of - [] -> Nothing - us -> Just (last us) - - maybe_index_url = - case [url | Flag_UseIndex url <- flags] of - [] -> Nothing - us -> Just (last us) - - maybe_html_help_format = - case [hhformat | Flag_HtmlHelp hhformat <- flags] of - [] -> Nothing - formats -> Just (last formats) - - prologue <- getPrologue flags + title = fromMaybe "" (optTitle flags) + unicode = Flag_UseUnicode `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 - let visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] - -- *all* visible interfaces including external package modules + -- /All/ visible interfaces including external package modules. allIfaces = map toInstalledIface ifaces ++ installedIfaces allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] - packageMod = ifaceMod (head ifaces) - packageStr = Just (modulePackageString packageMod) - (pkgName,pkgVer) = modulePackageInfo packageMod + pkgMod = ifaceMod (head ifaces) + pkgId = modulePackageId pkgMod + pkgStr = Just (packageIdString pkgId) + (pkgName,pkgVer) = modulePackageInfo pkgMod + (srcBase, srcModule, srcEntity) = sourceUrls flags + srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity + sourceUrls' = (srcBase, srcModule, srcMap') + libDir <- getHaddockLibDir flags + prologue <- getPrologue flags + themes <- getThemes libDir flags >>= either bye return + when (Flag_GenIndex `elem` flags) $ do - ppHtmlIndex odir title packageStr maybe_html_help_format - maybe_contents_url maybe_source_urls maybe_wiki_urls + ppHtmlIndex odir title pkgStr + themes opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces - copyHtmlBits odir libDir css_file - - when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ - ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format [] + copyHtmlBits odir libDir themes when (Flag_GenContents `elem` flags) $ do - ppHtmlContents odir title packageStr maybe_html_help_format - maybe_index_url maybe_source_urls maybe_wiki_urls + ppHtmlContents odir title pkgStr + themes opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue - copyHtmlBits odir libDir css_file + copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do - ppHtml title packageStr visibleIfaces odir - prologue maybe_html_help_format - maybe_source_urls maybe_wiki_urls - maybe_contents_url maybe_index_url unicode - copyHtmlBits odir libDir css_file + ppHtml title pkgStr visibleIfaces odir + prologue + themes sourceUrls' opt_wiki_urls + opt_contents_url opt_index_url unicode + copyHtmlBits odir libDir themes when (Flag_Hoogle `elem` flags) $ do let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName ppHoogle 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 +-- * Reading and dumping interface files ------------------------------------------------------------------------------- readInterfaceFiles :: MonadIO m => NameCacheAccessor m - -> [(FilePath, FilePath)] -> - m [(InterfaceFile, FilePath)] + -> [(DocPaths, FilePath)] -> + m [(DocPaths, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs = do mbPackages <- mapM tryReadIface pairs return (catMaybes mbPackages) where -- try to read an interface, warn if we can't - tryReadIface (html, iface) = do - eIface <- readInterfaceFile name_cache_accessor iface + tryReadIface (paths, file) = do + eIface <- readInterfaceFile name_cache_accessor file case eIface of Left err -> liftIO $ do - putStrLn ("Warning: Cannot read " ++ iface ++ ":") + putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing - Right f -> return $ Just (f, html) + Right f -> return $ Just (paths, f) -dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO () -dumpInterfaceFile ifaces homeLinks flags = - case [str | Flag_DumpInterface str <- flags] of - [] -> return () - fs -> let filename = last fs in writeInterfaceFile filename ifaceFile +dumpInterfaceFile :: FilePath -> [InstalledInterface] -> LinkEnv -> IO () +dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile where ifaceFile = InterfaceFile { ifInstalledIfaces = ifaces, @@ -290,13 +274,14 @@ ------------------------------------------------------------------------------- --- Creating a GHC session +-- * Creating a GHC session ------------------------------------------------------------------------------- + -- | Start a GHC session with the -haddock flag set. Also turn off --- compilation and linking. -startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -startGhc libDir flags ghcActs = do +-- compilation and linking. Then run the given 'Ghc' action. +withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a +withGhc libDir flags ghcActs = do -- TODO: handle warnings? (restFlags, _) <- parseStaticFlags (map noLoc flags) runGhc (Just libDir) $ do @@ -326,9 +311,10 @@ ------------------------------------------------------------------------------- --- Misc +-- * Misc ------------------------------------------------------------------------------- + getHaddockLibDir :: [Flag] -> IO String getHaddockLibDir flags = case [str | Flag_Lib str <- flags] of @@ -340,6 +326,7 @@ #endif fs -> return (last fs) + getGhcLibDir :: [Flag] -> IO String getGhcLibDir flags = case [ dir | Flag_GhcLibDir dir <- flags ] of @@ -352,17 +339,8 @@ xs -> return $ last xs -getVerbosity :: Monad m => [Flag] -> m Verbosity -getVerbosity flags = - case [ str | Flag_Verbosity str <- flags ] of - [] -> return normal - x:_ -> case parseVerbosity x of - Left e -> throwE e - Right v -> return v - - -handleEasyFlags :: [Flag] -> IO () -handleEasyFlags flags = do +shortcutFlags :: [Flag] -> IO () +shortcutFlags flags = do usage <- getUsage when (Flag_Help `elem` flags) (bye usage) @@ -379,6 +357,14 @@ 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" @@ -387,10 +373,10 @@ byeGhcVersion = bye (cProjectVersion ++ "\n") -updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO () +updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO () updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping) where - mapping = [ (instMod iface, html) | (ifaces, html) <- packages + mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] @@ -400,8 +386,14 @@ [] -> return Nothing [filename] -> do str <- readFile filename - case parseParas (tokenise str) of - Nothing -> throwE "parsing haddock prologue failed" +#if ! MIN_VERSION_ghc(6,13,0) + let f = id +#else + let f = flattenExtensionFlags +#endif + case parseParas (tokenise (f defaultDynFlags) str + (1,0) {- TODO: real position -}) of + Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename Just doc -> return (Just doc) _otherwise -> throwE "multiple -p/--prologue options" @@ -419,6 +411,7 @@ Just d -> return (d "..") #endif + getExecDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) getExecDir = allocaArray len $ \buf -> do @@ -428,6 +421,7 @@ else do s <- peekCString buf return (Just (dropFileName s)) where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. + foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32