haddock 2.7.2 → 2.8.0
raw patch · 63 files changed
+6736/−5374 lines, 63 filesdep +xhtmldep ~basedep ~ghcbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: xhtml
Dependency ranges changed: base, ghc
API changes (from Hackage documentation)
- Documentation.Haddock: Flag_HtmlHelp :: String -> Flag
+ Documentation.Haddock: DocExamples :: [Example] -> Doc id
+ Documentation.Haddock: Example :: String -> [String] -> Example
+ Documentation.Haddock: Flag_BuiltInThemes :: Flag
+ Documentation.Haddock: Flag_LaTeX :: Flag
+ Documentation.Haddock: Flag_LaTeXStyle :: String -> Flag
+ Documentation.Haddock: Flag_NoTmpCompDir :: Flag
+ Documentation.Haddock: data Example
+ Documentation.Haddock: exampleExpression :: Example -> String
+ Documentation.Haddock: exampleResult :: Example -> [String]
+ Documentation.Haddock: markup :: DocMarkup id a -> Doc id -> a
+ Documentation.Haddock: markupExample :: DocMarkup id a -> [Example] -> a
+ Documentation.Haddock: processModules :: Verbosity -> [String] -> [Flag] -> [InterfaceFile] -> Ghc ([Interface], LinkEnv)
+ Documentation.Haddock: type Decl = LHsDecl Name
- Documentation.Haddock: Markup :: a -> (String -> a) -> (a -> a) -> (a -> a -> a) -> ([id] -> a) -> (String -> a) -> (a -> a) -> (a -> a) -> ([a] -> a) -> ([a] -> a) -> ([(a, a)] -> a) -> (a -> a) -> (String -> a) -> (String -> a) -> (String -> a) -> DocMarkup id a
+ Documentation.Haddock: Markup :: a -> (String -> a) -> (a -> a) -> (a -> a -> a) -> ([id] -> a) -> (String -> a) -> (a -> a) -> (a -> a) -> ([a] -> a) -> ([a] -> a) -> ([(a, a)] -> a) -> (a -> a) -> (String -> a) -> (String -> a) -> (String -> a) -> ([Example] -> a) -> DocMarkup id a
- Documentation.Haddock: createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile] -> Ghc ([Interface], LinkEnv)
+ Documentation.Haddock: createInterfaces :: [Flag] -> [String] -> IO [Interface]
Files
- CHANGES +40/−0
- LICENSE +1/−1
- dist/build/haddock/haddock-tmp/Haddock/Lex.hs +200/−70
- dist/build/haddock/haddock-tmp/Haddock/Parse.hs +286/−192
- doc/configure.ac +1/−1
- doc/haddock.xml +307/−143
- haddock.cabal +45/−26
- haddock.spec +1/−1
- html/Classic.theme/haskell_icon.gif binary
- html/Classic.theme/minus.gif binary
- html/Classic.theme/plus.gif binary
- html/Classic.theme/xhaddock.css +487/−0
- html/Ocean.std-theme/hslogo-16.png binary
- html/Ocean.std-theme/minus.gif binary
- html/Ocean.std-theme/ocean.css +542/−0
- html/Ocean.std-theme/plus.gif binary
- html/Ocean.std-theme/synopsis.png binary
- html/frames.html +28/−27
- html/haddock-DEBUG.css +0/−173
- html/haddock-util.js +185/−13
- html/haddock.css +0/−297
- html/haskell_icon.gif binary
- html/minus.gif binary
- html/plus.gif binary
- latex/haddock.sty +57/−0
- src/Documentation/Haddock.hs +23/−5
- src/Haddock/Backends/DevHelp.hs +0/−86
- src/Haddock/Backends/HH.hs +0/−186
- src/Haddock/Backends/HH2.hs +0/−197
- src/Haddock/Backends/HaddockDB.hs +0/−1
- src/Haddock/Backends/Hoogle.hs +4/−7
- src/Haddock/Backends/Html.hs +0/−1993
- src/Haddock/Backends/LaTeX.hs +1170/−0
- src/Haddock/Backends/Xhtml.hs +652/−0
- src/Haddock/Backends/Xhtml/Decl.hs +734/−0
- src/Haddock/Backends/Xhtml/DocMarkup.hs +124/−0
- src/Haddock/Backends/Xhtml/Layout.hs +206/−0
- src/Haddock/Backends/Xhtml/Names.hs +92/−0
- src/Haddock/Backends/Xhtml/Themes.hs +207/−0
- src/Haddock/Backends/Xhtml/Types.hs +29/−0
- src/Haddock/Backends/Xhtml/Utils.hs +201/−0
- src/Haddock/Convert.hs +35/−9
- src/Haddock/Doc.hs +1/−0
- src/Haddock/GhcUtils.hs +55/−15
- src/Haddock/Interface.hs +122/−100
- src/Haddock/Interface/AttachInstances.hs +39/−19
- src/Haddock/Interface/Create.hs +45/−36
- src/Haddock/Interface/ExtractFnArgDocs.hs +0/−1
- src/Haddock/Interface/LexParseRn.hs +12/−14
- src/Haddock/Interface/ParseModuleHeader.hs +7/−6
- src/Haddock/Interface/Rename.hs +1/−1
- src/Haddock/Interface/Rn.hs +3/−2
- src/Haddock/InterfaceFile.hs +50/−17
- src/Haddock/Lex.x +52/−27
- src/Haddock/ModuleTree.hs +9/−4
- src/Haddock/Options.hs +168/−85
- src/Haddock/Parse.y +57/−18
- src/Haddock/Types.hs +176/−152
- src/Haddock/Utils.hs +155/−98
- src/Haddock/Utils/BlockTable.hs +0/−180
- src/Haddock/Utils/Html.hs +0/−1037
- src/Haddock/Version.hs +0/−1
- src/Main.hs +127/−133
CHANGES view
@@ -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
LICENSE view
@@ -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:
dist/build/haddock/haddock-tmp/Haddock/Lex.hs view
@@ -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 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# 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 "<built-in>" #-}@@ -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
dist/build/haddock/haddock-tmp/Haddock/Parse.hs view
@@ -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 "<built-in>" #-}@@ -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 #-}
doc/configure.ac view
@@ -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])
doc/haddock.xml view
@@ -10,13 +10,18 @@ <firstname>Simon</firstname> <surname>Marlow</surname> </author>- <address><email>simonmar@microsoft.com</email></address>+ <address><email>marlowsd@gmail.com</email></address>+ <author>+ <firstname>David</firstname>+ <surname>Waern</surname>+ </author>+ <address><email>david.waern@gmail.com</email></address> <copyright>- <year>2004</year>- <holder>Simon Marlow</holder>+ <year>2010</year>+ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.7.2, a Haskell+ <para>This document describes Haddock version 2.8.0, a Haskell documentation tool.</para> </abstract> </bookinfo>@@ -93,7 +98,7 @@ </listitem> <listitem> <para>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.</para> </listitem>@@ -120,7 +125,7 @@ Haddock source code, except where otherwise indicated.</para> <blockquote>- <para>Copyright 2002, Simon Marlow. All rights reserved.</para>+ <para>Copyright 2002-2010, Simon Marlow. All rights reserved.</para> <para>Redistribution and use in source and binary forms, with or without modification, are permitted provided that the@@ -157,6 +162,51 @@ </section> <section>+ <title>Contributors</title>+ <para>Haddock was originally written by Simon Marlow. Since it is an open source+ project, many people have contributed to its development over the years.+ Below is a list of contributors in alphabetical order that we hope is+ somewhat complete. If you think you are missing from this list, please contact+ us.+ </para>+ <itemizedlist>+ <listitem>Ashley Yakeley</listitem>+ <listitem>Benjamin Franksen</listitem>+ <listitem>Brett Letner</listitem>+ <listitem>Clemens Fruhwirth</listitem>+ <listitem>Conal Elliott</listitem>+ <listitem>David Waern</listitem> + <listitem>Duncan Coutts</listitem>+ <listitem>George Pollard</listitem>+ <listitem>George Russel</listitem>+ <listitem>Hal Daume</listitem>+ <listitem>Ian Lynagh</listitem>+ <listitem>Isaac Dupree</listitem>+ <listitem>Joachim Breitner</listitem>+ <listitem>Krasimir Angelov</listitem>+ <listitem>Lennart Augustsson</listitem>+ <listitem>Luke Plant</listitem>+ <listitem>Malcolm Wallace</listitem>+ <listitem>Mark Lentczner</listitem>+ <listitem>Mark Shields</listitem>+ <listitem>Neil Mitchell</listitem>+ <listitem>Mike Thomas</listitem>+ <listitem>Manuel Chakravarty</listitem>+ <listitem>Oliver Brown</listitem>+ <listitem>Roman Cheplyaka</listitem>+ <listitem>Ross Paterson</listitem>+ <listitem>Simon Hengel</listitem>+ <listitem>Simon Marlow</listitem>+ <listitem>Simon Peyton-Jones</listitem>+ <listitem>Sigbjorn Finne</listitem>+ <listitem>Stefan O'Rear</listitem>+ <listitem>Sven Panne</listitem>+ <listitem>Thomas Schilling</listitem>+ <listitem>Wolfgang Jeltsch</listitem>+ <listitem>Yitzchak Gale</listitem>+ </itemizedlist>+ </section>+ <section> <title>Acknowledgements</title> <para>Several documentation systems provided the inspiration for@@ -180,12 +230,9 @@ <para>and probably several others I've forgotten.</para> - <para>Thanks to the following people for useful feedback,- discussion, patches, packaging, and moral support: Simon Peyton- Jones, Mark Shields, Manuel Chakravarty, Ross Patterson, Brett- Letner, Sven Panne, Hal Daume, George Russell, Oliver Braun,- Ashley Yakeley, Malcolm Wallace, Krasimir Angelov, the members- of <email>haskelldoc@haskell.org</email>, and everyone who+ <para>Thanks to the the members+ of <email>haskelldoc@haskell.org</email>,+ <email>haddock@projects.haskell.org</email> and everyone who contributed to the many libraries that Haddock makes use of.</para> </section>@@ -247,27 +294,30 @@ <varlistentry> <term>- <indexterm><primary><option>--optghc</option></primary></indexterm>- <option>--optghc</option>=<replaceable>option</replaceable>+ <indexterm><primary><option>-o</option></primary></indexterm>+ <option>-o</option> <replaceable>dir</replaceable> </term>+ <term>+ <indexterm><primary><option>--odir</option></primary></indexterm>+ <option>--odir</option>=<replaceable>dir</replaceable>+ </term> <listitem>- <para>Pass <replaceable>option</replaceable> to GHC.</para>+ <para>Generate files into <replaceable>dir</replaceable>+ instead of the current directory.</para> </listitem> </varlistentry> - <varlistentry> <term>- <indexterm><primary><option>-o</option></primary></indexterm>- <option>-o</option> <replaceable>dir</replaceable>+ <indexterm><primary><option>-l</option></primary></indexterm>+ <option>-l</option> <replaceable>dir</replaceable> </term> <term>- <indexterm><primary><option>--odir</option></primary></indexterm>- <option>--odir</option>=<replaceable>dir</replaceable>+ <indexterm><primary><option>--lib</option></primary></indexterm>+ <option>--lib</option>=<replaceable>dir</replaceable> </term> <listitem>- <para>Generate files into <replaceable>dir</replaceable>- instead of the current directory.</para>+ <para>Use Haddock auxiliary files (themes, javascript, etc...) in <replaceable>dir</replaceable>.</para> </listitem> </varlistentry> @@ -329,35 +379,6 @@ <varlistentry> <term>- <indexterm><primary><option>-l</option></primary></indexterm>- <option>-l</option> <replaceable>dir</replaceable>- </term>- <term>- <indexterm><primary><option>--lib</option></primary></indexterm>- <option>--lib</option>=<replaceable>dir</replaceable>- </term>- <listitem>- <para>Use auxiliary files in <replaceable>dir</replaceable>.</para>- </listitem>- </varlistentry>-- <varlistentry>- <term>- <indexterm><primary><option>-S</option></primary></indexterm>- <option>-S</option>- </term>- <term>- <indexterm><primary><option>--docbook</option></primary></indexterm>- <option>--docbook</option>- </term>- <listitem>- <para>Reserved for future use (output documentation in DocBook XML- format).</para>- </listitem>- </varlistentry>-- <varlistentry>- <term> <indexterm><primary><option>-h</option></primary></indexterm> <option>-h</option> </term>@@ -372,6 +393,15 @@ given), including the following:</para> <variablelist> <varlistentry>+ <term><filename><replaceable>module</replaceable>.html</filename></term>+ <term><filename>mini_<replaceable>module</replaceable>.html</filename></term>+ <listitem>+ <para>An HTML page for each+ <replaceable>module</replaceable>, and a "mini" page for+ each used when viewing in frames.</para>+ </listitem>+ </varlistentry>+ <varlistentry> <term><filename>index.html</filename></term> <listitem> <para>The top level page of the documentation: lists@@ -380,36 +410,33 @@ </listitem> </varlistentry> <varlistentry>- <term><filename>haddock.css</filename></term>+ <term><filename>doc-index.html</filename></term>+ <term><filename>doc-index-<replaceable>X</replaceable>.html</filename></term> <listitem>- <para>The stylesheet used by the generated HTML. Feel- free to modify this to change the colors or- layout, or even specify your own stylesheet using the- <option>--css</option> option.</para>+ <para>The alphabetic index, possibly split into multiple+ pages if big enough.</para> </listitem> </varlistentry> <varlistentry>- <term><filename>haddock-util.js</filename></term>+ <term><filename>frames.html</filename></term> <listitem>- <para>A small piece of JavaScript for collapsing sections- of the generated HTML.</para>+ <para>The top level document when viewing in frames.</para> </listitem> </varlistentry> <varlistentry>- <term><filename><replaceable>module</replaceable>.html</filename></term>+ <term><filename><replaceable>some</replaceable>.css</filename></term>+ <term><filename><replaceable>etc...</replaceable></filename></term> <listitem>- <para>An HTML page for each- <replaceable>module</replaceable>.</para>+ <para>Files needed for the themes used. Specify your themes+ using the <option>--theme</option> option.</para> </listitem> </varlistentry> <varlistentry>- <term><filename>doc-index.html</filename></term>- <term><filename>doc-index-XX.html</filename></term>+ <term><filename>haddock-util.js</filename></term> <listitem>- <para>The index, split into two- (functions/constructors and types/classes, as per- Haskell namespaces) and further split- alphabetically.</para>+ <para>Some JavaScript utilities used to implement some of the+ dynamic features like collapsable sections, and switching to+ frames view.</para> </listitem> </varlistentry> </variablelist>@@ -417,61 +444,81 @@ </varlistentry> <varlistentry>- <term>- <indexterm><primary><option>-m</option></primary></indexterm>- <option>-m</option>- </term>- <term>- <indexterm><primary><option>--html-help</option></primary></indexterm>- <option>--html-help</option>+ <term>+ <indexterm><primary><option>--latex</option></primary></indexterm>+ <option>--latex</option> </term>- <listitem>- <para>(In HTML mode only) Produce extra contents and index- files for given HTML Help system. Currently supported Help- systems are Microsoft HTML Help 1.3 and 2.0 and GNOME DevHelp.</para>-- <para>Using the Microsoft HTML Help system provides two- advantages over plain HTML: the help viewer gives you a nice- hierarchical folding contents pane on the left, and the- documentation files are compressed and therefore much- smaller (roughly a factor of 10). The disadvantage is that- the help can't be viewed over the web.</para>-- <para>In order to create a compiled Microsoft help file, you- also need the Microsoft HTML Help compiler, which is- available free from- <ulink url="http://www.microsoft.com/">http://www.microsoft.com/</ulink>- (search for <quote>HTML Help compiler</quote>).</para>-- <para>Viewers</para>+ <listitem>+ <para>Generate documentation in LaTeX format. Several files+ will be generated into the current directory (or the+ specified directory if the <option>-o</option> option is+ given), including the following:</para>+ <variablelist>- <varlistentry>- <term>Microsoft HTML Help Viewer</term>- <listitem><para>Distributed with Microsoft Windows</para></listitem>- </varlistentry>- <varlistentry>- <term><ulink url="http://xchm.sourceforge.net">xCHM</ulink></term>- <listitem><para>a CHM viewer for UNIX (Linux, *BSD, Solaris), written by Razvan Cojocaru</para></listitem>+ <varlistentry>+ <term><filename><replaceable>package</replaceable>.tex</filename></term>+ <listitem>+ <para>The top-level LaTeX source file; to format the+ documentation into PDF you might run something like+ this:</para>+<screen>+$ pdflatex <replaceable>package</replaceable>.tex</screen>+ </listitem> </varlistentry> <varlistentry>- <term><ulink url="http://www.jouledata.com/MacProducts.html">JouleData Solutions' CHM Viewer</ulink></term>- <listitem><para>a comercial 100% native Cocoa .chm file viewer for the Mac OS X platform</para></listitem>+ <term><filename>haddock.sty</filename></term>+ <listitem>+ <para>The default style. The file contains+ definitions for various macros used in the LaTeX+ sources generated by Haddock; to change the way the+ formatted output looks, you might want to override+ these by specifying your own style with+ the <option>--latex-style</option> option.</para>+ </listitem> </varlistentry> <varlistentry>- <term><ulink url="http://gnochm.sourceforge.net">GnoCHM</ulink></term>- <listitem><para>a CHM file viewer. It is designed to integrate nicely with Gnome.</para></listitem>+ <term><filename><replaceable>module</replaceable>.tex</filename></term>+ <listitem>+ <para>The LaTeX documentation for+ each <replaceable>module</replaceable>.</para>+ </listitem> </varlistentry>- </variablelist>+ </variablelist>+ </listitem>+ </varlistentry> - <para>The GNOME DevHelp also provides help viewer which looks like- MSHelp viewer but the documentation files aren't compressed.- The documentation can be viewed with any HTML browser but- DevHelp gives you a nice hierarchical folding contents and- keyword index panes on the left. The DevHelp expects to see- *.devhelp file in the folder where the documentation is placed.- The file contains all required information- to build the contents and index panes.- </para>+ <varlistentry>+ <term>+ <indexterm><primary><option>--latex-style</option></primary></indexterm>+ <option>--latex-style=<replaceable>style</replaceable></option>+ </term>+ <listitem>+ <para>This option lets you override the default style used+ by the LaTeX generated by the <option>--latex</option> option.+ Normally Haddock puts a+ standard <filename>haddock.sty</filename> in the output+ directory, and includes the+ command <literal>\usepackage{haddock}</literal> in the+ LaTeX source. If this option is given,+ then <filename>haddock.sty</filename> is not generated,+ and the command is+ instead <literal>\usepackage{<replaceable>style</replaceable>}</literal>.+ </para>+ </listitem>+ </varlistentry>++ <varlistentry>+ <term>+ <indexterm><primary><option>-S</option></primary></indexterm>+ <option>-S</option>+ </term>+ <term>+ <indexterm><primary><option>--docbook</option></primary></indexterm>+ <option>--docbook</option>+ </term>+ <listitem>+ <para>Reserved for future use (output documentation in DocBook XML+ format).</para> </listitem> </varlistentry> @@ -637,6 +684,59 @@ <varlistentry> <term>+ <indexterm><primary><option>--theme</option></primary></indexterm>+ <option>--theme</option>=<replaceable>path</replaceable>+ </term>+ <listitem>+ <para>Specify a theme to be used for HTML (<option>--html</option>)+ documentation. If given multiple times then the pages will use the+ first theme given by default, and have alternate style sheets for+ the others. The reader can switch between themes with browsers that+ support alternate style sheets, or with the "Style" menu that gets + added when the page is loaded. If+ no themes are specified, then just the default built-in theme+ ("Ocean") is used.+ </para>+ + <para>The <replaceable>path</replaceable> parameter can be one of:+ </para>++ <itemizedlist>+ <listitem>+ <para>A <emphasis>directory</emphasis>: The base name of+ the directory becomes the name of the theme. The directory+ must contain exactly one+ <filename><replaceable>some</replaceable>.css</filename> file.+ Other files, usually image files, will be copied, along with+ the <filename><replaceable>some</replaceable>.css</filename>+ file, into the generated output directory.</para>+ </listitem>+ <listitem>+ <para>A <emphasis>CSS file</emphasis>: The base name of+ the file becomes the name of the theme.</para>+ </listitem>+ <listitem>+ <para>The <emphasis>name</emphasis> of a built-in theme+ ("Ocean" or "Classic").</para>+ </listitem>+ </itemizedlist>+ </listitem>+ </varlistentry>++ <varlistentry>+ <term>+ <indexterm><primary><option>--built-in-themes</option></primary></indexterm>+ <option>--built-in-themes</option>+ </term>+ <listitem>+ <para>Includes the built-in themes ("Ocean" and "Classic").+ Can be combined with <option>--theme</option>. Note that order+ matters: The first specified theme will be the default.</para>+ </listitem>+ </varlistentry>++ <varlistentry>+ <term> <indexterm><primary><option>-c</option></primary></indexterm> <option>-c</option> <replaceable>file</replaceable> </term>@@ -645,9 +745,7 @@ <option>--css</option>=<replaceable>file</replaceable> </term> <listitem>- <para>Specify a stylesheet to use instead of the default one- that comes with Haddock. It should specify certain classes:- see the default stylesheet for details.</para>+ <para>Deprecated aliases for <option>--theme</option></para> </listitem> </varlistentry> @@ -718,6 +816,20 @@ <varlistentry> <term>+ <indexterm><primary><option>-V</option></primary></indexterm>+ <option>-V</option>+ </term>+ <term>+ <indexterm><primary><option>--version</option></primary></indexterm>+ <option>--version</option>+ </term>+ <listitem>+ <para>Output version information and exit.</para>+ </listitem>+ </varlistentry>++ <varlistentry>+ <term> <indexterm><primary><option>-v</option></primary></indexterm> <option>-v</option> </term>@@ -736,44 +848,39 @@ <varlistentry> <term>- <indexterm><primary><option>-V</option></primary></indexterm>- <option>-V</option>+ <indexterm><primary><option>--use-contents</option></primary></indexterm>+ <option>--use-contents=<replaceable>URL</replaceable></option> </term> <term>- <indexterm><primary><option>--version</option></primary></indexterm>- <option>--version</option>- </term>- <listitem>- <para>Output version information and exit.</para>- </listitem>- </varlistentry>-- <varlistentry>- <term> <indexterm><primary><option>--use-index</option></primary></indexterm> <option>--use-index=<replaceable>URL</replaceable></option> </term> <listitem> <para>When generating HTML, do not generate an index.- Instead, redirect the Index link on each page to+ Instead, redirect the Contents and/or Index link on each page to <replaceable>URL</replaceable>. This option is intended for- use in conjuction with <option>--gen-index</option> for- generating a separate index covering multiple+ use in conjuction with <option>--gen-contents</option> and/or + <option>--gen-index</option> for+ generating a separate contents and/or index covering multiple libraries.</para> </listitem> </varlistentry> <varlistentry> <term>+ <indexterm><primary><option>--gen-contents</option></primary></indexterm>+ <option>--gen-contents</option>+ </term>+ <term> <indexterm><primary><option>--gen-index</option></primary></indexterm> <option>--gen-index</option> </term> <listitem>- <para>Generate an HTML index containing entries pulled from- all the specified interfaces (interfaces are specified using+ <para>Generate an HTML contents and/or index containing entries pulled + from all the specified interfaces (interfaces are specified using <option>-i</option> or <option>--read-interface</option>).- This is used to generate a single index for multiple sets of- Haddock documentation.</para>+ This is used to generate a single contents and/or index for multiple + sets of Haddock documentation.</para> </listitem> </varlistentry> @@ -806,6 +913,16 @@ </varlistentry> <varlistentry>+ <term>+ <indexterm><primary><option>--optghc</option></primary></indexterm>+ <option>--optghc</option>=<replaceable>option</replaceable>+ </term>+ <listitem>+ <para>Pass <replaceable>option</replaceable> to GHC.</para>+ </listitem>+ </varlistentry>++ <varlistentry> <term> <indexterm><primary><option>-w</option></primary></indexterm> <option>-w</option>@@ -818,6 +935,26 @@ <para>Turn off all warnings.</para> </listitem> </varlistentry>++ <varlistentry>+ <term>+ <indexterm><primary><option>--no-tmp-comp-dir</option></primary></indexterm>+ <option>--no-tmp-comp-dir</option>+ </term>+ <listitem>+ <para>+ Do not use a temporary directory for reading and writing compilation output files+ (<literal>.o</literal>, <literal>.hi</literal>, and stub files). Instead, use the+ present directory or another directory that you have explicitly told GHC to use+ via the <literal>--optghc</literal> flag.+ </para>+ <para>+ This flag can be used to avoid recompilation if compilation files already exist.+ Compilation files are produced when Haddock has to process modules that make use of+ Template Haskell, in which case Haddock compiles the modules using the GHC API. + </para>+ </listitem>+ </varlistentry> </variablelist> <section id="cpp">@@ -1409,12 +1546,17 @@ one of these special characters, precede it with a backslash (<literal>\</literal>).</para> - <para>Additionally, the character <literal>></literal> has- a special meaning at the beginning of a line, and the- following characters have special meanings at the beginning of- a paragraph:- <literal>*</literal>, <literal>-</literal>. These characters- can also be escaped using <literal>\</literal>.</para>+ <para>Additionally, the character <literal>></literal> has+ a special meaning at the beginning of a line, and the+ following characters have special meanings at the beginning of+ a paragraph:+ <literal>*</literal>, <literal>-</literal>. These characters+ can also be escaped using <literal>\</literal>.</para>++ <para>Furthermore, the character sequence <literal>>>></literal>+ has a special meaning at the beginning of a line. To+ escape it, just prefix the characters in the sequence with a+ backslash.</para> </section> <section>@@ -1464,6 +1606,28 @@ literally, whereas the <literal>@...@</literal> form interprets markup as normal inside the code block.</para> </section>++ <section>+ <title>Examples</title>++ <para> Haddock has markup support for examples of interaction with a+ <emphasis>read-eval-print loop (REPL)</emphasis>. An+ example is introduced with+ <literal>>>></literal> followed by an expression followed+ by zero or more result lines:</para>++<programlisting>+-- | Two examples are given bellow:+--+-- >>> fib 10+-- 55+--+-- >>> putStrLn "foo\nbar"+-- foo+-- bar+</programlisting>+ </section>+ <section> <title>Hyperlinked Identifiers</title>
haddock.cabal view
@@ -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
haddock.spec view
@@ -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}
+ html/Classic.theme/haskell_icon.gif view
binary file changed (absent → 911 bytes)
+ html/Classic.theme/minus.gif view
binary file changed (absent → 56 bytes)
+ html/Classic.theme/plus.gif view
binary file changed (absent → 59 bytes)
+ html/Classic.theme/xhaddock.css view
@@ -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 }++/* <tt> font is a little too small in MSIE */+tt { font-size: 100%; }+pre { font-size: 100%; }+.keyword { text-decoration: underline; }+.caption {+ font-weight: bold;+ margin: 0;+ padding: 0;+}++h1 {+ padding-top: 15px;+ font-weight: bold;+ font-size: 150%;+}++h2 {+ padding-top: 10px;+ font-weight: bold;+ font-size: 130%+ }++h3 {+ padding-top: 5px;+ font-weight: bold;+ font-size: 110%+ }++h4, h5 {+ font-weight: bold;+ font-size: 100%+ }++h1, h2, h3, h4, h5 {+ margin-top: 0.5em;+ margin-bottom: 0.5em;+}++p { + padding-top: 2px;+ padding-left: 10px;+}++ul, ol, dl {+ padding-top: 2px;+ padding-left: 10px;+ margin-left: 2.5em;+}++pre { + padding-top: 2px;+ padding-left: 20px;+}++* + p, * + pre {+ margin-top: 1em;+}+.caption + p, .src + p {+ margin-top: 0;+}++.def {+ font-weight: bold;+}++ul.links {+ list-style: none;+ text-align: left;+ float: right;+ display: inline-table;+ padding: 0;+}++ul.links li {+ display: inline;+ border-left-width: 1px;+ border-left-color: #ffffff;+ border-left-style: solid;+ white-space: nowrap;+ padding: 1px 5px;+}++.hide { display: none; }+.show { }+.collapser {+ background: url(minus.gif) no-repeat 0 0.3em;+}+.expander {+ background: url(plus.gif) no-repeat 0 0.3em;+}+.collapser, .expander {+ padding-left: 14px;+ cursor: pointer;+}++#package-header {+ color: #ffffff;+ padding: 5px 5px 5px 31px;+ margin: 0 0 1px;+ background: #000099 url(haskell_icon.gif) no-repeat 5px 6px;+ position: relative;+}++#package-header .caption {+ font-weight: normal;+ font-style: normal;+}+#package-header a:link { color: #ffffff }+#package-header a:visited { color: #ffff00 }+#package-header a:hover { background-color: #6060ff; }+#package-header ul.links li:hover { background-color: #6060ff; }++div#style-menu-holder {+ position: relative;+ z-index: 2;+ display: inline;+}++#style-menu {+ position: absolute;+ z-index: 1;+ overflow: visible;+ background-color: #000099;+ margin: 0;+ width: 6em;+ text-align: center;+ right: 0;+ padding: 2px 2px 1px;+}++#style-menu li {+ display: list-item;+ border-style: none;+ margin: 0;+ padding: 3px;+ color: #000;+ list-style-type: none;+ border-top: 1px solid #ffffff;+}++#module-header {+ 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;+}++++
+ html/Ocean.std-theme/hslogo-16.png view
binary file changed (absent → 1684 bytes)
+ html/Ocean.std-theme/minus.gif view
binary file changed (absent → 56 bytes)
+ html/Ocean.std-theme/ocean.css view
@@ -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 */
+ html/Ocean.std-theme/plus.gif view
binary file changed (absent → 59 bytes)
+ html/Ocean.std-theme/synopsis.png view
binary file changed (absent → 11327 bytes)
html/frames.html view
@@ -1,27 +1,28 @@-<html> -<head> -<script type="text/javascript"><!-- -/* - - The synopsis frame needs to be updated using javascript, so we hide - it by default and only show it if javascript is enabled. - - TODO: provide some means to disable it. -*/ -function load() { - var d = document.getElementById("inner-fs"); - d.rows = "50%,50%"; -} ---></script> -<frameset id="outer-fs" cols="25%,75%" onload="load()"> - <frameset id="inner-fs" rows="100%,0%"> - - <frame src="index-frames.html" name="modules"> - <frame src="" name="synopsis"> - - </frameset> - <frame src="index.html" name="main"> - -</frameset> - -</html> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+<script src="haddock-util.js" type="text/javascript"></script>+<script type="text/javascript"><!--+/*++ The synopsis frame needs to be updated using javascript, so we hide+ it by default and only show it if javascript is enabled.++ TODO: provide some means to disable it.+*/+function load() {+ var d = document.getElementById("inner-fs");+ d.rows = "50%,50%";+ postReframe();+}+--></script>+<frameset id="outer-fs" cols="25%,75%" onload="load()">+ <frameset id="inner-fs" rows="100%,0%">+ <frame src="index-frames.html" name="modules">+ <frame src="" name="synopsis">+ </frameset>+ <frame src="index.html" name="main">+</frameset>+</html>
− html/haddock-DEBUG.css
@@ -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- }-
html/haddock-util.js view
@@ -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("<a href='#' onclick='reframe();return true;'>Frames</a>");+ bodyCls = "no-frame";+ }+ else {+ bodyCls = "in-frame";+ }+ addClass(document.body, bodyCls);+}++function reframe() {+ setCookie("haddock-reframe", document.URL);+ window.location = "frames.html";+}++function postReframe() {+ var s = getCookie("haddock-reframe");+ if (s) {+ parent.window.main.location = s;+ clearCookie("haddock-reframe");+ }+}++function styles() {+ var i, a, es = document.getElementsByTagName("link"), rs = [];+ for (i = 0; a = es[i]; i++) {+ if(a.rel.indexOf("style") != -1 && a.title) {+ rs.push(a);+ }+ }+ return rs;+}++function addStyleMenu() {+ var as = styles();+ var i, a, btns = "";+ for(i=0; a = as[i]; i++) {+ btns += "<li><a href='#' onclick=\"setActiveStyleSheet('"+ + a.title + "'); return false;\">"+ + a.title + "</a></li>"+ }+ if (as.length > 1) {+ var h = "<div id='style-menu-holder'>"+ + "<a href='#' onclick='styleMenu(); return false;'>Style ▾</a>"+ + "<ul id='style-menu' class='hide'>" + btns + "</ul>"+ + "</div>";+ addMenuItem(h);+ }+}++function setActiveStyleSheet(title) {+ var as = styles();+ var i, a, found;+ for(i=0; a = as[i]; i++) {+ a.disabled = true;+ // need to do this always, some browsers are edge triggered+ if(a.title == title) {+ found = a;+ }+ }+ if (found) {+ found.disabled = false;+ setCookie("haddock-style", title);+ }+ else {+ as[0].disabled = false;+ clearCookie("haddock-style");+ }+ styleMenu(false);+}++function resetStyle() {+ var s = getCookie("haddock-style");+ if (s) setActiveStyleSheet(s);+}+++function styleMenu(show) {+ var m = document.getElementById('style-menu');+ if (m) toggleShow(m, show);+}+++function pageLoad() {+ addStyleMenu();+ adjustForFrames();+ resetStyle();+}+
− html/haddock.css
@@ -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;-}--/* <TT> font is a little too small in MSIE */-TT { font-size: 100%; }-PRE { font-size: 100%; }--LI P { margin: 0pt } --TD {- border-width: 0px;-}--TABLE.narrow {- border-width: 0px;-}--TD.s8 { height: 8px; }-TD.s15 { height: 15px; }--SPAN.keyword { text-decoration: underline; }--/* Resize the buttom image to match the text size */-IMG.coll { width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em }--/* --------- Contents page ---------- */--DIV.node {- padding-left: 3em;-}--DIV.cnode {- padding-left: 1.75em;-}--SPAN.pkg {- position: absolute;- left: 50em;-}--/* --------- Documentation elements ---------- */--TD.children {- padding-left: 25px;- }--TD.synopsis {- padding: 2px;- background-color: #f0f0f0;- font-family: monospace- }--TD.decl { - padding: 2px;- background-color: #f0f0f0; - font-family: monospace;- vertical-align: top;- }--TD.topdecl {- padding: 2px;- background-color: #f0f0f0;- font-family: monospace;- vertical-align: top;-}--TABLE.declbar {- border-spacing: 0px;- }--TD.declname {- width: 100%;- }--TD.declbut {- padding-left: 5px;- padding-right: 5px;- border-left-width: 1px;- border-left-color: #000099;- border-left-style: solid;- white-space: nowrap;- font-size: small;- }--/* - arg is just like decl, except that wrapping is not allowed. It is- used for function and constructor arguments which have a text box- to the right, where if wrapping is allowed the text box squashes up- the declaration by wrapping it.-*/-TD.arg { - padding: 2px;- background-color: #f0f0f0; - font-family: monospace;- vertical-align: top;- white-space: nowrap;- }--TD.recfield { padding-left: 20px }--TD.doc { - padding-top: 2px;- padding-left: 10px;- }--TD.ndoc { - padding: 2px;- }--TD.rdoc { - padding: 2px;- padding-left: 10px;- width: 100%;- }--TD.body { - padding-left: 10px- }--TD.pkg {- width: 100%;- padding-left: 10px-}--TABLE.indexsearch TR.indexrow {- display: none;-}-TABLE.indexsearch TR.indexshow {- display: table-row;-}--TD.indexentry {- vertical-align: top;- padding-right: 10px- }--TD.indexannot {- vertical-align: top;- padding-left: 20px;- white-space: nowrap- }--TD.indexlinks {- width: 100%- }--/* ------- Section Headings ------- */--TD.section1 {- padding-top: 15px;- font-weight: bold;- font-size: 150%- }--TD.section2 {- padding-top: 10px;- font-weight: bold;- font-size: 130%- }--TD.section3 {- padding-top: 5px;- font-weight: bold;- font-size: 110%- }--TD.section4 {- font-weight: bold;- font-size: 100%- }--/* -------------- The title bar at the top of the page */--TD.infohead {- color: #ffffff;- font-weight: bold;- padding-right: 10px;- text-align: left;-}--TD.infoval {- color: #ffffff;- padding-right: 10px;- text-align: left;-}--TD.topbar {- background-color: #000099;- padding: 5px;-}--TD.title {- color: #ffffff;- padding-left: 10px;- width: 100%- }--TD.topbut {- padding-left: 5px;- padding-right: 5px;- border-left-width: 1px;- border-left-color: #ffffff;- border-left-style: solid;- white-space: nowrap;- }--TD.topbut A:link {- color: #ffffff- }--TD.topbut A:visited {- color: #ffff00- }--TD.topbut A:hover {- background-color: #6060ff;- }--TD.topbut:hover {- background-color: #6060ff- }--TD.modulebar { - background-color: #0077dd;- padding: 5px;- border-top-width: 1px;- border-top-color: #ffffff;- border-top-style: solid;- }--/* --------- The page footer --------- */--TD.botbar {- background-color: #000099;- color: #ffffff;- padding: 5px- }-TD.botbar A:link {- color: #ffffff;- text-decoration: underline- }-TD.botbar A:visited {- color: #ffff00- }-TD.botbar A:hover {- background-color: #6060ff- }--/* --------- Mini Synopsis for Frame View --------- */--.outer {- margin: 0 0;- padding: 0 0;-}--.mini-synopsis {- padding: 0.25em 0.25em;-}--.mini-synopsis H1 { font-size: 130%; }-.mini-synopsis H2 { font-size: 110%; }-.mini-synopsis H3 { font-size: 100%; }-.mini-synopsis H1, .mini-synopsis H2, .mini-synopsis H3 {- margin-top: 0.5em;- margin-bottom: 0.25em;- padding: 0 0;-}--.mini-synopsis H1 { border-bottom: 1px solid #ccc; }--.mini-topbar {- font-size: 130%;- background: #0077dd;- padding: 0.25em;-}--
− html/haskell_icon.gif
binary file changed (911 → absent bytes)
− html/minus.gif
binary file changed (56 → absent bytes)
− html/plus.gif
binary file changed (59 → absent bytes)
+ latex/haddock.sty view
@@ -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}
src/Documentation/Haddock.hs view
@@ -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+
− src/Haddock/Backends/DevHelp.hs
@@ -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 "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$- (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>- text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$- text "<chapters>" $$- nest 4 (ppModuleTree [] tree) $+$- text "</chapters>" $$- text "<functions>" $$- nest 4 (ppList index) $+$- text "</functions>" $$- text "</book>"- writeFile (pathJoin [odir, devHelpFile]) (render doc)- where - package = fromMaybe "pkg" maybe_package-- ppModuleTree :: [String] -> [ModuleTree] -> Doc- ppModuleTree ss [x] = ppNode ss x- ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs- ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"-- ppNode :: [String] -> ModuleTree -> Doc- ppNode ss (Node s leaf _ _short ts) =- case ts of- [] -> text "<sub"<+>ppAttribs<>text "/>"- _ -> - text "<sub"<+>ppAttribs<>text ">" $$- nest 4 (ppModuleTree (s:ss) ts) $+$- text "</sub>"- where- ppLink | leaf = text (moduleHtmlFile (mkModule (stringToPackageId "") - (mkModuleName mdl)))- | otherwise = empty-- ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink-- mdl = foldr (++) "" (s' : map ('.':) ss')- (s':ss') = reverse (s:ss)- -- reconstruct the module name-- index :: [(Name, [Module])]- index = Map.toAscList (foldr getModuleIndex Map.empty ifaces)-- getModuleIndex iface fm =- Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | name <- ifaceExports iface, nameModule name == mdl]) fm- where mdl = ifaceMod iface-- ppList :: [(Name, [Module])] -> Doc- ppList [] = empty- ppList ((name,refs):mdls) =- ppReference name refs $$- ppList mdls-- ppReference :: Name -> [Module] -> Doc- ppReference _ [] = empty- ppReference name (mdl:refs) = - text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$- ppReference name refs
− src/Haddock/Backends/HH.hs
@@ -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 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$- text "<HTML>" $$- text "<HEAD>" $$- text "<META name=\"GENERATOR\" content=\"Haddock\">" $$- text "<!-- Sitemap 1.0 -->" $$- text "</HEAD><BODY>" $$- ppModuleTree tree $$- text "</BODY><HTML>"- writeFile (pathJoin [odir, contentsHHFile]) (render html)- where- package = fromMaybe "pkg" maybe_package- - ppModuleTree :: [ModuleTree] -> Doc- ppModuleTree ts =- text "<OBJECT type=\"text/site properties\">" $$- text "<PARAM name=\"FrameName\" value=\"main\">" $$- text "</OBJECT>" $$- text "<UL>" $+$- nest 4 (text "<LI>" <> nest 4- (text "<OBJECT type=\"text/sitemap\">" $$- nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$- text "<PARAM name=\"Local\" value=\"index.html\">") $$- text "</OBJECT>") $+$- text "</LI>" $$- text "<UL>" $+$- nest 4 (fn [] ts) $+$- text "</UL>") $+$- text "</UL>"-- fn :: [String] -> [ModuleTree] -> Doc- fn ss [x] = ppNode ss x- fn ss (x:xs) = ppNode ss x $$ fn ss xs- fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"-- ppNode :: [String] -> ModuleTree -> Doc- ppNode ss (Node s leaf _pkg _ []) =- ppLeaf s ss leaf- ppNode ss (Node s leaf _pkg _ ts) =- ppLeaf s ss leaf $$- text "<UL>" $+$- nest 4 (fn (s:ss) ts) $+$- text "</UL>"-- ppLeaf s ss isleaf =- text "<LI>" <> nest 4- (text "<OBJECT type=\"text/sitemap\">" $$- text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$- (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile mdl) <> text "\">" else empty) $$- text "</OBJECT>") $+$- text "</LI>"- where - mdl = foldr (++) "" (s' : map ('.':) ss')- (s':ss') = reverse (s:ss)- -- reconstruct the module name- ---------------------------------ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO ()-ppHHIndex odir maybe_package ifaces = do- let indexHHFile = package++".hhk"- - html = - text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$- text "<HTML>" $$- text "<HEAD>" $$- text "<META name=\"GENERATOR\" content=\"Haddock\">" $$- text "<!-- Sitemap 1.0 -->" $$- text "</HEAD><BODY>" $$- text "<UL>" $+$- nest 4 (ppList index) $+$- text "</UL>" $$- text "</BODY><HTML>"- writeFile (pathJoin [odir, indexHHFile]) (render html)- where- package = fromMaybe "pkg" maybe_package- - index :: [(HsName, [Module])]- index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)-- getIfaceIndex iface fm =- foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']- where mdl = iface_module iface- - ppList [] = empty- ppList ((name,refs):mdls) =- text "<LI>" <> nest 4- (text "<OBJECT type=\"text/sitemap\">" $$- text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$- ppReference name refs $$- text "</OBJECT>") $+$- text "</LI>" $$- ppList mdls-- ppReference name [] = empty- ppReference name (Module mdl:refs) =- text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef mdl name) <> text "\">" $$- ppReference name refs---ppHHProject :: FilePath -> String -> Maybe String -> [Interface] -> [FilePath] -> IO ()-ppHHProject odir doctitle maybe_package ifaces pkg_paths = do- let projectHHFile = package++".hhp"- doc =- text "[OPTIONS]" $$- text "Compatibility=1.1 or later" $$- text "Compiled file=" <> text package <> text ".chm" $$- text "Contents file=" <> text package <> text ".hhc" $$- text "Default topic=" <> text contentsHtmlFile $$- text "Display compile progress=No" $$- text "Index file=" <> text package <> text ".hhk" $$- text "Title=" <> text doctitle $$- space $$- text "[FILES]" $$- ppMods ifaces $$- text contentsHtmlFile $$- text indexHtmlFile $$- ppIndexFiles chars $$- ppLibFiles ("":pkg_paths)- writeFile (pathJoin [odir, projectHHFile]) (render doc)- where- package = fromMaybe "pkg" maybe_package- - ppMods [] = empty- ppMods (iface:ifaces) =- let Module mdl = iface_module iface in- text (moduleHtmlFile mdl) $$- ppMods ifaces- - ppIndexFiles [] = empty- ppIndexFiles (c:cs) =- text (subIndexHtmlFile c) $$- ppIndexFiles cs- - ppLibFiles [] = empty- ppLibFiles (path:paths) =- ppLibFile cssFile $$- ppLibFile iconFile $$- ppLibFile jsFile $$- ppLibFile plusFile $$- ppLibFile minusFile $$- ppLibFiles paths- where- toPath fname | null path = fname- | otherwise = pathJoin [path, fname]- ppLibFile fname = text (toPath fname)-- chars :: [Char]- chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))-- getIfaceIndex iface fm =- Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm- where mdl = iface_module iface--}
− src/Haddock/Backends/HH2.hs
@@ -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 "<?xml version=\"1.0\"?>" $$- text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$- text "<HelpTOC DTDVersion=\"1.0\">" $$- nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$- nest 4 (ppModuleTree [] tree) $+$- text "</HelpTOCNode>") $$- text "</HelpTOC>"- writeFile (pathJoin [odir, contentsHH2File]) (render doc)- where- package = fromMaybe "pkg" maybe_package- - ppModuleTree :: [String] -> [ModuleTree] -> Doc- ppModuleTree ss [x] = ppNode ss x- ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs- ppModuleTree _ [] = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given"-- ppNode :: [String] -> ModuleTree -> Doc- ppNode ss (Node s leaf _pkg _short []) =- text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text "/>"- ppNode ss (Node s leaf _pkg _short ts) =- text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text ">" $$- nest 4 (ppModuleTree (s:ss) ts) $+$- text "</HelpTOCNode>"- - ppAttributes :: Bool -> [String] -> Doc- ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl]- where- mdl = foldr (++) "" (s' : map ('.':) ss')- (s':ss') = reverse ss- -- reconstruct the module name- - ppId = text "Id=" <> doubleQuotes (text mdl)- - ppTitle = text "Title=" <> doubleQuotes (text (head ss))- - ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl))- | otherwise = empty---------------------------------------------------------------------------------------ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO ()-ppHH2Index odir maybe_package ifaces = do- let - indexKHH2File = package++"K.HxK"- indexNHH2File = package++"N.HxK"- docK = - text "<?xml version=\"1.0\"?>" $$- text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$- text "<HelpIndex DTDVersion=\"1.0\" Name=\"K\">" $$- nest 4 (ppList index) $+$- text "</HelpIndex>" - docN = - text "<?xml version=\"1.0\"?>" $$- text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$- text "<HelpIndex DTDVersion=\"1.0\" Name=\"NamedURLIndex\">" $$- text "<Keyword Term=\"HomePage\">" $$- nest 4 (text "<Jump Url=\""<>text contentsHtmlFile<>text "\"/>") $$- text "</Keyword>" $$- text "</HelpIndex>"- writeFile (pathJoin [odir, indexKHH2File]) (render docK)- writeFile (pathJoin [odir, indexNHH2File]) (render docN)- where- package = fromMaybe "pkg" maybe_package- - index :: [(HsName, [Module])]- index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces)-- getIfaceIndex iface fm =- Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm- where mdl = iface_module iface- - ppList [] = empty- ppList ((name,mdls):vs) =- text "<Keyword Term=\"" <> text (escapeStr (show name)) <> text "\">" $$- nest 4 (vcat (map (ppJump name) mdls)) $$- text "</Keyword>" $$- ppList vs-- ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef mdl name) <> text "\"/>"----------------------------------------------------------------------------------------ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()-ppHH2Files odir maybe_package ifaces pkg_paths = do- let filesHH2File = package++".HxF"- doc =- text "<?xml version=\"1.0\"?>" $$- text "<!DOCTYPE HelpFileList SYSTEM \"ms-help://hx/resources/HelpFileList.DTD\">" $$- text "<HelpFileList DTDVersion=\"1.0\">" $$- nest 4 (ppMods ifaces $$- text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$- text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$- ppIndexFiles chars $$- ppLibFiles ("":pkg_paths)) $$- text "</HelpFileList>"- writeFile (pathJoin [odir, filesHH2File]) (render doc)- where- package = fromMaybe "pkg" maybe_package- - ppMods [] = empty- ppMods (iface:ifaces) =- text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$- ppMods ifaces- where Module mdl = iface_module iface- - ppIndexFiles [] = empty- ppIndexFiles (c:cs) =- text "<File Url=\""<>text (subIndexHtmlFile c)<>text "\"/>" $$- ppIndexFiles cs- - ppLibFiles [] = empty- ppLibFiles (path:paths) = - ppLibFile cssFile $$- ppLibFile iconFile $$- ppLibFile jsFile $$- ppLibFile plusFile $$- ppLibFile minusFile $$- ppLibFiles paths- where- toPath fname | null path = fname- | otherwise = pathJoin [path, fname]- ppLibFile fname = text "<File Url=\""<>text (toPath fname)<>text "\"/>"-- chars :: [Char]- chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces))-- getIfaceIndex iface fm =- Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm- where mdl = iface_module iface---------------------------------------------------------------------------------------ppHH2Collection :: FilePath -> String -> Maybe String -> IO ()-ppHH2Collection odir doctitle maybe_package = do- let - package = fromMaybe "pkg" maybe_package- collectionHH2File = package++".HxC"- - doc =- text "<?xml version=\"1.0\"?>" $$- text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$- text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$- nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$- nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$- text "</CompilerOptions>" $$- text "<TOCDef File=\"" <> text package <> text ".HxT\"/>" $$- text "<KeywordIndexDef File=\"" <> text package <> text "K.HxK\"/>" $$- text "<KeywordIndexDef File=\"" <> text package <> text "N.HxK\"/>" $$- text "<ItemMoniker Name=\"!DefaultToc\" ProgId=\"HxDs.HxHierarchy\" InitData=\"\"/>" $$- text "<ItemMoniker Name=\"!DefaultFullTextSearch\" ProgId=\"HxDs.HxFullTextSearch\" InitData=\"\"/>" $$- text "<ItemMoniker Name=\"!DefaultAssociativeIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"A\"/>" $$- text "<ItemMoniker Name=\"!DefaultKeywordIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"K\"/>" $$- text "<ItemMoniker Name=\"!DefaultNamedUrlIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"NamedURLIndex\"/>" $$- text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$- text "</HelpCollection>"- writeFile (pathJoin [odir, collectionHH2File]) (render doc)--}
src/Haddock/Backends/HaddockDB.hs view
@@ -8,7 +8,6 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------ module Haddock.Backends.HaddockDB (ppDocBook) where {-
src/Haddock/Backends/Hoogle.hs view
@@ -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) }
− src/Haddock/Backends/Html.hs
@@ -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 <P> (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 <P>..</P>--- can add too much whitespace in some browsers (eg. IE). However if--- we have multiple paragraphs, then we want the extra whitespace to--- separate them. So we catch the single paragraph case and transform it--- here.-unParagraph :: 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"]
+ src/Haddock/Backends/LaTeX.hs view
@@ -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
+ src/Haddock/Backends/Xhtml.hs view
@@ -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 <![CDATA[ section. Will break if the miniPage name could+ -- have "]]>" in it!+ << primHtml (+ "//<![CDATA[\nwindow.onload = function () {pageLoad();"+ ++ setSynopsis ++ "};\n//]]>\n")+ ]+ where+ setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage+++srcButton :: SourceURLs -> Maybe Interface -> Maybe Html+srcButton (Just src_base_url, _, _) Nothing =+ Just (anchor ! [href src_base_url] << "Source")+srcButton (_, Just src_module_url, _) (Just iface) =+ let url = spliceURL (Just $ ifaceOrigFilename iface)+ (Just $ ifaceMod iface) Nothing Nothing src_module_url+ in Just (anchor ! [href url] << "Source")+srcButton _ _ =+ Nothing+++wikiButton :: WikiURLs -> Maybe Module -> Maybe Html+wikiButton (Just wiki_base_url, _, _) Nothing =+ Just (anchor ! [href wiki_base_url] << "User Comments")++wikiButton (_, Just wiki_module_url, _) (Just mdl) =+ let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url+ in Just (anchor ! [href url] << "User Comments")++wikiButton _ _ =+ Nothing+++contentsButton :: Maybe String -> Maybe Html+contentsButton maybe_contents_url+ = Just (anchor ! [href url] << "Contents")+ where url = 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++
+ src/Haddock/Backends/Xhtml/Decl.hs view
@@ -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]++
+ src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -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 <P> (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 <P>..</P>+ -- can add too much whitespace in some browsers (eg. IE). However if+ -- we have multiple paragraphs, then we want the extra whitespace to+ -- separate them. So we catch the single paragraph case and transform it+ -- here. We don't do this in code blocks as it eliminates line breaks.+ unParagraph :: Doc a -> Doc a+ unParagraph (DocParagraph d) = d+ unParagraph doc = doc++ fmtUnParagraphLists :: DocMarkup a (Doc a)+ fmtUnParagraphLists = idMarkup {+ markupUnorderedList = DocUnorderedList . map unParagraph,+ markupOrderedList = DocOrderedList . map unParagraph+ }
+ src/Haddock/Backends/Xhtml/Layout.hs view
@@ -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)+
+ src/Haddock/Backends/Xhtml/Names.hs view
@@ -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.
+ src/Haddock/Backends/Xhtml/Themes.hs view
@@ -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+
+ src/Haddock/Backends/Xhtml/Types.hs view
@@ -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)
+ src/Haddock/Backends/Xhtml/Utils.hs view
@@ -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
src/Haddock/Convert.hs view
@@ -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])
src/Haddock/Doc.hs view
@@ -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
src/Haddock/GhcUtils.hs view
@@ -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+
src/Haddock/Interface.hs view
@@ -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)+
src/Haddock/Interface/AttachInstances.hs view
@@ -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
src/Haddock/Interface/Create.hs view
@@ -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 []
src/Haddock/Interface/ExtractFnArgDocs.hs view
@@ -8,7 +8,6 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------ module Haddock.Interface.ExtractFnArgDocs ( getDeclFnArgDocs, getSigFnArgDocs, getTypeFnArgDocs ) where
src/Haddock/Interface/LexParseRn.hs view
@@ -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
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -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,
src/Haddock/Interface/Rename.hs view
@@ -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)
src/Haddock/Interface/Rn.hs view
@@ -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)
src/Haddock/InterfaceFile.hs view
@@ -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
src/Haddock/Lex.x view
@@ -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 <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 | <eof>) { token TokPara `andBegin` para}@@ -66,11 +72,21 @@ <birdtrack> .* \n? { strtokenNL TokBirdTrack `andBegin` line } +<example> {+ $ws* \n { token TokPara `andBegin` para }+ $ws* \>\>\> { strtoken TokExamplePrompt `andBegin` exampleexpr }+ () { begin exampleresult }+}++<exampleexpr> .* \n { strtokenNL TokExampleExpression `andBegin` example }++<exampleresult> .* \n { strtokenNL TokExampleResult `andBegin` example }+ <string,def> { $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]
src/Haddock/ModuleTree.hs view
@@ -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]
src/Haddock/Options.hs view
@@ -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)+
src/Haddock/Parse.y view
@@ -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 }
src/Haddock/Types.hs view
@@ -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) ->
src/Haddock/Utils.hs view
@@ -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
− src/Haddock/Utils/BlockTable.hs
@@ -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 <andy@galconn.com>- Stability : experimental- Portability : portable-- $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $-- An Html combinator library---}--module Haddock.Utils.BlockTable (---- Datatypes:-- BlockTable, -- abstract---- Contruction Functions: -- single,- empty,- above,- beside,---- Investigation Functions: -- getMatrix,- showsTable,- showTable,-- ) where--import Prelude--infixr 4 `beside`-infixr 3 `above`---- These combinators can be used to build formated 2D tables.--- The specific target useage is for HTML table generation.--{-- Examples of use:-- > table1 :: BlockTable String- > table1 = single "Hello" +-----+- |Hello|- This is a 1x1 cell +-----+- Note: single has type- - single :: a -> BlockTable a- - So the cells can contain anything.- - > table2 :: BlockTable String- > table2 = single "World" +-----+- |World|- +-----+--- > table3 :: BlockTable String- > table3 = table1 %-% table2 +-----%-----+- |Hello%World|- % is used to indicate +-----%-----+- the join edge between- the two Tables. -- > table4 :: BlockTable String- > table4 = table3 %/% table2 +-----+-----+- |Hello|World|- Notice the padding on the %%%%%%%%%%%%%- smaller (bottom) cell to |World |- force the table to be a +-----------+- rectangle.-- > table5 :: BlockTable String- > table5 = table1 %-% table4 +-----%-----+-----+- |Hello%Hello|World|- Notice the padding on the | %-----+-----+- leftmost cell, again to | %World |- force the table to be a +-----%-----------+- rectangle.- - Now the table can be rendered with processTable, for example:- Main> processTable table5- [[("Hello",(1,2)),- ("Hello",(1,1)),- ("World",(1,1))],- [("World",(2,1))]] :: [[([Char],(Int,Int))]]- Main> --}---- ------------------------------------------------------------------------------ Contruction Functions---- Perhaps one day I'll write the Show instance--- to show boxes aka the above ascii renditions.--instance (Show a) => Show (BlockTable a) where- showsPrec _ = showsTable--type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]]--data BlockTable a = Table (Int -> Int -> TableI a) Int Int----- You can create a (1x1) table entry--single :: a -> BlockTable a-single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1--empty :: BlockTable a-empty = Table (\ _ _ r -> r) 0 0----- You can compose tables, horizonally and vertically--above :: BlockTable a -> BlockTable a -> BlockTable a-beside :: BlockTable a -> BlockTable a -> BlockTable a--t1 `above` t2 = trans (combine (trans t1) (trans t2) (.))--t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r ->- let- -- Note this depends on the fact that- -- that the result has the same number- -- of lines as the y dimention; one list- -- per line. This is not true in general- -- but is always true for these combinators.- -- I should assert this!- -- I should even prove this.- beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys- beside' (x:xs) [] = x : xs ++ r- beside' [] (y:ys) = y : ys ++ r- beside' [] [] = r- in- beside' (lst1 []) (lst2 []))---- trans flips (transposes) over the x and y axis of--- the table. It is only used internally, and typically--- in pairs, ie. (flip ... munge ... (un)flip).--trans :: BlockTable a -> BlockTable a-trans (Table f1 x1 y1) = Table (flip f1) y1 x1--combine :: BlockTable a - -> BlockTable b - -> (TableI a -> TableI b -> TableI c) - -> BlockTable c-combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y- where- max_y = max y1 y2- new_fn x y =- case compare y1 y2 of- EQ -> comb (f1 0 y) (f2 x y)- GT -> comb (f1 0 y) (f2 x (y + y1 - y2))- LT -> comb (f1 0 (y + y2 - y1)) (f2 x y)---- ------------------------------------------------------------------------------ Investigation Functions---- This is the other thing you can do with a Table;--- turn it into a 2D list, tagged with the (x,y)--- sizes of each cell in the table.--getMatrix :: BlockTable a -> [[(a,(Int,Int))]]-getMatrix (Table r _ _) = r 0 0 []---- You can also look at a table--showsTable :: (Show a) => BlockTable a -> ShowS-showsTable table = shows (getMatrix table)--showTable :: (Show a) => BlockTable a -> String-showTable table = showsTable table ""
− src/Haddock/Utils/Html.hs
@@ -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 <andy@galconn.com>--- Stability : experimental--- Portability : portable------ An Html combinator library-----------------------------------------------------------------------------------module Haddock.Utils.Html (- module Haddock.Utils.Html,- ) where--import qualified Haddock.Utils.BlockTable as BT--import Data.Char (isAscii, ord)-import Numeric (showHex)--infixr 2 +++ -- combining Html-infixr 7 << -- nesting Html-infixl 8 ! -- adding optional arguments----- A important property of Html is that all strings inside the--- structure are already in Html friendly format.--- For example, use of >,etc.--data HtmlElement-{-- - ..just..plain..normal..text... but using © and &amb;, etc.- -}- = HtmlString String-{-- - <thetag {..attrs..}> ..content.. </thetag>- -}- | HtmlTag { -- tag with internal markup- markupTag :: String,- markupAttrs :: [HtmlAttr],- markupContent :: Html- }--{- These are the index-value pairs.- - The empty string is a synonym for tags with no arguments.- - (not strictly HTML, but anyway).- -}---data HtmlAttr = HtmlAttr String String---newtype Html = Html { getHtmlElements :: [HtmlElement] }---- Read MARKUP as the class of things that can be validly rendered--- inside MARKUP tag brackets. So this can be one or more Html's,--- or a String, for example.--class HTML a where- toHtml :: a -> Html- toHtmlFromList :: [a] -> Html-- toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs])--instance HTML Html where- toHtml a = a--instance HTML Char where- toHtml a = toHtml [a]- toHtmlFromList [] = Html []- toHtmlFromList str = Html [HtmlString (stringToHtmlString str)]--instance (HTML a) => HTML [a] where- toHtml xs = toHtmlFromList xs--class ADDATTRS a where- (!) :: a -> [HtmlAttr] -> a--instance (ADDATTRS b) => ADDATTRS (a -> b) where- (!) fn attr = \ arg -> fn arg ! attr--instance ADDATTRS Html where- (!) (Html htmls) attr = Html (map addAttrs htmls)- where- addAttrs html =- case html of- HtmlTag { markupAttrs = markupAttrs0- , markupTag = markupTag0- , markupContent = markupContent0 } ->- HtmlTag { markupAttrs = markupAttrs0 ++ attr- , markupTag = markupTag0- , markupContent = markupContent0 }- _ -> html---(<<) :: (HTML a) => (Html -> b) -> a -> b-fn << arg = fn (toHtml arg)---concatHtml :: (HTML a) => [a] -> Html-concatHtml as = Html (concat (map (getHtmlElements.toHtml) as))--(+++) :: (HTML a,HTML b) => a -> b -> Html-a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b))--noHtml :: Html-noHtml = Html []---isNoHtml :: Html -> Bool-isNoHtml (Html xs) = null xs---tag :: String -> Html -> Html-tag str htmls =- Html [ HtmlTag { markupTag = str,- markupAttrs = [],- markupContent = htmls }- ]--itag :: String -> Html-itag str = tag str noHtml--emptyAttr :: String -> HtmlAttr-emptyAttr s = HtmlAttr s ""--intAttr :: String -> Int -> HtmlAttr-intAttr s i = HtmlAttr s (show i)--strAttr :: String -> String -> HtmlAttr-strAttr s t = HtmlAttr s t---{--foldHtml :: (String -> [HtmlAttr] -> [a] -> a) - -> (String -> a)- -> Html- -> a-foldHtml f g (HtmlTag str attr fmls) - = f str attr (map (foldHtml f g) fmls) -foldHtml f g (HtmlString str) - = g str---}--- Processing Strings into Html friendly things.--- This converts a String to a Html String.-stringToHtmlString :: String -> String-stringToHtmlString = concatMap fixChar- where- fixChar '<' = "<"- 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"] << ("</" ++ markupTag0 ++ ">")---- ------------------------------------------------------------------------------ Hotlink datatype--data HotLink = HotLink {- hotLinkURL :: URL,- hotLinkContents :: [Html],- hotLinkAttributes :: [HtmlAttr]- } deriving Show--instance HTML HotLink where- toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl)- << hotLinkContents hl--hotlink :: URL -> [Html] -> HotLink-hotlink url h = HotLink {- hotLinkURL = url,- hotLinkContents = h,- hotLinkAttributes = [] }----- ------------------------------------------------------------------------------ More Combinators---- (Abridged from Erik Meijer's Original Html library)--ordList :: (HTML a) => [a] -> Html-ordList items = olist << map (li <<) items--unordList :: (HTML a) => [a] -> Html-unordList items = ulist << map (li <<) items--defList :: (HTML a,HTML b) => [(a,b)] -> Html-defList items- = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ]---widget :: String -> String -> [HtmlAttr] -> Html-widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0)--checkbox :: String -> String -> Html-hidden :: String -> String -> Html-radio :: String -> String -> Html-reset :: String -> String -> Html-submit :: String -> String -> Html-password :: String -> Html-textfield :: String -> Html-afile :: String -> Html-clickmap :: String -> Html--checkbox n v = widget "CHECKBOX" n [value v]-hidden n v = widget "HIDDEN" n [value v]-radio n v = widget "RADIO" n [value v]-reset n v = widget "RESET" n [value v]-submit n v = widget "SUBMIT" n [value v]-password n = widget "PASSWORD" n []-textfield n = widget "TEXT" n []-afile n = widget "FILE" n []-clickmap n = widget "IMAGE" n []--menu :: String -> [Html] -> Html-menu n choices- = select ! [name n] << [ option << p << choice | choice <- choices ]--gui :: String -> Html -> Html-gui act = form ! [action act,method "POST"]---- ------------------------------------------------------------------------------ Html Rendering- --- Uses the append trick to optimize appending.--- The output is quite messy, because space matters in--- HTML, so we must not generate needless spaces.--renderHtml :: (HTML html) => html -> String-renderHtml theHtml =- renderMessage ++ - foldr (.) id (map unprettyHtml- (getHtmlElements (tag "HTML" << theHtml))) "\n"--renderMessage :: String-renderMessage =- "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++- "<!--Rendered using the Haskell Html Library v0.2-->\n"--unprettyHtml :: HtmlElement -> ShowS-unprettyHtml (HtmlString str) = (++) str-unprettyHtml (HtmlTag- { markupTag = name0,- markupContent = html,- markupAttrs = markupAttrs0 })- = if isNoHtml html && elem name0 validHtmlITags- then renderTag True name0 markupAttrs0 0- else (renderTag True name0 markupAttrs0 0- . foldr (.) id (map unprettyHtml (getHtmlElements html))- . renderTag False name0 [] 0)---- Local Utilities-prettyHtml :: (HTML html) => html -> String-prettyHtml theHtml = - unlines- $ concat- $ map prettyHtml'- $ getHtmlElements- $ toHtml theHtml--prettyHtml' :: HtmlElement -> [String]-prettyHtml' (HtmlString str) = [str]-prettyHtml' (HtmlTag- { markupTag = name0,- markupContent = html,- markupAttrs = markupAttrs0 })- = if isNoHtml html && elem name0 validHtmlITags- then - [rmNL (renderTag True name0 markupAttrs0 0 "")]- else- [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ - shift (concat (map prettyHtml' (getHtmlElements html))) ++- [rmNL (renderTag False name0 [] 0 "")]- where- shift = map (\x -> " " ++ x)--rmNL :: [Char] -> [Char]-rmNL = filter (/= '\n')---- This prints the Tags The lack of spaces in intentunal, because Html is--- actually space dependant.--renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS-renderTag x name0 markupAttrs0 n r- = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r- where- open = if x then "<" else "</"- - nl = "\n" ++ replicate (n `div` 8) '\t' - ++ replicate (n `mod` 8) ' '-- rest [] = nl- rest attr = " " ++ unwords (map showPair attr) ++ nl-- showPair :: HtmlAttr -> String- showPair (HtmlAttr tag0 val)- = tag0 ++ "=\"" ++ val ++ "\""-
src/Haddock/Version.hs view
@@ -8,7 +8,6 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------ module Haddock.Version ( projectName, projectVersion, projectUrl ) where
src/Main.hs view
@@ -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