mapf xs is the list obtained by applying f to each element
+ of xs, i.e.,
+
map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]
+ map f [x1, x2, ...] == [f x1, f x2, ...]
+
classMonad m where
The Monad class defines the basic operations over a monad,
+a concept from a branch of mathematics known as category theory.
+From the perspective of a Haskell programmer, however, it is best to
+think of a monad as an abstract datatype of actions.
+Haskell's do expressions provide a convenient syntax for writing
+monadic expressions.
+
Instances of Monad should satisfy the following laws:
+
return a >>= k == k a
+ m >>= return == m
+ m >>= (\x -> k x >>= h) == (m >>= k) >>= h
+
Instances of both Monad and Functor should additionally satisfy the law:
+
fmap f xs == xs >>= return . f
+
The instances of Monad for lists, Data.Maybe.Maybe and System.IO.IO
+defined in the Prelude satisfy these laws.
+
Methods
(>>=) :: m a -> (a -> m b) -> m b
Sequentially compose two actions, passing any value produced
+ by the first as an argument to the second.
+
(>>) :: m a -> m b -> m b
Sequentially compose two actions, discarding any value produced
+ by the first, like sequencing operators (such as the semicolon)
+ in imperative languages.
+
Fail with a message. This operation is not part of the
+ mathematical definition of a monad, but is invoked on pattern-match
+ failure in a do expression.
+
The Handles are initially in binary mode; if you need them to be
+ in text mode then use hSetBinaryMode.
+
dataMVar a
An MVar (pronounced "em-var") is a synchronising variable, used
+for communication between concurrent threads. It can be thought of
+as a a box, which may be empty or full.
+
An MVar (pronounced "em-var") is a synchronising variable, used
-for communication between concurrent threads. It can be thought of
-as a a box, which may be empty or full.
-
hunk ./tests/tests/FunArgs.hs 11
+
+g :: a -- ^ First argument
+ -> b -- ^ Second argument
+ -> c -- ^ Third argument
+ -> d -- ^ Result
+g = undefined
+
hunk ./tests/tests/FunArgs.html.ref 134
+>
g
:: a
First argument
+
-> b
Second argument
+
-> c
Third argument
+
-> d
Result
+
-> T3-> (T3)= 611
+ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
hunk ./src/Haddock/Backends/Html.hs 1616
-
hunk ./src/Haddock/GhcUtils.hs 94
- = case collectAcc d [] of
+ = case collectHsBindBinders d of
hunk ./src/Haddock/GhcUtils.hs 96
- (name:_) -> Just (unLoc name)
+ (name:_) -> Just name
hunk ./src/Haddock/GhcUtils.hs 34
-import LazyUniqFM
+import UniqFM
hunk ./src/Haddock/Backends/Html.hs 1516
-ppBang HsUnbox = toHtml "!" -- unboxed args is an implementation detail,
+ppBang HsUnpack = toHtml "!" -- unboxed args is an implementation detail,
hunk ./src/Haddock/Backends/Html.hs 1518
+ppBang HsUnpackFailed = toHtml "!" -- unboxed args is an implementation detail,
hunk ./src/Haddock/Convert.hs 20
+import BasicTypes
hunk ./src/Haddock/Convert.hs 30
-import BasicTypes
hunk ./src/Haddock/Convert.hs 170
- MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
- MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
- NotMarkedStrict ->
- -- HsNoBang never appears, it's implied instead.
- tySyn
+ -- HsNoBang never appears, it's implied instead.
+ HsNoBang -> tySyn
+ _ -> noLoc $ HsBangTy strict tySyn
hunk ./src/Haddock/Convert.hs 20
-import BasicTypes
hunk ./src/Haddock/Backends/Html.hs 1515
-ppBang HsStrict = toHtml "!"
-ppBang HsUnpack = toHtml "!" -- unboxed args is an implementation detail,
- -- so we just show the strictness annotation
-ppBang HsUnpackFailed = toHtml "!" -- unboxed args is an implementation detail,
-
+ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
hunk ./src/Haddock/Convert.hs 166
- linear_tys = zipWith (\ty strict ->
+ linear_tys = zipWith (\ty bang ->
hunk ./src/Haddock/Convert.hs 168
- in case strict of
- -- HsNoBang never appears, it's implied instead.
- HsNoBang -> tySyn
- _ -> noLoc $ HsBangTy strict tySyn
+ in case bang of
+ HsUnpackFailed -> noLoc $ HsBangTy HsStrict tySyn
+ HsNoBang -> tySyn
+ -- HsNoBang never appears, it's implied instead.
+ _ -> noLoc $ HsBangTy bang tySyn
+
hunk ./ghc.mk 15
- "$(RM)" $(RM_OPTS) -r $@
+ "$(RM)" $(RM_OPTS_REC) $@
hunk ./src/Main.hs 104
+#if ! MIN_VERSION_ghc(6,13,0)
hunk ./src/Main.hs 106
+#endif
hunk ./src/Haddock/Backends/Html.hs 402
- id_s = "n:" ++ show id_
+ id_s = "n." ++ show id_
hunk ./src/Haddock/Interface/Create.hs 561
- -- *here* is that we behave reasonably when we run into one of
+ -- /here/ is that we behave reasonably when we run into one of
hunk ./haddock.cabal 134
+ Haddock.Lex
+ Haddock.Parse
hunk ./src/Documentation/Haddock.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module : Documentation.Haddock
+-- Copyright : (c) David Waern 2010
+-- License : BSD-like
hunk ./src/Documentation/Haddock.hs 7
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2003
+-- Maintainer : haddock@projects.haskellorg
+-- Stability : experimental
+-- Portability : portable
hunk ./src/Documentation/Haddock.hs 11
+-- The Haddock API: A rudimentory, highly experimental API exposing some of
+-- the internals of Haddock. Don't expect it to be stable.
+-----------------------------------------------------------------------------
hunk ./src/Documentation/Haddock.hs 17
+
+ -- * Interface
+ Interface(..),
+ InstalledInterface(..),
+ createInterfaces,
+
+ -- * Export items & declarations
+ ExportItem(..),
+ DeclInfo,
+ DocForDecl,
+ FnArgsDoc,
+
+ -- * Hyperlinking
+ LinkEnv,
+ DocName(..),
+ docNameOcc,
+
+ -- * Instances
+ DocInstance,
+ InstHead(..),
+
+ -- * Documentation comments
+ Doc(..),
+ DocMarkup(..),
+
+ -- * Interface Files
+ -- | (.haddock files)
+ InterfaceFile(..),
hunk ./src/Documentation/Haddock.hs 49
- InterfaceFile(..),
- LinkEnv,
- InstalledInterface(..),
- DocName(..),
- docNameOcc
+
+ -- * Flags and options
+ Flag(..),
+ DocOption(..)
+
hunk ./src/Documentation/Haddock.hs 58
+import Haddock.Interface
hunk ./src/Documentation/Haddock.hs 60
+import Haddock.Options
hunk ./src/Haddock/Interface.hs 43
--- | Turn a topologically sorted list of module names/filenames into interfaces. Also
--- return the home link environment created in the process.
-createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile]
- -> Ghc ([Interface], LinkEnv)
+-- | 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
hunk ./src/Haddock/Types.hs 39
+
+-- | An instance head that may have documentation.
hunk ./src/Haddock/Types.hs 57
--- | A 'DocName' identifies something that may have documentation. The 'Module'
--- argument specifies where we prefer to link to in the documentation. It may
--- be different than the original module.
-data DocName = Documented Name Module | Undocumented Name
- deriving Eq
+-- | 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)
hunk ./src/Haddock/Types.hs 63
--- | The 'OccName' belonging to this name
+-- | The 'OccName' of this name.
hunk ./src/Haddock/Types.hs 74
+-- | Source-level options for controlling the documentation.
hunk ./src/Haddock/Types.hs 139
+
+-- | An environment used to create hyper-linked syntax.
hunk ./src/Haddock/Types.hs 163
--- | This is the data structure used to render a Haddock page for a module - it
--- is the "interface" of the module. The core of Haddock lies in creating this
+-- | 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
hunk ./src/Haddock/Types.hs 169
- -- | The module represented by this interface
+ -- | The module represented by this interface.
hunk ./src/Haddock/Types.hs 172
- -- | The original filename for this module
+ -- | Original file name of the module.
hunk ./src/Haddock/Types.hs 175
- -- | Textual information about the module
+ -- | Textual information about the module.
hunk ./src/Haddock/Types.hs 178
- -- | The documentation header for this module
+ -- | Documentation header.
hunk ./src/Haddock/Types.hs 181
- -- | The renamed documentation header for this module
+ -- | Documentation header with link information.
hunk ./src/Haddock/Types.hs 184
- -- | The Haddock options for this module (prune, ignore-exports, etc)
+ -- | Haddock options for this module (prune, ignore-exports, etc).
hunk ./src/Haddock/Types.hs 187
- -- | The declarations of the module. Excludes declarations that don't
- -- have names (instances and stand-alone documentation comments). Includes
- -- subordinate names, but they are mapped to their parent declarations.
+ -- | Declarations originating from the module. Excludes declarations without
+ -- names (instances and stand-alone documentation comments). Includes
+ -- names of subordinate declarations mapped to their parent declarations.
hunk ./src/Haddock/Types.hs 192
- -- | Everything declared in the module (including subordinates) that has docs
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
hunk ./src/Haddock/Types.hs 201
- -- | All names defined in this module
+ -- | All names defined in the module.
hunk ./src/Haddock/Types.hs 204
- -- | All names exported by this module
+ -- | All names exported by the module.
hunk ./src/Haddock/Types.hs 207
- -- | All the visible names exported by this module
- -- For a name to be visible, it has to:
- --
- -- * be exported normally, and not via a full module re-exportation.
- --
- -- * have a declaration in this module or any of it's imports, with the
- -- exception that it can't be from another package.
- --
- -- Basically, a visible name is a name that will show up in the documentation
- -- for this module.
+ -- | All \"visible\" names exported by the module.
+ -- A visible name is a name that will show up in the documentation of the
+ -- module.
hunk ./src/Haddock/Types.hs 212
- -- | The instances exported by this module
+ -- | Instances exported by the module.
hunk ./src/Haddock/Types.hs 215
- -- | Docs for instances defined in this module
+ -- | Documentation of instances defined in the module.
hunk ./src/Haddock/Types.hs 220
--- | A smaller version of 'Interface' that we can get from the Haddock
--- interface files.
+-- | A smaller version of 'Interface' that can be created from Haddock's
+-- interface files ('InterfaceFile').
hunk ./src/Haddock/Types.hs 224
- -- | The module represented by this interface
+ -- | The module represented by this interface.
hunk ./src/Haddock/Types.hs 227
- -- | Textual information about the module
+ -- | Textual information about the module.
hunk ./src/Haddock/Types.hs 230
- -- | Everything declared in the module (including subordinates) that has docs
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
hunk ./src/Haddock/Types.hs 234
- -- | All names exported by this module
+ -- | All names exported by this module.
hunk ./src/Haddock/Types.hs 237
- -- | All the visible names exported by this module
- -- For a name to be visible, it has to:
- --
- -- * be exported normally, and not via a full module re-exportation.
- --
- -- * have a declaration in this module or any of it's imports, with the
- -- exception that it can't be from another package.
- --
- -- Basically, a visible name is a name that will show up in the documentation
- -- for this module.
+ -- | All \"visible\" names exported by the module.
+ -- A visible name is a name that will show up in the documentation of the
+ -- module.
hunk ./src/Haddock/Types.hs 242
- -- | The Haddock options for this module (prune, ignore-exports, etc)
+ -- | Haddock options for this module (prune, ignore-exports, etc).
hunk ./tests/runtests.hs 78
- let basepath = init libdir ++ "/../../share/doc/ghc/html/libraries/base/"
+ let basepath = init libdir ++ "/../../share/doc/ghc/html/libraries/base-4.2.0.0/"
hunk ./tests/runtests.hs 80
- let processpath = init libdir ++ "/../../share/doc/ghc/html/libraries/process/"
+ let processpath = init libdir ++ "/../../share/doc/ghc/html/libraries/process-1.0.1.2/"
hunk ./src/Haddock/Interface/Create.hs 68
- localNames = ghcDefinedNames ghcMod
hunk ./src/Haddock/Interface/Create.hs 92
- ifaceLocals = localNames,
hunk ./src/Haddock/Types.hs 201
- -- | All names defined in the module.
- ifaceLocals :: ![Name],
-
hunk ./src/Documentation/Haddock.hs 41
+ HaddockModInfo(..),
hunk ./src/Documentation/Haddock.hs 43
- -- * Interface Files
+ -- * Interface files
hunk ./tests/runtests.hs 64
- let mods = filter ((==) ".hs" . takeExtension) contents
+
+ let mods =
+ case args of
+ x:_ | x /= "all" -> [x ++ ".hs"]
+ _ -> filter ((==) ".hs" . takeExtension) contents
+
hunk ./doc/haddock.xml 19
- This document describes Haddock version 2.6.0, a Haskell
+ This document describes Haddock version 2.7.0, a Haskell
hunk ./haddock.cabal 2
-version: 2.6.0
+version: 2.7.0
hunk ./haddock.spec 20
-%define version 2.6.0
+%define version 2.7.0
hunk ./ANNOUNCE 2
--- Haddock 2.6.0
+-- Haddock 2.7.0
hunk ./ANNOUNCE 7
-This is the version that comes with GHC 6.12.1. It contains the main results of
-Isaac Dupree's Summer of Code project, which are:
-
- * Cross-package documentation (exporting something that comes from another
- package is handled correctly. The full documentation of that thing shows
- up in your documentation)
-
- * Lexing and parsing of Haddock comment markup is moved from GHC back into
- Haddock. This will make it easier to make changes to the markup format
-
-We have decided to drop compatibility with older GHC versions in order to speed
-up development.
-
hunk ./ANNOUNCE 8
--- Full list of changes in version 2.6.0
+-- Changes in version 2.7.0
hunk ./ANNOUNCE 11
- * Drop support for GHC 6.10.*
-
- * Add support for GHC 6.12.1
-
- * Cross-package documentation
-
- * Move lexing and parsing of the Haddock comment markup back to Haddock
-
- * Slightly prettier printing of instance heads
-
- * Support platforms for which GHC has no native code generator
+ * Instances can be commented
hunk ./ANNOUNCE 13
- * Add a flag --print-ghc-libdir
+ * The Haddock API now exposes more of the internals of Haddock
hunk ./ANNOUNCE 15
- * Minor bug fixes
+ * Bug fixes (most importantly #128)
hunk ./ANNOUNCE 25
- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/haddock-2.6.0
+ http://hackage.haskell.org/cgi-bin/hackage-scripts/package/haddock-2.7.0
hunk ./ANNOUNCE 43
- Ian Lynagh
- Simon Peyton-Jones
+ Yitzchak Gale
hunk ./CHANGES 1
+Changes in version 2.7.0:
+
+ * Instances can be commented
+
+ * The Haddock API now exposes more of the internals of Haddock
+
+ * Bug fixes (most importantly #128)
+
+-----------------------------------------------------------------------------
+
hunk ./haddock.cabal 2
-version: 2.7.0
+version: 2.6.0
hunk ./haddock.cabal 127
+ build-depends:
+ base >= 4.0.0.0 && < 4.3.0.0,
+ filepath,
+ directory,
+ pretty,
+ containers,
+ array,
+ Cabal >= 1.5,
+ ghc >= 6.12 && < 6.14,
+ ghc-paths
+
+ if flag(test)
+ cpp-options: -DTEST
+ build-depends: QuickCheck >= 2.1 && < 3
+
hunk ./haddock.cabal 145
+ ghc-options: -funbox-strict-fields -O2 -Wall
+
hunk ./haddock.cabal 151
+ Haddock.Interface
+ Haddock.Interface.Rename
+ Haddock.Interface.Create
+ Haddock.Interface.ExtractFnArgDocs
+ Haddock.Interface.AttachInstances
+ Haddock.Interface.Rn
+ Haddock.Interface.LexParseRn
+ Haddock.Interface.ParseModuleHeader
hunk ./haddock.cabal 161
+ Haddock.Utils.BlockTable
+ Haddock.Utils.Html
+ Haddock.Utils
+ Haddock.Backends.Html
+ Haddock.Backends.HaddockDB
+ Haddock.Backends.DevHelp
+ Haddock.Backends.HH
+ Haddock.Backends.HH2
+ Haddock.Backends.Hoogle
+ Haddock.ModuleTree
hunk ./haddock.cabal 172
+ Haddock.Doc
+ Haddock.Version
hunk ./haddock.cabal 175
- Haddock.Utils
+ Haddock.Options
hunk ./haddock.cabal 177
+ Haddock.Convert
hunk ./haddock.cabal 2
-version: 2.6.0
+version: 2.7.0
hunk ./doc/haddock.xml 19
- This document describes Haddock version 2.7.0, a Haskell
+ This document describes Haddock version 2.7.1, a Haskell
hunk ./haddock.cabal 2
-version: 2.7.0
+version: 2.7.1
hunk ./haddock.spec 20
-%define version 2.7.0
+%define version 2.7.1
hunk ./CHANGES 1
+Changes in version 2.7.1:
+
+ * Fix problems with library part of .cabal file
+
+-----------------------------------------------------------------------------
+
hunk ./haddock.cabal 178
+ Paths_haddock
hunk ./CHANGES 1
+Changes in version 2.7.2
+
+ * Add Paths_haddock to library
+
+-----------------------------------------------------------------------------
+
hunk ./doc/haddock.xml 19
- This document describes Haddock version 2.7.1, a Haskell
+ This document describes Haddock version 2.7.2, a Haskell
hunk ./haddock.cabal 2
-version: 2.7.1
+version: 2.7.2
hunk ./haddock.spec 20
-%define version 2.7.1
+%define version 2.7.2
hunk ./src/Documentation/Haddock.hs 36
- InstHead(..),
+ InstHead,
hunk ./src/Haddock/Backends/Hoogle.hs 148
- (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x))
-
- tyVar (UserTyVar v _) = v
- tyVar (KindedTyVar v _) = v
+ (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))
hunk ./src/Haddock/Backends/Hoogle.hs 191
- 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]
hunk ./src/Haddock/Backends/Html.hs 1371
+#if __GLASGOW_HASKELL__ == 612
+ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html
+#else
hunk ./src/Haddock/Backends/Html.hs 1375
+#endif
hunk ./src/Haddock/Backends/Html.hs 1584
+#if __GLASGOW_HASKELL__ == 612
+ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]
+#else
hunk ./src/Haddock/Backends/Html.hs 1588
+#endif
hunk ./src/Haddock/Backends/Html.hs 1618
+#if __GLASGOW_HASKELL__ == 612
+ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
+#else
hunk ./src/Haddock/Backends/Html.hs 1622
-ppr_mono_ty _ (HsRecTy _) _ = error "ppr_mono_ty HsRecTy"
+#endif
+ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
hunk ./src/Haddock/Convert.hs 23
+#if __GLASGOW_HASKELL__ == 612
+import Type ( splitKindFunTys )
+#else
hunk ./src/Haddock/Convert.hs 27
+#endif
hunk ./src/Haddock/Convert.hs 232
+#if __GLASGOW_HASKELL__ == 612
+ then UserTyVar name
+#else
hunk ./src/Haddock/Convert.hs 236
+#endif
hunk ./src/Haddock/GhcUtils.hs 93
-getMainDeclBinder (ValD d)
- = case collectHsBindBinders d of
- [] -> Nothing
- (name:_) -> Just 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
+
+
hunk ./tests/tests/A.html.ref 114
-> version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2 version 2.6.0 version 2.7.2= 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
hunk ./src/Haddock/GhcUtils.hs 34
+#if __GLASGOW_HASKELL__ >= 613
hunk ./src/Haddock/GhcUtils.hs 36
+#else
+import LazyUniqFM
+#endif
addfile ./tests/tests/Examples.hs
hunk ./tests/tests/Examples.hs 1
+module Examples where
+
+-- | Fibonacci number of given 'Integer'.
+--
+-- Examples:
+--
+-- ghci> fib 5
+-- 5
+-- ghci> fib 10
+-- 55
+--
+-- ghci> fib 10
+-- 55
+--
+-- One more Example:
+--
+-- ghci> fib 5
+-- 5
+--
+-- One more Example:
+--
+-- ghci> fib 5
+-- 5
+--
+-- Example with an import:
+--
+-- ghci> import Data.Char
+-- ghci> isSpace 'a'
+-- False
+--
+fib :: Integer -> Integer
+fib 0 = 0
+fib 1 = 1
+fib n = fib (n - 1) + fib (n - 2)
addfile ./tests/tests/Examples.html.ref
hunk ./tests/tests/Examples.html.ref 1
+
+
+Examples
hunk ./src/Haddock/Lex.x 57
+ $ws* ghci \> { strtoken TokExamplePrompt `andBegin` exampleexpr }
hunk ./src/Haddock/Interface.hs 95
- let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } }
- return (map addHscAsm modgraph)
+ let addDefTarget m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } }
+ return (map addDefTarget modgraph)
hunk ./src/Main.hs 144
- startGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
+ withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
hunk ./src/Main.hs 299
--- 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
hunk ./doc/haddock.xml 1412
- Additionally, the character > has
- a special meaning at the beginning of a line, and the
- following characters have special meanings at the beginning of
- a paragraph:
- *, -. These characters
- can also be escaped using \.
+ Additionally, the character > and
+ the character sequence ghci> have special
+ meanings at the beginning of a line. The following characters
+ have special meanings at the beginning of a paragraph:
+ *, -. The single
+ characters can also be escaped using \. To
+ get a literal ghci> at the beginning of a
+ line, prefix the > with a
+ backslash.
hunk ./doc/haddock.xml 1471
+
+ Interactive Examples
+
+ Haddock has markup support for interactive examples, that
+ illustrate the use of source constructs in a
+ read-eval-print loop (REPL). An
+ interactive example is introduced with
+ ghci> followed by an expression followed
+ by zero or more result lines:
+
+
+-- | Two examples are given bellow:
+--
+-- ghci> fib 10
+-- 55
+--
+-- ghci> putStrLn "foo\nbar"
+-- foo
+-- bar
+
+
+
+
hunk ./doc/haddock.xml 1412
- Additionally, the character > and
- the character sequence ghci> have special
- meanings at the beginning of a line. The following characters
- have special meanings at the beginning of a paragraph:
- *, -. The single
- characters can also be escaped using \. To
- get a literal ghci> at the beginning of a
- line, prefix the > with a
- backslash.
+ Additionally, the character > has
+ a special meaning at the beginning of a line, and the
+ following characters have special meanings at the beginning of
+ a paragraph:
+ *, -. These characters
+ can also be escaped using \.
+
+ Furthermore, the character sequence ghci>
+ has a special meaning at the beginning of a line. To
+ escape it, just prefix the > character with a
+ backslash.
hunk ./doc/haddock.xml 1474
- Interactive Examples
+ Examples
hunk ./doc/haddock.xml 1476
- Haddock has markup support for interactive examples, that
- illustrate the use of source constructs in a
- read-eval-print loop (REPL). An
- interactive example is introduced with
+ Haddock has markup support for examples of interaction with a
+ read-eval-print loop (REPL). An
+ example is introduced with
hunk ./CHANGES 1
+Changes in version 2.6.1 (bug fix release from the stable branch)
+
+ * Fix #128
+
+-----------------------------------------------------------------------------
+
addfile ./tests/parsetests.hs
hunk ./tests/parsetests.hs 1
+module Main (main) where
+
+import Test.HUnit
+import RdrName (RdrName)
+import DynFlags (defaultDynFlags)
+import Haddock.Lex (tokenise)
+import Haddock.Parse (parseParas)
+import Haddock.Types
+
+instance Show RdrName where
+ show x = "RdrName"
+
+data ParseTest = ParseTest {
+ input :: String
+ , result :: (Maybe (Doc RdrName))
+ }
+
+tests :: [ParseTest]
+tests = [
+ ParseTest {
+ input = "foobar"
+ , result = Just $ DocParagraph $ DocString "foobar\n"
+ }
+
+ , ParseTest {
+ input = "foobar\n\nghci> fib 10\n55"
+ , result = Just $ DocAppend (DocParagraph $ DocString "foobar\n") (DocExamples $ [Example "fib 10" ["55"]])
+ }
+
+ , ParseTest {
+ input = "foobar\nghci> fib 10\n55"
+ , result = Nothing -- parse error
+ }
+
+ , ParseTest {
+ input = "foobar\n\n> some code"
+ , result = Just (DocAppend (DocParagraph (DocString "foobar\n")) (DocCodeBlock (DocString " some code\n")))
+ }
+
+ , ParseTest {
+ input = "foobar\n> some code"
+ , result = Nothing -- parse error
+ }
+ ]
+
+
+main = do
+ _ <- runTestTT $ TestList $ map testFromParseTest tests
+ return ();
+ where
+
+ testFromParseTest :: ParseTest -> Test
+ testFromParseTest (ParseTest input result) = TestCase $ assertEqual input (parse input) result
+
+ parse :: String -> Maybe (Doc RdrName)
+ parse input = parseParas $ tokenise defaultDynFlags input (0,0)
addfile ./tests/runparsetests.sh
hunk ./tests/runparsetests.sh 1
+#!/bin/sh
+cd `dirname $0`
+
+runhaskell -hide-all-packages -cpp \
+ -packagecontainers \
+ -packagearray \
+ -packagebase \
+ -packageghc \
+ -packagexhtml \
+ -packageghc-paths \
+ -packageHUnit \
+ -i../dist/build/ \
+ -i../src/ \
+ parsetests.hs
hunk ./tests/README 1
-This is a little output test suit for Haddock. To add a test:
hunk ./tests/README 2
- 1 Create a module in the "tests" directory
- 2 Run runtests.hs
- You should now have output/.html but the test will always
- pass since there is no reference output to compare with
- 3 To add reference output, do
- runhaskell copy.hs
+A testsuite for Haddock that uses the concept of "golden files" (compares
+output files against a set of reference files).
hunk ./tests/README 5
-Tips:
+To add a new test:
hunk ./tests/README 7
-You can do
+ 1) Create a module in the "tests" directory.
+
+ 2) Run runtests.hs. You should now have output/.html. The test
+ passes since there is no reference file to compare with.
+
+ 3) To make a reference file from the output file, do
+ runhaskell copy.hs
+
+Tips and tricks:
+
+You can
hunk ./tests/README 19
-to copy all output into reference files
hunk ./tests/README 20
-You can do
+to copy all output files into reference files.
+
+You can
hunk ./tests/README 24
-to continue despite a failing test
+
+to continue despite a failing test.
adddir ./tests/gold
move ./tests/README ./tests/gold/README
move ./tests/copy.hs ./tests/gold/copy.hs
move ./tests/gold ./tests/golden-tests
move ./tests/output ./tests/golden-tests/output
move ./tests/runtests.hs ./tests/golden-tests/runtests.hs
move ./tests/tests ./tests/golden-tests/tests
adddir ./tests/unit
move ./tests/parsetests.hs ./tests/unit/parsetests.hs
move ./tests/runparsetests.sh ./tests/unit/runparsetests.sh
move ./tests/unit ./tests/unit-tests
hunk ./tests/golden-tests/README 2
-A testsuite for Haddock that uses the concept of "golden files" (compares
-output files against a set of reference files).
+This is a testsuite for Haddock that uses the concept of "golden files". That
+is, it compares output files against a set of reference files.
hunk ./tests/unit-tests/parsetests.hs 48
- _ <- runTestTT $ TestList $ map testFromParseTest tests
+ _ <- runTestTT $ TestList $ map toTestCase tests
hunk ./tests/unit-tests/parsetests.hs 52
- testFromParseTest :: ParseTest -> Test
- testFromParseTest (ParseTest input result) = TestCase $ assertEqual input (parse input) result
+ toTestCase :: ParseTest -> Test
+ toTestCase (ParseTest input result) = TestCase $ assertEqual input (parse input) result
hunk ./tests/unit-tests/runparsetests.sh 12
- -i../dist/build/ \
- -i../src/ \
+ -i../../dist/build/ \
+ -i../../src/ \
hunk ./src/Haddock/Convert.hs 25
+import BasicTypes
hunk ./src/Haddock/Convert.hs 174
+#if __GLASGOW_HASKELL__ >= 613
hunk ./src/Haddock/Convert.hs 179
+#else
+ MarkedStrict -> noLoc $ HsBangTy HsStrict tySyn
+ MarkedUnboxed -> noLoc $ HsBangTy HsUnbox tySyn
+ NotMarkedStrict -> tySyn
+ -- HsNoBang never appears, it's implied instead.
+#endif
hunk ./src/Haddock/Interface.hs 53
- -- part 1, create interfaces
+ -- Part 1, create interfaces
hunk ./src/Haddock/Interface.hs 59
- -- part 2, build link environment
+ -- Part 2, build link environment
hunk ./src/Haddock/Interface.hs 61
- -- combine the link envs of the external packages into one
+ -- Combine the link envs of the external packages into one
hunk ./src/Haddock/Interface.hs 63
- homeLinks = buildHomeLinks interfaces -- build the environment for the home
+ homeLinks = buildHomeLinks interfaces -- Build the environment for the home
hunk ./src/Haddock/Interface.hs 67
- -- part 3, attach instances
+ -- Part 3, attach instances
hunk ./src/Haddock/Interface.hs 71
- -- part 4, rename interfaces
+ -- Part 4, rename interfaces
hunk ./src/Haddock/Interface/Create.hs 38
--- | Process the data in the GhcModule to produce an interface.
+-- | Process the data in a GhcModule to produce an interface.
hunk ./src/Haddock/Interface/Create.hs 40
--- sort. That's what's in the module map.
-createInterface :: GhcModule -> [Flag] -> ModuleMap -> InstIfaceMap
+-- sort. That's what's in the interface map.
+createInterface :: GhcModule -> [Flag] -> IfaceMap -> InstIfaceMap
hunk ./src/Haddock/Interface/Create.hs 423
- :: ModuleMap
+ :: IfaceMap
hunk ./src/Haddock/Types.hs 136
-type ModuleMap = Map Module Interface
+type IfaceMap = Map Module Interface
hunk ./src/Documentation/Haddock.hs 14
-
-
hunk ./src/Haddock/Backends/DevHelp.hs 12
-
hunk ./src/Haddock/Backends/HH.hs 11
-
hunk ./src/Haddock/Backends/HH2.hs 11
-
hunk ./src/Haddock/Backends/HaddockDB.hs 11
-
hunk ./src/Haddock/Backends/Hoogle.hs 14
-
hunk ./src/Haddock/Convert.hs 15
-
+module Haddock.Convert where
hunk ./src/Haddock/Convert.hs 18
-module Haddock.Convert where
hunk ./src/Haddock/Doc.hs 30
+
hunk ./src/Haddock/GhcUtils.hs 16
-
hunk ./src/Haddock/Interface/AttachInstances.hs 14
-
hunk ./src/Haddock/Interface/Create.hs 12
-
hunk ./src/Haddock/Interface/ExtractFnArgDocs.hs 11
-
hunk ./src/Haddock/Interface/LexParseRn.hs 1
-
hunk ./src/Haddock/Interface/LexParseRn.hs 11
-
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 1
-
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 11
-
hunk ./src/Haddock/Interface/Rename.hs 12
-
hunk ./src/Haddock/Interface/Rn.hs 1
-
hunk ./src/Haddock/InterfaceFile.hs 14
-
hunk ./src/Haddock/ModuleTree.hs 12
-
hunk ./src/Haddock/Options.hs 14
-
-
hunk ./src/Haddock/Utils.hs 13
-
-
hunk ./src/Haddock/Version.hs 11
-
hunk ./src/Main.hs 18
-
hunk ./src/Main.hs 71
+
hunk ./src/Main.hs 334
+
hunk ./src/Main.hs 346
+
hunk ./src/Main.hs 426
+
hunk ./src/Main.hs 437
+
hunk ./src/Haddock/Convert.hs 19
+
hunk ./src/Haddock/Convert.hs 39
+
hunk ./src/Haddock/Convert.hs 73
+
hunk ./src/Haddock/Convert.hs 79
+
hunk ./src/Haddock/Convert.hs 155
+
hunk ./src/Haddock/Convert.hs 210
+
hunk ./src/Haddock/Convert.hs 214
+
hunk ./src/Haddock/Convert.hs 222
+
hunk ./src/Haddock/Convert.hs 240
+
hunk ./src/Haddock/Convert.hs 255
+
hunk ./src/Haddock/Convert.hs 271
+
hunk ./src/Haddock/Convert.hs 311
+
hunk ./src/Haddock/InterfaceFile.hs 42
+
hunk ./src/Haddock/InterfaceFile.hs 127
+
hunk ./src/Haddock/InterfaceFile.hs 149
+
hunk ./src/Haddock/InterfaceFile.hs 210
+
hunk ./src/Haddock/InterfaceFile.hs 267
+
hunk ./src/Haddock/InterfaceFile.hs 279
+
hunk ./src/Haddock/InterfaceFile.hs 282
+
hunk ./src/Haddock/InterfaceFile.hs 306
+
hunk ./src/Haddock/InterfaceFile.hs 317
--- Hmm, why didn't we dare to make this instance already? It makes things
--- much easier.
+
hunk ./src/Haddock/ModuleTree.hs 14
+
hunk ./src/Haddock/ModuleTree.hs 21
+
hunk ./src/Haddock/ModuleTree.hs 24
+
hunk ./src/Haddock/ModuleTree.hs 33
+
hunk ./src/Haddock/ModuleTree.hs 45
+
hunk ./src/Haddock/ModuleTree.hs 51
+
hunk ./src/Haddock/Utils.hs 41
- -- * Binary extras
--- FormatVersion, mkFormatVersion
-
hunk ./src/Haddock/Utils.hs 49
+
hunk ./src/Haddock/Utils.hs 100
--- | extract a module's short description.
+-- | Extract a module's short description.
hunk ./src/Haddock/Utils.hs 104
--- | extract a module's short description.
+
+-- | Extract a module's short description.
hunk ./src/Haddock/Utils.hs 113
+
hunk ./src/Haddock/Utils.hs 127
+
hunk ./src/Haddock/Utils.hs 149
+
hunk ./src/Haddock/Utils.hs 163
+
hunk ./src/Haddock/Utils.hs 173
+
hunk ./src/Haddock/Utils.hs 177
+
hunk ./src/Haddock/Utils.hs 182
+
hunk ./src/Haddock/Utils.hs 189
+
hunk ./src/Haddock/Utils.hs 195
+
hunk ./src/Haddock/Utils.hs 201
+
hunk ./src/Haddock/Utils.hs 206
+
hunk ./src/Haddock/Utils.hs 216
+
hunk ./src/Haddock/Utils.hs 220
+
hunk ./src/Haddock/Utils.hs 229
+
hunk ./src/Haddock/Utils.hs 233
+
hunk ./src/Haddock/Utils.hs 240
+
hunk ./src/Haddock/Utils.hs 244
+
hunk ./src/Haddock/Utils.hs 248
+
hunk ./src/Haddock/Utils.hs 252
+
hunk ./src/Haddock/Utils.hs 256
+
hunk ./src/Haddock/Utils.hs 261
+
hunk ./src/Haddock/Utils.hs 266
+
hunk ./src/Haddock/Utils.hs 270
+
hunk ./src/Haddock/Utils.hs 290
+
hunk ./src/Haddock/Utils.hs 294
+
hunk ./src/Haddock/Utils.hs 315
+
hunk ./src/Haddock/Utils.hs 320
+
hunk ./src/Haddock/Utils.hs 338
+
hunk ./src/Haddock/Utils.hs 356
+
hunk ./src/Haddock/Utils.hs 360
+
hunk ./src/Haddock/Utils.hs 385
+
hunk ./src/Haddock/Utils.hs 388
+
hunk ./src/Haddock/Utils.hs 392
+
hunk ./src/Haddock/Utils.hs 396
+
hunk ./src/Documentation/Haddock.hs 23
+ Decl,
hunk ./src/Documentation/Haddock.hs 39
+ Example(..),
hunk ./src/Haddock/Types.hs 163
--- | 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.
hunk ./src/Haddock/Interface.hs 5
--- David Waern 2006-2009
+-- David Waern 2006-2010
hunk ./src/Haddock/Interface.hs 12
--- 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.
hunk ./src/Haddock/Interface.hs 66
- -- Part 1, create interfaces
+
+ out verbosity verbose "Creating interfaces..."
hunk ./src/Haddock/Interface.hs 70
- out verbosity verbose "Creating interfaces..."
hunk ./src/Haddock/Interface.hs 72
- -- Part 2, build link environment
+ out verbosity verbose "Attaching instances..."
+ interfaces' <- attachInstances interfaces instIfaceMap
+
hunk ./src/Haddock/Interface.hs 76
- -- Combine the link envs of the external packages into one
+ -- Combine the link envs of the external packages into one
hunk ./src/Haddock/Interface.hs 81
-
- -- Part 3, attach instances
- out verbosity verbose "Attaching instances..."
- interfaces' <- attachInstances interfaces instIfaceMap
-
- -- Part 4, rename interfaces
+
hunk ./src/Haddock/Utils.hs 55
-import Binary
hunk ./src/Haddock/Utils.hs 64
-import Data.Word ( Word8 )
-import Data.Bits ( testBit )
hunk ./src/Haddock/GhcUtils.hs 27
+import Exception
hunk ./src/Haddock/GhcUtils.hs 231
+
+
+-------------------------------------------------------------------------------
+-- 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
+
hunk ./src/Haddock/Interface.hs 29
-
hunk ./src/Haddock/Interface.hs 34
+import Haddock.GhcUtils
+import Haddock.InterfaceFile
hunk ./src/Haddock/Interface.hs 39
-import Haddock.Types
hunk ./src/Haddock/Interface.hs 40
-import Haddock.GhcUtils
+import Haddock.Types
hunk ./src/Haddock/Interface.hs 42
-import Haddock.InterfaceFile
hunk ./src/Haddock/Interface.hs 43
-import qualified Data.Map as Map
+import Control.Monad
hunk ./src/Haddock/Interface.hs 45
+import qualified Data.Map as Map
hunk ./src/Haddock/Interface.hs 47
-import Control.Monad
-import Control.Exception ( evaluate )
hunk ./src/Haddock/Interface.hs 48
+import System.Directory
+import System.FilePath
hunk ./src/Haddock/Interface.hs 51
-import GHC hiding (verbosity, flags)
hunk ./src/Haddock/Interface.hs 52
+import Exception
+import GHC hiding (verbosity, flags)
hunk ./src/Haddock/Interface.hs 94
+ let useTempDir = Flag_NoTmpCompDir `notElem` flags
+
+ -- Output dir needs to be set before calling depanal since it uses it to
+ -- compute output file names that are stored in the DynFlags of the
+ -- resulting ModSummaries.
+ tmp <- liftIO getTemporaryDirectory
+ x <- liftIO getProcessID
+ let tempDir = tmp ".haddock-" ++ show x
+ when useTempDir $ modifySessionDynFlags (setOutputDir tempDir)
+
hunk ./src/Haddock/Interface.hs 106
+ -- Dependency analysis.
hunk ./src/Haddock/Interface.hs 109
- -- 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 addDefTarget m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = defaultObjectTarget } }
- return (map addDefTarget modgraph)
- else return modgraph
+ -- If template haskell is used by the package, we can't use HscNothing as
+ -- target since we might need to run code generated from one or more of the
+ -- modules during typechecking.
+ if needsTemplateHaskell modgraph
+ then
+ -- Create a temporary directory in wich to write compilation output,
+ -- unless the user has asked us not to.
+ (if useTempDir then withTempDir tempDir else id) $ do
+ -- Turn on compilation.
+ 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
hunk ./src/Haddock/Interface.hs 124
- 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
+ processModules verbosity flags instIfaceMap modgraph'
+ else
+ processModules verbosity flags instIfaceMap modgraph
+
+
+withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
+withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
+ (liftIO $ removeDirectoryRecursive dir)
+
+
+processModules :: Verbosity -> [Flag] -> InstIfaceMap -> [ModSummary]
+ -> Ghc [Interface]
+processModules verbosity flags instIfaceMap mods = do
+ let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
+ (ifaces, _) <- foldM f ([], Map.empty) sortedMods
hunk ./src/Haddock/Interface.hs 140
+ 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.
hunk ./src/Haddock/Interface.hs 148
-processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
hunk ./src/Haddock/Options.hs 95
+ | Flag_NoTmpCompDir
hunk ./src/Haddock/Options.hs 166
- Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings"
+ Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
+ Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
+ "don't re-direct compilation output to a temporary directory"
hunk ./src/Haddock/Utils.hs 46
- out
+ out,
+
+ -- * System tools
+ getProcessID
hunk ./src/Haddock/Utils.hs 75
+#ifndef mingw32_HOST_OS
+import qualified System.Posix.Internals
+#else /* Must be Win32 */
+import Foreign
+import Foreign.C.String
+#endif
+
hunk ./src/Haddock/Utils.hs 389
------------------------------------------------------------------------------
--- put here temporarily
-
-
-newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)
-
-
-nullFormatVersion :: FormatVersion
-nullFormatVersion = mkFormatVersion 0
-
+-- -----------------------------------------------------------------------------
+-- System tools
hunk ./src/Haddock/Utils.hs 392
-mkFormatVersion :: Int -> FormatVersion
-mkFormatVersion = FormatVersion
hunk ./src/Haddock/Utils.hs 393
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
+#else
+getProcessID :: IO Int
+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
+#endif
hunk ./src/Haddock/Utils.hs 400
-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
hunk ./src/Haddock/Options.hs 12
--- Definition of the command line interface of Haddock
+-- Definition of the command line interface of Haddock.
hunk ./src/Main.hs 169
--------------------------------------------------------------------------------
--- Rendering
--------------------------------------------------------------------------------
-
-
--- | Render the interfaces with whatever backend is specified in the flags
+-- | Render the interfaces with whatever backend is specified in the flags.
hunk ./src/Main.hs 293
+
hunk ./src/Main.hs 137
- -- We have one global error handler for all GHC source errors. Other kinds
- -- of exceptions will be propagated to the top-level error handler.
+ -- Catches all GHC source errors, then prints and re-throws them.
hunk ./src/Main.hs 142
- -- initialize GHC
+ -- Initialize GHC.
hunk ./src/Main.hs 120
- -- parse command-line flags and handle some of them initially
+ -- Parse command-line flags and handle some of them initially.
hunk ./src/Main.hs 145
- -- get packages supplied with --read-interface
+ -- Get packages supplied with --read-interface.
hunk ./src/Main.hs 148
-
- -- create the interfaces -- this is the core part of Haddock
+ -- Create the interfaces -- this is the core part of Haddock.
hunk ./src/Main.hs 151
-
hunk ./src/Main.hs 152
- -- render the interfaces
+ -- Render the interfaces.
hunk ./src/Main.hs 155
- -- last but not least, dump the interface file
+ -- Last but not least, dump the interface file.
hunk ./src/Main.hs 159
- -- get packages supplied with --read-interface
+ -- Get packages supplied with --read-interface.
hunk ./src/Main.hs 162
- -- render even though there are no input files (usually contents/index)
+ -- Render even though there are no input files (usually contents/index).
hunk ./src/Haddock/Interface.hs 82
-
+
hunk ./doc/haddock.xml 810
+
+
+
+
+ If the input modules use Template Haskell, Haddock has to
+ perform compilation (using GHC). This results in .o, .hi, and stub files that
+ are written to a temporary directory by default. When this flag is specified,
+ however, the files are written to the present directory (or another path if you
+ tell GHC, for example like this: --optghc=-odir --optghc=path).
+ Note that not only will files be written to this directory, GHC will also look for
+ already existing files there, and use them in order to skip compilation.
+
+
+
+
+
+
hunk ./src/Haddock/Utils.hs 121
-restrictTo :: [Name] -> (LHsDecl Name) -> (LHsDecl Name)
+restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
hunk ./src/Haddock/Utils.hs 397
-getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
+getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid
hunk ./haddock.cabal 72
- base >= 4.0.0.0 && < 4.3.0.0,
+ base >= 4.0.0.0 && < 4.4.0.0,
hunk ./haddock.cabal 128
- base >= 4.0.0.0 && < 4.3.0.0,
+ base >= 4.0.0.0 && < 4.4.0.0,
hunk ./haddock.cabal 78
+ xhtml >= 3000.2 && < 3000.3,
addfile ./html/xhaddock.css
hunk ./html/xhaddock.css 1
+* {
+ margin: 0;
+ padding: 0;
+}
+
+body {
+ background-color: #ffffff;
+ color: #000000;
+ font-size: 100%;
+ font-family: sans-serif;
+ padding: 8px;
+}
+
+a:link { color: #0000e0; text-decoration: none }
+a:visited { color: #0000a0; text-decoration: none }
+a:hover { background-color: #e0e0ff; text-decoration: none }
+
+/* font is a little too small in MSIE */
+tt { font-size: 100%; }
+pre { font-size: 100%; }
+span.keyword { text-decoration: underline; }
+
+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 {
+ font-weight: bold;
+ font-size: 100%
+ }
+
+p {
+ padding-top: 2px;
+ padding-left: 10px;
+ margin-bottom: 1em;
+}
+
+pre {
+ padding-top: 2px;
+ padding-left: 20px;
+ margin-bottom: 1em;
+}
+
+h1 + p, h2 + p, h3 + p, h4 + p {
+ margin-top: 1em;
+}
+
+p.caption {
+ margin: 0;
+ padding: 0;
+}
+
+div.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;
+}
+
+div.package-header a:link { color: #ffffff }
+div.package-header a:visited { color: #ffff00 }
+div.package-header a:hover { background-color: #6060ff; }
+div.package-header ul.links li:hover { background-color: #6060ff; }
+
+ul.links {
+ list-style: none;
+ text-align: left;
+ position: absolute;
+ right: 5px;
+ top: 5px;
+ display: inline-table;
+}
+
+ul.links li {
+ display: inline;
+ border-left-width: 1px;
+ border-left-color: #ffffff;
+ border-left-style: solid;
+ white-space: nowrap;
+ padding: 1px 5px;
+}
+
+div.module-header {
+ background-color: #0077dd;
+ padding: 5px;
+ position: relative;
+ height: 3em;
+}
+
+div.module-header p {
+ font-size: 200%;
+ height: 1.5em;
+ padding-top: .25em;
+}
+
+dl.info {
+ color: #ffffff;
+ display: block;
+ position: absolute;
+ top: 3px;
+ right: 5px;
+}
+
+dl.info dt {
+ float: left;
+ width: 5em;
+ font-weight: bold;
+ display: block;
+}
+
+dl.info dd {
+ display: block;
+ padding-left: 6em;
+}
+
+div.table-of-contents {
+ margin-top: 1em;
+ margin-bottom: 1em;
+}
+
+div.table-of-contents p {
+ font-weight: bold;
+}
+
+div.table-of-contents ul {
+ margin-top: 1em;
+ margin-bottom: 1em;
+ list-style-type: none;
+}
+
+div.table-of-contents ul ul {
+ margin-left: 2.5em;
+}
+
+ul.synopsis {
+ margin-top: 1em;
+ margin-bottom: 1em;
+}
+ul.synopsis li {
+ background-color: #f0f0f0;
+ font-family: monospace;
+ vertical-align: top;
+ margin-top: 8px;
+ margin-bottom: 8px;
+ padding: 2px;
+ margin-left: 10px;
+ list-style-type: none;
+}
+
+
+p.decl {
+ padding: 3px;
+ background-color: #f0f0f0;
+ font-family: monospace;
+ margin-bottom: 0;
+}
+
+
+p.decl a.link {
+ float: right;
+ border-left-width: 1px;
+ border-left-color: #000099;
+ border-left-style: solid;
+ white-space: nowrap;
+ font-size: small;
+ padding: 0 4px 2px 5px;
+}
+
+p.arg {
+ margin-bottom: 0;
+}
+p.arg span {
+ background-color: #f0f0f0;
+ font-family: monospace;
+ white-space: nowrap;
+ float: none;
+}
+
+p.inst-header {
+ font-weight: bold;
+ margin-bottom: 0;
+}
+
+p.inst-header img {
+ width : 0.75em; height: 0.75em; margin-bottom: 0; margin-right: 0.5em
+}
+
+ul.int {
+ margin-top: 1em;
+ margin-bottom: 1em;
+}
+ul.inst li {
+ background-color: #f0f0f0;
+ font-family: monospace;
+ vertical-align: top;
+ margin-top: 1px;
+ margin-bottom: 1px;
+ padding: 2px;
+ margin-left: 20px;
+ list-style-type: none;
+}
+
+
+
+div.bottom {
+ background-color: #000099;
+ color: #ffffff;
+ padding: 5px
+ }
+div.bottom a:link {
+ color: #ffffff;
+ text-decoration: underline
+ }
+div.bottom a:visited {
+ color: #ffff00
+ }
+div.bottom a:hover {
+ background-color: #6060ff
+ }
+
+/* @group Original Selectors */
+
+/* --------- Contents page ---------- */
+
+div.node {
+ padding-left: 3em;
+}
+
+div.cnode {
+ padding-left: 1.75em;
+}
+
+span.pkg {
+ position: absolute;
+ left: 50em;
+}
+
+/* --------- 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;
+}
+
+/* @end */
+
+
+
+
+
adddir ./src/Haddock/Backends/Xhtml
addfile ./src/Haddock/Backends/Xhtml.hs
hunk ./src/Haddock/Backends/Xhtml.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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,
+ ppHtmlHelpFiles
+) where
+
+
+import Prelude hiding (div)
+
+import Haddock.Backends.DevHelp
+import Haddock.Backends.HH
+import Haddock.Backends.HH2
+import Haddock.Backends.Xhtml.Decl
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Util
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Version
+import Haddock.Utils
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as Html
+import Haddock.GhcUtils
+
+import Control.Exception ( bracket )
+import Control.Monad ( when, unless )
+import Control.Monad.Instances ( ) -- for Functor Either a
+import Data.Char ( toUpper )
+import Data.Either
+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
+
+
+
+-- -----------------------------------------------------------------------------
+-- 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, 'x':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 :: Html
+footer =
+ thediv ! [theclass "bottom"] << paragraph << (
+ "Produced by " +++
+ (anchor ! [href projectUrl] << toHtml projectName) +++
+ (" version " ++ projectVersion)
+ )
+
+srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
+srcButton (Just src_base_url, _, _) Nothing =
+ Just (anchor ! [href src_base_url] << "Source code")
+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 code")
+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
+
+simpleHeader :: String -> Maybe String -> Maybe String
+ -> SourceURLs -> WikiURLs -> Html
+simpleHeader doctitle maybe_contents_url maybe_index_url
+ maybe_source_url maybe_wiki_url =
+ thediv ! [theclass "package-header"] << (
+ paragraph ! [theclass "caption"] << doctitle +++
+ unordList (catMaybes [
+ srcButton maybe_source_url Nothing,
+ wikiButton maybe_wiki_url Nothing,
+ contentsButton maybe_contents_url,
+ indexButton maybe_index_url
+ ]) ! [theclass "links"]
+ )
+
+pageHeader :: String -> Interface -> String
+ -> SourceURLs -> WikiURLs
+ -> Maybe String -> Maybe String -> Html
+pageHeader mdl iface doctitle
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url =
+ thediv ! [theclass "package-header"] << (
+ paragraph ! [theclass "caption"] << (doctitle +++ spaceHtml) +++
+ unordList (catMaybes [
+ srcButton maybe_source_url (Just iface),
+ wikiButton maybe_wiki_url (Just $ ifaceMod iface),
+ contentsButton maybe_contents_url,
+ indexButton maybe_index_url
+ ]) ! [theclass "links"]
+ ) +++
+ thediv ! [theclass "module-header"] << (
+ paragraph ! [theclass "caption"] << mdl +++
+ moduleInfo iface
+ )
+
+moduleInfo :: Interface -> Html
+moduleInfo iface =
+ let
+ info = ifaceInfo iface
+
+ doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe (String, String)
+ doOneEntry (fieldName, field) = field info >>= \a -> return (fieldName, a)
+
+ entries :: [(String, String)]
+ entries = mapMaybe doOneEntry [
+ ("Portability",hmi_portability),
+ ("Stability",hmi_stability),
+ ("Maintainer",hmi_maintainer)
+ ]
+ in
+ case entries of
+ [] -> noHtml
+ _ -> defList entries ! [theclass "info"]
+
+-- ---------------------------------------------------------------------------
+-- 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 << (
+ simpleHeader doctitle Nothing maybe_index_url
+ maybe_source_url maybe_wiki_url +++
+ vanillaTable << (
+ ppPrologue doctitle prologue
+ ppModuleTree doctitle tree) +++
+ footer
+ )
+ createDirectoryIfMissing True odir
+ writeFile (pathJoin [odir, contentsHtmlFile]) (renderToString 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 = 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 -> cell $ 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__
+
+
+-- | 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]) (renderToString 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 << (
+ simpleHeader doctitle maybe_contents_url Nothing
+ maybe_source_url maybe_wiki_url +++
+ vanillaTable << index_html
+ )
+
+ createDirectoryIfMissing True odir
+
+ when split_indices $
+ mapM_ (do_sub_index index) initialChars
+
+ writeFile (pathJoin [odir, indexHtmlFile]) (renderToString 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 =
+ cell $ 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 = id
+ -- XHtml is more strict about not allowing you to poke inside a structure
+ -- hence this approach won't work for now -- since the whole table is
+ -- going away soon, this is just disabled for now.
+{-
+ 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]) (renderToString html)
+ where
+ html = header (documentCharacterEncoding +++
+ thetitle (toHtml (doctitle ++ " (Index)")) +++
+ styleSheet) +++
+ body << (
+ simpleHeader doctitle maybe_contents_url Nothing
+ maybe_source_url maybe_wiki_url +++
+ vanillaTable << (
+ 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?
+ << ("window.onload = function () {setSynopsis(\"mini_"
+ ++ moduleHtmlFile mdl ++ "\")};"))
+ ) +++
+ body << (
+ pageHeader mdl_str iface doctitle
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url +++
+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode +++
+ footer)
+
+ createDirectoryIfMissing True odir
+ writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderToString 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]) (renderToString html)
+
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
+ = ppModuleContents exports +++
+ 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)
+
+ description
+ = case ifaceRnDoc iface of
+ Nothing -> noHtml
+ Just doc -> h1 << toHtml "Description" +++ docToHtml doc
+
+ -- omit the synopsis if there are no documentation annotations at all
+ synopsis
+ | no_doc_at_all = noHtml
+ | otherwise
+ = h1 << "Synopsis" +++
+ unordList (
+ rights $
+ map (processExport True linksInfo unicode) exports
+ ) ! [theclass "synopsis"]
+
+ -- 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 $
+ map (either id (paragraph ! [theclass "decl"] <<)) $
+ 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] -> Html
+ppModuleContents exports
+ | null sections = noHtml
+ | otherwise = contentsDiv
+ where
+ contentsDiv = thediv ! [theclass "table-of-contents"] << (
+ paragraph ! [theclass "caption"] << "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)
+ -> Either Html Html -- Right is a decl, Left is a "extra" (doc or group)
+processExport _ _ _ (ExportGroup lev id0 doc)
+ = Left $ groupTag lev << namedAnchor id0 << docToHtml doc
+processExport summary links unicode (ExportDecl decl doc subdocs insts)
+ = Right $ ppDecl' summary links decl doc insts subdocs unicode
+processExport _ _ _ (ExportNoDecl y [])
+ = Right $ ppDocName y
+processExport _ _ _ (ExportNoDecl y subs)
+ = Right $ ppDocName y +++ parenList (map ppDocName subs)
+processExport _ _ _ (ExportDoc doc)
+ = Left $ docToHtml doc
+processExport _ _ _ (ExportModule mdl)
+ = Right $ toHtml "module" +++ ppModule mdl ""
+
+groupTag :: Int -> Html -> Html
+groupTag lev
+ | lev == 1 = h1
+ | lev == 2 = h2
+ | lev == 3 = h3
+ | otherwise = h4
+
+
+
+
addfile ./src/Haddock/Backends/Xhtml/Decl.hs
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 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.Util
+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' s k l m i d u = vanillaTable << ppDecl s k l m i d u
+
+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 _ -> 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 -> 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 -> 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 -> emptyTable
+ Just d -> ndocBox (docToHtml d)
+
+ body_
+ | null lsigs, null ats = 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 = 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 -> emptyTable
+
+ constrBit
+ | null cons = emptyTable
+ | otherwise = constrHdr (
+ tda [theclass "body"] << constrTable <<
+ aboves (map (ppSideBySideConstr subdocs unicode) cons)
+ )
+
+ instId = collapseId (getName docname)
+
+ instancesBit
+ | null instances = 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 = 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]
+
+
addfile ./src/Haddock/Backends/Xhtml/DocMarkup.hs
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 where
+
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Util
+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 {
+ markupParagraph = paragraph,
+ markupEmpty = toHtml "",
+ markupString = toHtml,
+ markupAppend = (+++),
+ markupIdentifier = tt . ppId . choose,
+ markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref,
+ markupEmphasis = emphasize . toHtml,
+ markupMonospaced = tt . toHtml,
+ markupUnorderedList = ulist . concatHtml . map (li <<),
+ markupPic = \path -> image ! [src path],
+ markupOrderedList = olist . concatHtml . map (li <<),
+ markupDefList = dlist . concatHtml . map markupDef,
+ markupCodeBlock = pre,
+ markupURL = \url -> anchor ! [href url] << toHtml url,
+ markupAName = \aname -> namedAnchor aname << toHtml ""
+ }
+ where
+ -- If an id can refer to multiple things, we give precedence to type
+ -- constructors. This should ideally be done during renaming from RdrName
+ -- to Name, but since we will move this process from GHC into Haddock in
+ -- the future, we fix it here in the meantime.
+ -- TODO: mention this rule in the documentation.
+ choose [] = error "empty identifier list in HsDoc"
+ choose [x] = x
+ choose (x:y:_)
+ | isTyCon x = x
+ | otherwise = y
+
+
+markupDef :: (HTML a, HTML b) => (a, b) -> Html
+markupDef (a,b) = dterm << a +++ ddef << b
+
+
+htmlMarkup :: DocMarkup DocName Html
+htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName)
+
+htmlOrigMarkup :: DocMarkup Name Html
+htmlOrigMarkup = parHtmlMarkup ppName isTyConName
+
+htmlRdrMarkup :: DocMarkup RdrName Html
+htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc
+
+-- If the doc is a single paragraph, don't surround it with
(this causes
+-- ugly extra whitespace with some browsers).
+docToHtml :: Doc DocName -> Html
+docToHtml doc = markup htmlMarkup (markup htmlCleanup doc)
+
+origDocToHtml :: Doc Name -> Html
+origDocToHtml doc = markup htmlOrigMarkup (markup htmlCleanup doc)
+
+rdrDocToHtml :: Doc RdrName -> Html
+rdrDocToHtml doc = markup htmlRdrMarkup (markup htmlCleanup doc)
+
+-- If there is a single paragraph, then surrounding it with
..
+-- can add too much whitespace in some browsers (eg. IE). However if
+-- we have multiple paragraphs, then we want the extra whitespace to
+-- separate them. So we catch the single paragraph case and transform it
+-- here.
+unParagraph :: Doc a -> Doc a
+unParagraph (DocParagraph d) = d
+--NO: This eliminates line breaks in the code block: (SDM, 6/5/2003)
+--unParagraph (DocCodeBlock d) = (DocMonospaced d)
+unParagraph doc = doc
+
+htmlCleanup :: DocMarkup a (Doc a)
+htmlCleanup = idMarkup {
+ markupUnorderedList = DocUnorderedList . map unParagraph,
+ markupOrderedList = DocOrderedList . map unParagraph
+ }
addfile ./src/Haddock/Backends/Xhtml/Layout.hs
hunk ./src/Haddock/Backends/Xhtml/Layout.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 where
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Util
+import Haddock.Types
+
+import Text.XHtml hiding ( name, title, p, quote )
+
+import FastString ( unpackFS )
+import GHC
+
+
+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)
+
+
+
+{-
+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 -> 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 -> 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)
+
+
+bodyBox :: Html -> HtmlTable
+bodyBox html = tda [theclass "body"] << vanillaTable << html
+
+-- a vanilla table has width 100%, no border, no padding, no spacing
+vanillaTable, vanillaTable2 :: Html -> Html
+vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0]
+vanillaTable2 = table ! [theclass "vanilla2", 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")
addfile ./src/Haddock/Backends/Xhtml/Names.hs
hunk ./src/Haddock/Backends/Xhtml/Names.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 where
+
+import Haddock.Backends.Xhtml.Util
+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)
+
+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)
+
addfile ./src/Haddock/Backends/Xhtml/Types.hs
hunk ./src/Haddock/Backends/Xhtml/Types.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 where
+
+
+-- 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)
+
+-- The URL for source and wiki links, and the current module
+type LinksInfo = (SourceURLs, WikiURLs)
addfile ./src/Haddock/Backends/Xhtml/Util.hs
hunk ./src/Haddock/Backends/Xhtml/Util.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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.Util where
+
+import Haddock.GhcUtils
+import Haddock.Utils
+
+import Data.Maybe
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as Html
+
+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
+
+(<++>) :: 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 _ [] = 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 "#)"
+
+
+tda :: [HtmlAttr] -> Html -> HtmlTable
+tda as = cell . (td ! as)
+
+emptyTable :: HtmlTable
+emptyTable = cell noHtml
+
+onclick :: String -> HtmlAttr
+onclick = strAttr "onclick"
+
+
+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 :: HtmlTable
+s8 = tda [ theclass "s8" ] << 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 c = anchor ! [Html.name n] << noHtml +++
+ anchor ! [Html.name (escapeStr n)] << c
+
+
+--
+-- 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"]) noHtml
hunk ./src/Haddock/Options.hs 80
+ | Flag_Xhtml
hunk ./src/Haddock/Options.hs 117
+ Option [] ["xhtml"] (NoArg Flag_Xhtml) "use experimental XHTML rendering",
hunk ./src/Main.hs 21
-import Haddock.Backends.Html
+import qualified Haddock.Backends.Html as Html
+import qualified Haddock.Backends.Xhtml as Xhtml
hunk ./src/Main.hs 222
+ -- which HTML redering to use
+ pick htmlF xhtmlF = if (Flag_Xhtml `elem` flags) then xhtmlF else htmlF
+ ppHtmlIndex = pick Html.ppHtmlIndex Xhtml.ppHtmlIndex
+ ppHtmlHelpFiles = pick Html.ppHtmlHelpFiles Xhtml.ppHtmlHelpFiles
+ ppHtmlContents = pick Html.ppHtmlContents Xhtml.ppHtmlContents
+ ppHtml = pick Html.ppHtml Xhtml.ppHtml
+ copyHtmlBits = pick Html.copyHtmlBits Xhtml.copyHtmlBits
hunk ./tests/golden-tests/README 27
+You can pass extra options to haddock like so
+ runhaskell runtests.hs --xhtml all
+
hunk ./tests/golden-tests/runtests.hs 68
-
+ let (opts, spec) = span ("-" `isPrefixOf`) args
hunk ./tests/golden-tests/runtests.hs 70
- case args of
+ case spec of
hunk ./tests/golden-tests/runtests.hs 93
- handle <- runProcess "../dist/build/haddock/haddock" (["-w", "-o", outdir, "-h", "--optghc=-fglasgow-exts", "--optghc=-w", base, process] ++ mods') Nothing (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
+ handle <- runProcess "../dist/build/haddock/haddock" (["-w", "-o", outdir, "-h", "--optghc=-fglasgow-exts", "--optghc=-w", base, process] ++ opts ++ mods') Nothing (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 600
+#if __GLASGOW_HASKELL__ == 612
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 602
+#else
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html
+#endif
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 816
+#if __GLASGOW_HASKELL__ == 612
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 818
+#else
+ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
+#endif
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 840
--- gaw 2004
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 849
-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 _ (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"
hunk ./haddock.cabal 113
+ Haddock.Backends.Xhtml
+ Haddock.Backends.Xhtml.Decl
+ Haddock.Backends.Xhtml.DocMarkup
+ Haddock.Backends.Xhtml.Layout
+ Haddock.Backends.Xhtml.Names
+ Haddock.Backends.Xhtml.Types
+ Haddock.Backends.Xhtml.Util
hunk ./haddock.cabal 142
+ xhtml >= 3000.2 && < 3000.3,
hunk ./haddock.cabal 179
+ Haddock.Backends.Xhtml
+ Haddock.Backends.Xhtml.Decl
+ Haddock.Backends.Xhtml.DocMarkup
+ Haddock.Backends.Xhtml.Layout
+ Haddock.Backends.Xhtml.Names
+ Haddock.Backends.Xhtml.Types
+ Haddock.Backends.Xhtml.Util
hunk ./src/Haddock/Backends/Hoogle.hs 242
- markupAName = const $ str ""
+ markupAName = const $ str "",
+ markupExample = box TagPre . str . unlines . (map exampleToString)
hunk ./src/Haddock/Backends/Html.hs 1725
- markupAName = \aname -> namedAnchor aname << toHtml ""
+ markupAName = \aname -> namedAnchor aname << toHtml "",
+ markupExample = examplesToHtml
hunk ./src/Haddock/Backends/Html.hs 1740
+ examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+ exampleToHtml (Example expression result) = htmlExample
+ where
+ htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result)
+ htmlPrompt = (thecode . toHtml $ "ghci> ") ! [theclass "prompt"]
+ htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 45
- markupAName = \aname -> namedAnchor aname << toHtml ""
+ markupAName = \aname -> namedAnchor aname << toHtml "",
+ markupExample = examplesToHtml
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 60
+ examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+ exampleToHtml (Example expression result) = htmlExample
+ where
+ htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result)
+ htmlPrompt = (thecode . toHtml $ "ghci> ") ! [theclass "prompt"]
+ htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
hunk ./src/Haddock/Interface/Rename.hs 204
+ DocExamples e -> return (DocExamples e)
hunk ./src/Haddock/Interface/Rn.hs 83
+ DocExamples e -> return (DocExamples e)
+
hunk ./src/Haddock/InterfaceFile.hs 380
+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)
+
+
hunk ./src/Haddock/InterfaceFile.hs 437
+ put_ bh (DocExamples ao) = do
+ putByte bh 15
+ put_ bh ao
hunk ./src/Haddock/InterfaceFile.hs 488
+ 15 -> do
+ ao <- get bh
+ return (DocExamples ao)
hunk ./src/Haddock/Lex.x 48
+ $ws* ghci \> { strtoken TokExamplePrompt `andBegin` exampleexpr }
hunk ./src/Haddock/Lex.x 71
+ {
+ $ws* \n { token TokPara `andBegin` para }
+ $ws* ghci \> { strtoken TokExamplePrompt `andBegin` exampleexpr }
+ () { begin exampleresult }
+}
+
+ .* \n { strtokenNL TokExampleExpression `andBegin` example }
+
+ .* \n { strtokenNL TokExampleResult `andBegin` example }
+
hunk ./src/Haddock/Lex.x 123
+ | TokExamplePrompt String
+ | TokExampleExpression String
+ | TokExampleResult String
hunk ./src/Haddock/Parse.y 12
-import Haddock.Types (Doc(..))
+import Haddock.Types (Doc(..), Example(Example))
hunk ./src/Haddock/Parse.y 16
+import Data.Char (isSpace)
+import Data.Maybe (fromMaybe)
+import Data.List (stripPrefix)
hunk ./src/Haddock/Parse.y 37
+ PROMPT { TokExamplePrompt $$ }
+ RESULT { TokExampleResult $$ }
+ EXP { TokExampleExpression $$ }
hunk ./src/Haddock/Parse.y 75
+ | examples { DocExamples $1 }
hunk ./src/Haddock/Parse.y 81
+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 }
+
hunk ./src/Haddock/Parse.y 122
+
+-- | 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
hunk ./src/Haddock/Types.hs 282
+ | DocExamples [Example]
hunk ./src/Haddock/Types.hs 285
+data Example = Example { exampleExpression :: String
+ , exampleResult :: [String]
+ }
+ deriving (Eq, Show)
+
+exampleToString :: Example -> String
+exampleToString (Example expression result) =
+ "ghci> " ++ expression ++ "\n" ++ unlines result
hunk ./src/Haddock/Types.hs 334
- markupPic :: String -> a
+ markupPic :: String -> a,
+ markupExample :: [Example] -> a
hunk ./src/Haddock/Utils.hs 362
+markup m (DocExamples e) = markupExample m e
hunk ./src/Haddock/Utils.hs 386
- markupPic = DocPic
+ markupPic = DocPic,
+ markupExample = DocExamples
hunk ./src/Haddock/Interface/LexParseRn.hs 45
- let toks = tokenise str
+ let toks = tokenise str (0,0) -- TODO: real position
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 47
- Just description -> case parseString . tokenise $ description of
+ -- TODO: pass real file position
+ Just description -> case parseString $ tokenise description (0,0) of
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 54
- Right docOpt -> case parseParas . tokenise $ str8 of
+ -- TODO: pass real file position
+ Right docOpt -> case parseParas $ tokenise str8 (0,0) of
hunk ./src/Haddock/Lex.x 20
+ LToken,
hunk ./src/Haddock/Lex.x 36
+%wrapper "posn"
+
hunk ./src/Haddock/Lex.x 112
+-- | A located token
+type LToken = (Token, AlexPosn)
+
hunk ./src/Haddock/Lex.x 134
+tokenPos :: LToken -> (Int, Int)
+tokenPos t = let AlexPn _ line col = snd t in (line, col)
+
hunk ./src/Haddock/Lex.x 141
-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]) -> [LToken]
hunk ./src/Haddock/Lex.x 143
-alexInputPrevChar (c,_) = c
+tokenise :: String -> (Int, Int) -> [LToken]
+tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks
+ where
+ posn = AlexPn 0 line col
hunk ./src/Haddock/Lex.x 148
-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 =
hunk ./src/Haddock/Lex.x 153
- 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)
hunk ./src/Haddock/Lex.x 160
-andBegin act new_sc = \str _ cont -> act str new_sc cont
+andBegin act new_sc = \pos str _ cont -> act pos str new_sc cont
hunk ./src/Haddock/Lex.x 163
-token t = \_ sc cont -> t : cont sc
+token t = \pos _ sc cont -> (t, pos) : cont sc
hunk ./src/Haddock/Lex.x 166
-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
hunk ./src/Haddock/Lex.x 172
-begin sc = \_ _ cont -> cont sc
+begin sc = \_ _ _ cont -> cont sc
hunk ./src/Haddock/Lex.x 178
-ident str sc cont =
+ident pos str sc cont =
hunk ./src/Haddock/Lex.x 180
- Just names -> TokIdent names : cont sc
- Nothing -> TokString str : cont sc
+ Just names -> (TokIdent names, pos) : cont sc
+ Nothing -> (TokString str, pos) : cont sc
hunk ./src/Haddock/Parse.y 23
-%tokentype { Token }
+%tokentype { LToken }
hunk ./src/Haddock/Parse.y 25
-%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 $$ }
+%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 $$,_) }
hunk ./src/Haddock/Parse.y 120
-happyError :: [Token] -> Maybe a
+happyError :: [LToken] -> Maybe a
hunk ./src/Main.hs 408
- case parseParas (tokenise str) of
+ case parseParas (tokenise str (0,0) {- TODO: real position -}) of
hunk ./tests/golden-tests/runtests.hs 17
+haddockPath = ".." "dist" "build" "haddock" "haddock"
+
+
hunk ./tests/golden-tests/runtests.hs 25
-haddockEq file1 file2 = stripLinks file1 == stripLinks file2
+test = do
+ x <- doesFileExist haddockPath
+ when (not x) $ die "you need to run 'cabal build' successfully first"
hunk ./tests/golden-tests/runtests.hs 29
-stripLinks f = subRegex (mkRegexWithOpts "]*>" False False) f ""
+ contents <- getDirectoryContents "tests"
+ args <- getArgs
+ let (opts, spec) = span ("-" `isPrefixOf`) args
+ let mods =
+ case spec of
+ x:_ | x /= "all" -> [x ++ ".hs"]
+ _ -> filter ((==) ".hs" . takeExtension) contents
hunk ./tests/golden-tests/runtests.hs 37
-programOnPath p = do
- result <- findProgramLocation silent p
- return (isJust result)
+ let outdir = "output"
+ let mods' = map ("tests" ) mods
+ putStrLn ""
+ putStrLn "Haddock version: "
+ h1 <- runProcess haddockPath ["--version"] Nothing
+ (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
+ waitForProcess h1
+ putStrLn ""
+ putStrLn "GHC version: "
+ h2 <- runProcess haddockPath ["--ghc-version"] Nothing
+ (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
+ waitForProcess h2
+ putStrLn ""
+
+ libdir <- rawSystemStdout normal haddockPath ["--print-ghc-libdir"]
+ let basepath = init libdir ++ "/../../share/doc/ghc/html/libraries/base-4.2.0.0/"
+ let base = "-i " ++ basepath ++ "," ++ basepath ++ "base.haddock"
+ let processpath = init libdir ++ "/../../share/doc/ghc/html/libraries/process-1.0.1.2/"
+ let process = "-i " ++ processpath ++ "," ++ processpath ++ "process.haddock"
+
+ putStrLn "Running tests..."
+ handle <- runProcess haddockPath
+ (["-w", "-o", outdir, "-h", "--optghc=-fglasgow-exts"
+ , "--optghc=-w", base, process] ++ opts ++ mods')
+ Nothing (Just [("haddock_datadir", "../.")]) Nothing
+ Nothing Nothing
+
+ code <- waitForProcess handle
+ when (code /= ExitSuccess) $ error "Haddock run failed! Exiting."
+ check mods (if not (null args) && args !! 0 == "all" then False else True)
hunk ./tests/golden-tests/runtests.hs 99
-test = do
+haddockEq file1 file2 = stripLinks file1 == stripLinks file2
hunk ./tests/golden-tests/runtests.hs 101
- x <- doesFileExist (".." "dist" "build" "haddock" "haddock")
- when (not x) $ die "you need to run 'cabal build' successfully first"
hunk ./tests/golden-tests/runtests.hs 102
- contents <- getDirectoryContents "tests"
- args <- getArgs
- let (opts, spec) = span ("-" `isPrefixOf`) args
- let mods =
- case spec of
- x:_ | x /= "all" -> [x ++ ".hs"]
- _ -> filter ((==) ".hs" . takeExtension) contents
+stripLinks f = subRegex (mkRegexWithOpts "]*>" False False) f ""
hunk ./tests/golden-tests/runtests.hs 104
- let outdir = "output"
- let mods' = map ("tests" ) mods
- putStrLn ""
- putStrLn "Haddock version: "
- h1 <- runProcess "../dist/build/haddock/haddock" ["--version"] Nothing (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
- waitForProcess h1
- putStrLn ""
- putStrLn "GHC version: "
- h2 <- runProcess "../dist/build/haddock/haddock" ["--ghc-version"] Nothing (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
- waitForProcess h2
- putStrLn ""
hunk ./tests/golden-tests/runtests.hs 105
- libdir <- rawSystemStdout normal "../dist/build/haddock/haddock" ["--print-ghc-libdir"]
- let basepath = init libdir ++ "/../../share/doc/ghc/html/libraries/base-4.2.0.0/"
- let base = "-i " ++ basepath ++ "," ++ basepath ++ "base.haddock"
- let processpath = init libdir ++ "/../../share/doc/ghc/html/libraries/process-1.0.1.2/"
- let process = "-i " ++ processpath ++ "," ++ processpath ++ "process.haddock"
+programOnPath p = do
+ result <- findProgramLocation silent p
+ return (isJust result)
hunk ./tests/golden-tests/runtests.hs 109
- putStrLn "Running tests..."
- handle <- runProcess "../dist/build/haddock/haddock" (["-w", "-o", outdir, "-h", "--optghc=-fglasgow-exts", "--optghc=-w", base, process] ++ opts ++ mods') Nothing (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
- code <- waitForProcess handle
- when (code /= ExitSuccess) $ error "Haddock run failed! Exiting."
- check mods (if not (null args) && args !! 0 == "all" then False else True)
hunk ./tests/golden-tests/runtests.hs 51
+ -- TODO: use Distribution.* to get the packages instead
hunk ./tests/golden-tests/runtests.hs 53
- let basepath = init libdir ++ "/../../share/doc/ghc/html/libraries/base-4.2.0.0/"
- let base = "-i " ++ basepath ++ "," ++ basepath ++ "base.haddock"
- let processpath = init libdir ++ "/../../share/doc/ghc/html/libraries/process-1.0.1.2/"
- let process = "-i " ++ processpath ++ "," ++ processpath ++ "process.haddock"
+ let librariesPath = "..""..""share""doc""ghc""html""libraries"
+
+ let mkDep name version =
+ let path = init libdir librariesPath name ++ "-" ++ version
+ in "-i " ++ path ++ "," ++ path name ++ ".haddock"
+
+ let base = mkDep "base" "4.2.0.0"
+ process = mkDep "process" "1.0.1.2"
hunk ./tests/golden-tests/runtests.hs 61
+ ghcprim = mkDep "ghc-prim" "0.2.0.0"
hunk ./tests/golden-tests/runtests.hs 66
- , "--optghc=-w", base, process] ++ opts ++ mods')
+ , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
hunk ./tests/golden-tests/tests/FunArgs.html.ref 121
->-> ()-> () () () () () () () ()() () () -> T2()() -> T2 () () -> IO () ()() -> IO() () -> IO() -> IO () () ()() () () ()() () () ()() () () () () [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
-declInfos gre decls =
+declInfos :: DynFlags -> GlobalRdrEnv -> [(Decl, MaybeDocStrings)] -> ErrMsgM [DeclInfo]
+declInfos dflags gre decls =
hunk ./src/Haddock/Interface/Create.hs 175
- mbDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+ mbDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment
hunk ./src/Haddock/Interface/Create.hs 179
- \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc
+ \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
hunk ./src/Haddock/Interface/Create.hs 183
- mbSubDoc <- lexParseRnHaddockCommentList NormalHaddockComment
+ mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment
hunk ./src/Haddock/Interface/Create.hs 187
- \doc -> lexParseRnHaddockComment NormalHaddockComment gre doc
+ \doc -> lexParseRnHaddockComment dflags NormalHaddockComment gre doc
hunk ./src/Haddock/Interface/Create.hs 435
+ -> DynFlags
hunk ./src/Haddock/Interface/Create.hs 439
- opts maybe_exps ignore_all_exports _ instIfaceMap
+ opts maybe_exps ignore_all_exports _ instIfaceMap dflags
hunk ./src/Haddock/Interface/Create.hs 447
- liftErrMsg $ fullContentsOfThisModule gre decls
+ liftErrMsg $ fullContentsOfThisModule dflags gre decls
hunk ./src/Haddock/Interface/Create.hs 456
- ifDoc (lexParseRnHaddockComment DocSectionComment gre docStr)
+ ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr)
hunk ./src/Haddock/Interface/Create.hs 459
- ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+ ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
hunk ./src/Haddock/Interface/Create.hs 464
- ifDoc (lexParseRnHaddockComment NormalHaddockComment gre docStr)
+ ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)
hunk ./src/Haddock/Interface/Create.hs 623
- | m == this_mod = liftErrMsg $ fullContentsOfThisModule gre decls
+ | m == this_mod = liftErrMsg $ fullContentsOfThisModule dflags gre decls
hunk ./src/Haddock/Interface/Create.hs 671
-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
hunk ./src/Haddock/Interface/Create.hs 675
- mbDoc <- lexParseRnHaddockComment DocSectionComment gre docStr
+ mbDoc <- lexParseRnHaddockComment dflags DocSectionComment gre docStr
hunk ./src/Haddock/Interface/Create.hs 678
- mbDoc <- lexParseRnHaddockComment NormalHaddockComment gre docStr
+ mbDoc <- lexParseRnHaddockComment dflags NormalHaddockComment gre docStr
hunk ./src/Haddock/Interface/LexParseRn.hs 32
-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
hunk ./src/Haddock/Interface/LexParseRn.hs 41
-lexParseRnHaddockComment :: HaddockCommentType ->
+lexParseRnHaddockComment :: DynFlags -> HaddockCommentType ->
hunk ./src/Haddock/Interface/LexParseRn.hs 43
-lexParseRnHaddockComment hty gre (HsDocString fs) = do
+lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do
hunk ./src/Haddock/Interface/LexParseRn.hs 45
- let toks = tokenise str (0,0) -- TODO: real position
+ let toks = tokenise dflags str (0,0) -- TODO: real position
hunk ./src/Haddock/Interface/LexParseRn.hs 55
-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
hunk ./src/Haddock/Interface/LexParseRn.hs 60
-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
hunk ./src/Haddock/Interface/LexParseRn.hs 67
- case parseModuleHeader str of
+ case parseModuleHeader dflags str of
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 18
+import DynFlags
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 28
-parseModuleHeader :: String -> Either String (HaddockModInfo RdrName, Doc RdrName)
-parseModuleHeader str0 =
+parseModuleHeader :: DynFlags -> String -> Either String (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader dflags str0 =
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 49
- Just description -> case parseString $ tokenise description (0,0) of
+ Just description -> case parseString $ tokenise dflags description (0,0) of
hunk ./src/Haddock/Interface/ParseModuleHeader.hs 56
- Right docOpt -> case parseParas $ tokenise str8 (0,0) of
+ Right docOpt -> case parseParas $ tokenise dflags str8 (0,0) of
hunk ./src/Haddock/Lex.x 141
-type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> [LToken]
+type Action = AlexPosn -> String -> StartCode -> (StartCode -> [LToken]) -> DynFlags -> [LToken]
hunk ./src/Haddock/Lex.x 143
-tokenise :: String -> (Int, Int) -> [LToken]
-tokenise str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks
+tokenise :: DynFlags -> String -> (Int, Int) -> [LToken]
+tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para in {-trace (show toks)-} toks
hunk ./src/Haddock/Lex.x 153
- AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc)
+ AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags
hunk ./src/Haddock/Lex.x 160
-andBegin act new_sc = \pos str _ cont -> act pos str new_sc cont
+andBegin act new_sc = \pos str _ cont dflags -> act pos str new_sc cont dflags
hunk ./src/Haddock/Lex.x 163
-token t = \pos _ sc cont -> (t, pos) : cont sc
+token t = \pos _ sc cont _ -> (t, pos) : cont sc
hunk ./src/Haddock/Lex.x 166
-strtoken t = \pos str sc cont -> (t str, pos) : cont sc
-strtokenNL t = \pos str sc cont -> (t (filter (/= '\r') str), pos) : 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
hunk ./src/Haddock/Lex.x 172
-begin sc = \_ _ _ cont -> cont sc
+begin sc = \_ _ _ cont _ -> cont sc
hunk ./src/Haddock/Lex.x 178
-ident pos str sc cont =
- case strToHsQNames id of
+ident pos str sc cont dflags =
+ case strToHsQNames dflags id of
hunk ./src/Haddock/Lex.x 184
-strToHsQNames :: String -> Maybe [RdrName]
-strToHsQNames str0 =
+strToHsQNames :: DynFlags -> String -> Maybe [RdrName]
+strToHsQNames dflags str0 =
hunk ./src/Haddock/Lex.x 187
- pstate = mkPState buffer noSrcLoc defaultDynFlags
+ pstate = mkPState buffer noSrcLoc dflags
hunk ./src/Haddock/Types.hs 159
- ghcInstances :: [Instance]
+ ghcInstances :: [Instance],
+ ghcDynFlags :: DynFlags
hunk ./src/Main.hs 408
- case parseParas (tokenise str (0,0) {- TODO: real position -}) of
+ case parseParas (tokenise defaultDynFlags str (0,0) {- TODO: real position -}) of
addfile ./tests/golden-tests/tests/Ticket112.hs
hunk ./tests/golden-tests/tests/Ticket112.hs 1
+{-# LANGUAGE MagicHash #-}
+
+module Ticket112 where
+
+import GHC.Prim
+
+-- | ...given a raw 'Addr#' to the string, and the length of the string.
+f :: a
+f = undefined
addfile ./tests/golden-tests/tests/Ticket112.html.ref
hunk ./tests/golden-tests/tests/Ticket112.html.ref 1
+
+
+Ticket112
hunk ./tests/golden-tests/runtests.hs 17
-haddockPath = ".." "dist" "build" "haddock" "haddock"
+haddockBase = ".." ".."
+haddockPath = haddockBase "dist" "build" "haddock" "haddock"
hunk ./tests/golden-tests/runtests.hs 43
- (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
+ (Just [("haddock_datadir", haddockBase)]) Nothing Nothing Nothing
hunk ./tests/golden-tests/runtests.hs 48
- (Just [("haddock_datadir", "../.")]) Nothing Nothing Nothing
+ (Just [("haddock_datadir", haddockBase)]) Nothing Nothing Nothing
hunk ./tests/golden-tests/runtests.hs 68
- Nothing (Just [("haddock_datadir", "../.")]) Nothing
+ Nothing (Just [("haddock_datadir", haddockBase)]) Nothing
hunk ./tests/golden-tests/runtests.hs 60
- let base = mkDep "base" "4.2.0.0"
+ let base = mkDep "base" "4.2.0.1"
hunk ./src/Haddock/Types.hs 17
-
hunk ./src/Haddock/Types.hs 35
+
hunk ./src/Haddock/Types.hs 49
+
hunk ./src/Haddock/Types.hs 53
+
hunk ./src/Haddock/Types.hs 141
-
hunk ./src/Haddock/Types.hs 261
+
hunk ./src/Haddock/Types.hs 264
+
+
hunk ./src/Haddock/Types.hs 290
-data Example = Example { exampleExpression :: String
- , exampleResult :: [String]
- }
- deriving (Eq, Show)
+
+data Example = Example
+ { exampleExpression :: String
+ , exampleResult :: [String]
+ } deriving (Eq, Show)
+
hunk ./src/Haddock/Types.hs 301
+
hunk ./src/Haddock/Types.hs 366
-type ErrMsg = String
hunk ./src/Haddock/Types.hs 367
+type ErrMsg = String
hunk ./src/Haddock/Types.hs 370
+
hunk ./src/Haddock/Types.hs 374
+
hunk ./src/Haddock/Types.hs 382
+
hunk ./src/Haddock/Types.hs 389
+
hunk ./src/Haddock/Types.hs 402
+
hunk ./src/Haddock/Types.hs 419
+
+
hunk ./src/Haddock/Types.hs 423
+
+
hunk ./src/Haddock/Types.hs 36
--- convenient short-hands
+-- | Convenient short-hand
hunk ./src/Haddock/Backends/Html.hs 12
-
hunk ./src/Haddock/Backends/Xhtml.hs 13
-
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 13
-
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 13
-
hunk ./src/Haddock/Backends/Xhtml/Layout.hs 13
-
hunk ./src/Haddock/Backends/Xhtml/Names.hs 13
-
hunk ./src/Haddock/Backends/Xhtml/Types.hs 13
-
hunk ./src/Haddock/Backends/Xhtml/Util.hs 13
-
hunk ./src/Haddock/Types.hs 35
-
--- | Convenient short-hand
-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
+-----------------------------------------------------------------------------
hunk ./src/Haddock/Types.hs 43
--- | An environment used to create hyper-linked syntax.
-type LinkEnv = Map Name Module
-
-
-type GhcDocHdr = Maybe LHsDocString
+type Decl = LHsDecl Name
+type GhcDocHdr = Maybe LHsDocString
hunk ./src/Haddock/Types.hs 47
--- | 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],
- ghcDynFlags :: DynFlags
-}
+-----------------------------------------------------------------------------
+-- * Interface
+-----------------------------------------------------------------------------
hunk ./src/Haddock/Types.hs 149
-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)
hunk ./src/Haddock/Types.hs 221
+-----------------------------------------------------------------------------
+-- * 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)
+
+
hunk ./src/Haddock/Types.hs 288
+unrenameDoc :: Doc DocName -> Doc Name
+unrenameDoc = fmap getName
+
+
hunk ./src/Haddock/Types.hs 365
+-----------------------------------------------------------------------------
+-- * 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)
+
+
+-----------------------------------------------------------------------------
+-- * Misc.
+-----------------------------------------------------------------------------
+
+
+-- TODO: remove?
+-- | 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],
+ ghcDynFlags :: DynFlags
+}
+
+
+-----------------------------------------------------------------------------
+-- * Error handling
+-----------------------------------------------------------------------------
+
+
hunk ./src/Haddock/Types.hs 31
-#ifdef TEST
-import Test.QuickCheck
-#endif
hunk ./src/Haddock/Types.hs 300
-#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
-
-
-type LDoc id = Located (Doc id)
-
-
hunk ./src/Haddock/Backends/DevHelp.hs 23
+import System.FilePath
hunk ./src/Haddock/Backends/DevHelp.hs 41
- writeFile (pathJoin [odir, devHelpFile]) (render doc)
+ writeFile (joinPath [odir, devHelpFile]) (render doc)
hunk ./src/Haddock/Backends/HH.hs 42
- writeFile (pathJoin [odir, contentsHHFile]) (render html)
+ writeFile (joinPath [odir, contentsHHFile]) (render html)
hunk ./src/Haddock/Backends/HH.hs 105
- writeFile (pathJoin [odir, indexHHFile]) (render html)
+ writeFile (joinPath [odir, indexHHFile]) (render html)
hunk ./src/Haddock/Backends/HH.hs 151
- writeFile (pathJoin [odir, projectHHFile]) (render doc)
+ writeFile (joinPath [odir, projectHHFile]) (render doc)
hunk ./src/Haddock/Backends/HH.hs 176
- | otherwise = pathJoin [path, fname]
+ | otherwise = joinPath [path, fname]
hunk ./src/Haddock/Backends/HH2.hs 46
- writeFile (pathJoin [odir, contentsHH2File]) (render doc)
+ writeFile (joinPath [odir, contentsHH2File]) (render doc)
hunk ./src/Haddock/Backends/HH2.hs 98
- writeFile (pathJoin [odir, indexKHH2File]) (render docK)
- writeFile (pathJoin [odir, indexNHH2File]) (render docN)
+ writeFile (joinPath [odir, indexKHH2File]) (render docK)
+ writeFile (joinPath [odir, indexNHH2File]) (render docN)
hunk ./src/Haddock/Backends/HH2.hs 135
- writeFile (pathJoin [odir, filesHH2File]) (render doc)
+ writeFile (joinPath [odir, filesHH2File]) (render doc)
hunk ./src/Haddock/Backends/HH2.hs 160
- | otherwise = pathJoin [path, fname]
+ | otherwise = joinPath [path, fname]
hunk ./src/Haddock/Backends/HH2.hs 195
- writeFile (pathJoin [odir, collectionHH2File]) (render doc)
+ writeFile (joinPath [odir, collectionHH2File]) (render doc)
hunk ./src/Haddock/Backends/Html.hs 40
+import System.FilePath hiding ( () )
hunk ./src/Haddock/Backends/Html.hs 142
- libhtmldir = pathJoin [libdir, "html"]
+ libhtmldir = joinPath [libdir, "html"]
hunk ./src/Haddock/Backends/Html.hs 144
- Nothing -> pathJoin [libhtmldir, cssFile]
+ Nothing -> joinPath [libhtmldir, cssFile]
hunk ./src/Haddock/Backends/Html.hs 146
- css_destination = pathJoin [odir, cssFile]
+ css_destination = joinPath [odir, cssFile]
hunk ./src/Haddock/Backends/Html.hs 148
- copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f])
+ copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
hunk ./src/Haddock/Backends/Html.hs 331
- writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html)
+ writeFile (joinPath [odir, contentsHtmlFile]) (renderHtml html)
hunk ./src/Haddock/Backends/Html.hs 449
- writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderHtml html)
+ writeFile (joinPath [odir, frameIndexHtmlFile]) (renderHtml html)
hunk ./src/Haddock/Backends/Html.hs 481
- writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html)
+ writeFile (joinPath [odir, indexHtmlFile]) (renderHtml html)
hunk ./src/Haddock/Backends/Html.hs 532
- writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html)
+ writeFile (joinPath [odir, subIndexHtmlFile c]) (renderHtml html)
hunk ./src/Haddock/Backends/Html.hs 629
- writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html)
+ writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderHtml html)
hunk ./src/Haddock/Backends/Html.hs 646
- writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderHtml html)
+ writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderHtml html)
hunk ./src/Haddock/Backends/Xhtml.hs 47
+import System.FilePath hiding ( () )
hunk ./src/Haddock/Backends/Xhtml.hs 144
- libhtmldir = pathJoin [libdir, "html"]
+ libhtmldir = joinPath [libdir, "html"]
hunk ./src/Haddock/Backends/Xhtml.hs 146
- Nothing -> pathJoin [libhtmldir, 'x':cssFile]
+ Nothing -> joinPath [libhtmldir, 'x':cssFile]
hunk ./src/Haddock/Backends/Xhtml.hs 148
- css_destination = pathJoin [odir, cssFile]
+ css_destination = joinPath [odir, cssFile]
hunk ./src/Haddock/Backends/Xhtml.hs 150
- copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f])
+ copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
hunk ./src/Haddock/Backends/Xhtml.hs 280
- writeFile (pathJoin [odir, contentsHtmlFile]) (renderToString html)
+ writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html)
hunk ./src/Haddock/Backends/Xhtml.hs 396
- writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderToString html)
+ writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)
hunk ./src/Haddock/Backends/Xhtml.hs 428
- writeFile (pathJoin [odir, indexHtmlFile]) (renderToString html)
+ writeFile (joinPath [odir, indexHtmlFile]) (renderToString html)
hunk ./src/Haddock/Backends/Xhtml.hs 484
- writeFile (pathJoin [odir, subIndexHtmlFile c]) (renderToString html)
+ writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString html)
hunk ./src/Haddock/Backends/Xhtml.hs 582
- writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderToString html)
+ writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html)
hunk ./src/Haddock/Backends/Xhtml.hs 599
- writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)
+ writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)
hunk ./src/Haddock/Utils.hs 24
- subIndexHtmlFile, pathJoin,
+ subIndexHtmlFile,
hunk ./src/Haddock/Utils.hs 175
- Just fp0 -> pathJoin [fp0, mdl' ++ ".html"]
+ Just fp0 -> joinPath [fp0, mdl' ++ ".html"]
hunk ./src/Haddock/Utils.hs 214
-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
-
-
hunk ./src/Haddock/Options.hs 18
+ optTitle,
+ outputDir,
+ optContentsUrl,
+ optIndexUrl,
+ optHtmlHelpFormat,
+ optCssFile,
+ optSourceUrls,
+ optWikiUrls,
hunk ./src/Haddock/Options.hs 31
+import Data.Maybe
hunk ./src/Haddock/Options.hs 55
+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 ]
+
+
+optHtmlHelpFormat :: [Flag] -> Maybe String
+optHtmlHelpFormat flags = optLast [ hhformat | Flag_HtmlHelp hhformat <- flags ]
+
+
+optCssFile :: [Flag] -> Maybe FilePath
+optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
+
+
+optSourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+optSourceUrls flags =
+ (listToMaybe [str | Flag_SourceBaseURL str <- flags]
+ ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
+ ,listToMaybe [str | Flag_SourceEntityURL str <- flags])
+
+
+optWikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+optWikiUrls flags =
+ (listToMaybe [str | Flag_WikiBaseURL str <- flags]
+ ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
+ ,listToMaybe [str | Flag_WikiEntityURL str <- flags])
+
+
hunk ./src/Haddock/Options.hs 225
+
+
+-- | Like 'listToMaybe' but returns the last element instead of the first.
+optLast :: [a] -> Maybe a
+optLast [] = Nothing
+optLast xs = Just (last xs)
+
hunk ./src/Main.hs 7
--- David Waern 2006-2009
+-- David Waern 2006-2010
hunk ./src/Main.hs 170
- let
- title = case [str | Flag_Heading str <- flags] of
- [] -> ""
- (t:_) -> t
-
- maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags]
- ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
- ,listToMaybe [str | Flag_SourceEntityURL str <- flags])
-
- maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL str <- flags]
- ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
- ,listToMaybe [str | Flag_WikiEntityURL str <- flags])
-
- libDir <- 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)
hunk ./src/Main.hs 172
- 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)
+ title = case optTitle flags of Nothing -> ""; Just t -> t
+ unicode = Flag_UseUnicode `elem` flags
+ opt_source_urls = optSourceUrls flags
+ opt_wiki_urls = optWikiUrls flags
+ opt_contents_url = optContentsUrl flags
+ opt_index_url = optIndexUrl flags
+ opt_html_help_format = optHtmlHelpFormat flags
+ css_file = optCssFile flags
+ odir = outputDir flags
hunk ./src/Main.hs 182
- maybe_html_help_format =
- case [hhformat | Flag_HtmlHelp hhformat <- flags] of
- [] -> Nothing
- formats -> Just (last formats)
-
- prologue <- getPrologue flags
-
- let
hunk ./src/Main.hs 199
+
+ libDir <- getHaddockLibDir flags
+ prologue <- getPrologue flags
hunk ./src/Main.hs 204
- ppHtmlIndex odir title packageStr maybe_html_help_format
- maybe_contents_url maybe_source_urls maybe_wiki_urls
+ ppHtmlIndex odir title packageStr opt_html_help_format
+ opt_contents_url opt_source_urls opt_wiki_urls
hunk ./src/Main.hs 210
- ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format []
+ ppHtmlHelpFiles title packageStr visibleIfaces odir opt_html_help_format []
hunk ./src/Main.hs 213
- ppHtmlContents odir title packageStr maybe_html_help_format
- maybe_index_url maybe_source_urls maybe_wiki_urls
+ ppHtmlContents odir title packageStr opt_html_help_format
+ opt_index_url opt_source_urls opt_wiki_urls
hunk ./src/Main.hs 220
- prologue maybe_html_help_format
- maybe_source_urls maybe_wiki_urls
- maybe_contents_url maybe_index_url unicode
+ prologue opt_html_help_format
+ opt_source_urls opt_wiki_urls
+ opt_contents_url opt_index_url unicode
hunk ./src/Haddock/Options.hs 37
-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 ]
-
-
-optHtmlHelpFormat :: [Flag] -> Maybe String
-optHtmlHelpFormat flags = optLast [ hhformat | Flag_HtmlHelp hhformat <- flags ]
-
-
-optCssFile :: [Flag] -> Maybe FilePath
-optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
-
-
-optSourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
-optSourceUrls flags =
- (listToMaybe [str | Flag_SourceBaseURL str <- flags]
- ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
- ,listToMaybe [str | Flag_SourceEntityURL str <- flags])
-
-
-optWikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
-optWikiUrls flags =
- (listToMaybe [str | Flag_WikiBaseURL str <- flags]
- ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
- ,listToMaybe [str | Flag_WikiEntityURL str <- flags])
-
-
-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)
-
-
hunk ./src/Haddock/Options.hs 150
+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 ]
+
+
+optHtmlHelpFormat :: [Flag] -> Maybe String
+optHtmlHelpFormat flags = optLast [ hhformat | Flag_HtmlHelp hhformat <- flags ]
+
+
+optCssFile :: [Flag] -> Maybe FilePath
+optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
+
+
+optSourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+optSourceUrls flags =
+ (listToMaybe [str | Flag_SourceBaseURL str <- flags]
+ ,listToMaybe [str | Flag_SourceModuleURL str <- flags]
+ ,listToMaybe [str | Flag_SourceEntityURL str <- flags])
+
+
+optWikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+optWikiUrls flags =
+ (listToMaybe [str | Flag_WikiBaseURL str <- flags]
+ ,listToMaybe [str | Flag_WikiModuleURL str <- flags]
+ ,listToMaybe [str | Flag_WikiEntityURL str <- flags])
+
+
+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)
+
+
hunk ./src/Haddock/Options.hs 34
-import System.Console.GetOpt
+import System.Console.GetOpt
hunk ./src/Haddock/Options.hs 79
- 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")
+ "interface file name",
hunk ./src/Haddock/Options.hs 90
--- "output in DocBook XML",
+-- "output in DocBook XML",
hunk ./src/Haddock/Options.hs 92
- "output in HTML",
- Option [] ["xhtml"] (NoArg Flag_Xhtml) "use experimental XHTML rendering",
+ "output in HTML",
+ Option [] ["xhtml"] (NoArg Flag_Xhtml) "use experimental XHTML rendering",
hunk ./src/Haddock/Options.hs 96
- "output for Hoogle",
+ "output for Hoogle",
hunk ./src/Haddock/Options.hs 98
- "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",
+ "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",
hunk ./src/Haddock/Options.hs 102
- (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)",
hunk ./src/Haddock/Options.hs 107
- "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"] (ReqArg Flag_CSS "FILE")
+ "the CSS file to use for HTML output",
hunk ./src/Haddock/Options.hs 115
- "file containing prologue text",
+ "file containing prologue text",
hunk ./src/Haddock/Options.hs 117
- "page heading",
+ "page heading",
hunk ./src/Haddock/Options.hs 119
- "extra debugging output",
+ "extra debugging output",
hunk ./src/Haddock/Options.hs 121
- "display this help and exit",
+ "display this help and exit",
hunk ./src/Haddock/Options.hs 123
- "output version information and exit",
+ "output version information and exit",
hunk ./src/Haddock/Options.hs 125
- "set verbosity level",
+ "set verbosity level",
hunk ./src/Haddock/Options.hs 127
- "use a separately-generated HTML contents page",
+ "use a separately-generated HTML contents page",
hunk ./src/Haddock/Options.hs 129
- "generate an HTML contents from specified\ninterfaces",
+ "generate an HTML contents from specified\ninterfaces",
hunk ./src/Haddock/Options.hs 131
- "use a separately-generated HTML index",
+ "use a separately-generated HTML index",
hunk ./src/Haddock/Options.hs 133
- "generate an HTML index from specified\ninterfaces",
+ "generate an HTML index from specified\ninterfaces",
hunk ./src/Haddock/Options.hs 135
- "behave as if all modules have the\nignore-exports atribute",
+ "behave as if all modules have the\nignore-exports atribute",
hunk ./src/Haddock/Options.hs 137
- "behave as if MODULE has the hide attribute",
+ "behave as if MODULE has the hide attribute",
hunk ./src/Haddock/Options.hs 139
- "option to be forwarded to GHC",
+ "option to be forwarded to GHC",
hunk ./src/Haddock/Options.hs 141
- "output GHC version in numeric format",
+ "output GHC version in numeric format",
hunk ./src/Haddock/Options.hs 143
- "output GHC lib dir",
+ "output GHC lib dir",
hunk ./src/Haddock/Options.hs 146
- "don't re-direct compilation output to a temporary directory"
- ]
+ "don't re-direct compilation output to a temporary directory"
+ ]
hunk ./src/Haddock/Options.hs 163
- (_, _, errors) -> do
+ (_, _, errors) -> do
hunk ./src/Haddock/Options.hs 168
-optTitle :: [Flag] -> Maybe String
+optTitle :: [Flag] -> Maybe String
hunk ./src/Haddock/Options.hs 176
-outputDir flags =
+outputDir flags =
hunk ./src/Haddock/Options.hs 221
-parseIfaceOption s =
+parseIfaceOption s =
hunk ./src/Haddock/Options.hs 223
- (fpath,',':file) -> (fpath, file)
- (file, _) -> ("", file)
+ (fpath,',':file) -> (fpath, file)
+ (file, _) -> ("", file)
hunk ./src/Main.hs 194
- ppHtmlIndex = pick Html.ppHtmlIndex Xhtml.ppHtmlIndex
- ppHtmlHelpFiles = pick Html.ppHtmlHelpFiles Xhtml.ppHtmlHelpFiles
- ppHtmlContents = pick Html.ppHtmlContents Xhtml.ppHtmlContents
- ppHtml = pick Html.ppHtml Xhtml.ppHtml
- copyHtmlBits = pick Html.copyHtmlBits Xhtml.copyHtmlBits
-
+ ppHtmlIndex = pick Html.ppHtmlIndex Xhtml.ppHtmlIndex
+ ppHtmlHelpFiles = pick Html.ppHtmlHelpFiles Xhtml.ppHtmlHelpFiles
+ ppHtmlContents = pick Html.ppHtmlContents Xhtml.ppHtmlContents
+ ppHtml = pick Html.ppHtml Xhtml.ppHtml
+ copyHtmlBits = pick Html.copyHtmlBits Xhtml.copyHtmlBits
+
hunk ./src/Haddock/Interface.hs 39
-import Haddock.Options
+import Haddock.Options hiding (verbosity)
hunk ./src/Haddock/Options.hs 26
+ optDumpInterfaceFile,
+ verbosity,
hunk ./src/Haddock/Options.hs 34
+import Distribution.Verbosity
hunk ./src/Haddock/Options.hs 215
+optDumpInterfaceFile :: [Flag] -> Maybe FilePath
+optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface 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
+
+
hunk ./src/Haddock/Options.hs 234
-
-
-parseIfaceOption :: String -> (FilePath, FilePath)
-parseIfaceOption s =
- case break (==',') s of
- (fpath,',':file) -> (fpath, file)
- (file, _) -> ("", file)
+ where
+ parseIfaceOption :: String -> (FilePath, FilePath)
+ parseIfaceOption str =
+ case break (==',') str of
+ (fpath, ',':file) -> (fpath, file)
+ (file, _) -> ("", file)
hunk ./src/Main.hs 42
-import Distribution.Verbosity
hunk ./src/Main.hs 124
- verbosity <- getVerbosity flags
hunk ./src/Main.hs 148
- (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags
- (map fst packages)
+ (ifaces, homeLinks) <- createInterfaces (verbosity flags) fileArgs flags
+ (map fst packages)
hunk ./src/Main.hs 152
- renderStep packages interfaces
+ renderStep packages ifaces
hunk ./src/Main.hs 154
- -- Last but not least, dump the interface file.
- dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags
+ -- Dump an "interface file" (.haddock file), if requested.
+ case optDumpInterfaceFile flags of
+ Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+ Nothing -> return ()
hunk ./src/Main.hs 255
-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
hunk ./src/Main.hs 330
-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
-
-
hunk ./src/Main.hs 125
- let renderStep packages interfaces = do
- updateHTMLXRefs packages
- let ifaceFiles = map fst packages
- installedIfaces = concatMap ifInstalledIfaces ifaceFiles
- render flags interfaces installedIfaces
-
hunk ./src/Main.hs 127
-
hunk ./src/Main.hs 145
- renderStep packages ifaces
+ renderStep flags packages ifaces
hunk ./src/Main.hs 157
- renderStep packages []
+ renderStep flags packages []
+
+
+renderStep :: [Flag] -> [(InterfaceFile, FilePath)] -> [Interface] -> IO ()
+renderStep flags packages interfaces = do
+ updateHTMLXRefs packages
+ let ifaceFiles = map fst packages
+ installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+ render flags interfaces installedIfaces
hunk ./src/Main.hs 193
- -- which HTML redering to use
+ -- which HTML rendering to use
hunk ./src/Main.hs 185
- -- *all* visible interfaces including external package modules
+ -- *All* visible interfaces including external package modules.
hunk ./src/Main.hs 193
- -- which HTML rendering to use
+ -- Which HTML rendering to use.
hunk ./src/Haddock/Options.hs 91
- "interface file name",
+ "write the resulting interface to FILE",
hunk ./src/Haddock/Options.hs 149
- "don't re-direct compilation output to a temporary directory"
+ "do not re-direct compilation output to a temporary directory"
hunk ./src/Main.hs 173
- title = case optTitle flags of Nothing -> ""; Just t -> t
+ title = fromMaybe "" (optTitle flags)
hunk ./src/Main.hs 194
- pick htmlF xhtmlF = if (Flag_Xhtml `elem` flags) then xhtmlF else htmlF
+ pick htmlF xhtmlF = if Flag_Xhtml `elem` flags then xhtmlF else htmlF
hunk ./src/Main.hs 185
- -- *All* visible interfaces including external package modules.
+ -- /All/ visible interfaces including external package modules.
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 747
-ppBang HsStrict = toHtml "!"
-ppBang HsUnbox = toHtml "!" -- unboxed args is an implementation detail,
+ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
hunk ./src/Main.hs 371
- Nothing -> throwE "parsing haddock prologue failed"
+ Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename
hunk ./src/Haddock/Utils.hs 77
-#else /* Must be Win32 */
-import Foreign
-import Foreign.C.String
hunk ./src/Haddock/Lex.x 187
- pstate = mkPState buffer noSrcLoc dflags
+ pstate = mkPState dflags buffer noSrcLoc
hunk ./src/Main.hs 370
- case parseParas (tokenise defaultDynFlags str (0,0) {- TODO: real position -}) of
+ case parseParas (tokenise (flattenLanguageFlags defaultDynFlags) str (0,0) {- TODO: real position -}) of
hunk ./src/Main.hs 370
- case parseParas (tokenise (flattenLanguageFlags defaultDynFlags) str (0,0) {- TODO: real position -}) of
+ case parseParas (tokenise (flattenExtensionFlags defaultDynFlags) str (0,0) {- TODO: real position -}) of
hunk ./src/Haddock/Interface/Create.hs 563
- 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
+
hunk ./src/Haddock/Interface/Rn.hs 45
- [] -> return (DocString (ids2string ids))
+ [] -> return (DocMonospaced (DocString (ids2string ids)))
hunk ./doc/haddock.xml 13
- simonmar@microsoft.com
+ marlowsd@gmail.com
+
+ David
+ Waern
+
+ david.waern@gmail.com
hunk ./doc/haddock.xml 20
- 2004
- Simon Marlow
+ 2010
+ Simon Marlow, David Waern
hunk ./doc/haddock.xml 101
- and printed, for example. Haddock comes with HTML, DocBook
+ and printed, for example. Haddock comes with HTML, LaTeX,
hunk ./doc/haddock.xml 653
- Specify a stylesheet to use instead of the default one
+ Specify a CSS stylesheet to use instead of the default one
hunk ./doc/haddock.xml 659
+
+
+
+
+
+
+ Generate documentation in LaTeX format. Several files
+ will be generated into the current directory (or the
+ specified directory if the option is
+ given), including the following:
+
+
+
+ package.tex
+
+ The top-level LaTeX source file; to format the
+ documentation into PDF you might run something like
+ this:
+
+$ pdflatex package.tex
+
+
+
+ haddock.sty
+
+ The default style. The file contains
+ definitions for various macros used in the LaTeX
+ sources generated by Haddock; to change the way the
+ formatted output looks, you might want to override
+ these by specifying your own style with
+ the option.
+
+
+
+ module.tex
+
+ The LaTeX documentation for
+ each module.
+
+
+
+
+
+
+
+
+
+
+
+
+ This option lets you override the default style used
+ by the LaTeX generated by the option.
+ Normally Haddock puts a
+ standard haddock.sty in the output
+ directory, and includes the
+ command \usepackage{haddock} in the
+ LaTeX source. If this option is given,
+ then haddock.sty is not generated,
+ and the command is
+ instead \usepackage{style}.
+
+
+
+
hunk ./ghc.mk 12
-$(INPLACE_BIN)/$(utils/haddock_dist_PROG): $(INPLACE_LIB)/html
+$(INPLACE_BIN)/$(utils/haddock_dist_PROG): $(INPLACE_LIB)/html $(INPLACE_LIB)/latex
hunk ./ghc.mk 18
+$(INPLACE_LIB)/latex:
+ "$(RM)" $(RM_OPTS_REC) $@
+ "$(CP)" -R utils/haddock/latex $@
+
hunk ./haddock.cabal 60
+ latex/haddock.sty
hunk ./haddock.cabal 121
+ Haddock.Backends.LaTeX
adddir ./latex
addfile ./latex/haddock.sty
hunk ./latex/haddock.sty 1
+% 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}
addfile ./src/Haddock/Backends/LaTeX.hs
hunk ./src/Haddock/Backends/LaTeX.hs 1
+{-# 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 = "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
+ xs -> 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 False
+ ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode
+ InstD _ -> empty
+ _ -> error "declaration not supported by ppDecl"
+ where
+ unicode = False
+
+ppTyFam _ _ _ _ _ =
+ error "type family declarations are currently not supported by --latex"
+
+ppDataInst _ _ _ =
+ error "data instance declarations are currently not supported by --latex"
+
+ppTyInst _ _ _ _ _ =
+ error "type instance declarations are currently not supported by --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 False
+ 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 -> Bool
+ -> LaTeX
+ppFunSig loc doc docname typ unicode methods =
+ ppTypeOrFunSig loc docname typ doc
+ (ppTypeSig name typ False, ppSymName name, dcolon unicode)
+ unicode methods
+ where
+ name = getName docname
+
+ppTypeOrFunSig :: SrcSpan -> DocName -> HsType DocName ->
+ DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
+ -> Bool -> Bool -> LaTeX
+ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0)
+ unicode methods
+ | 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
+ decl@(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"
+
+ nm = unLoc $ tcdLName decl
+
+ 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
+
+ methodTable =
+ text "\\haddockpremethods{}\\textbf{Methods}" $$
+ vcat [ ppFunSig loc doc n typ unicode True
+ | 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
+ | null instances = empty
+ | all (isNothing . snd) instances =
+ declWithDoc (vcat (map (ppInstDecl unicode) (map fst instances))) Nothing
+ | otherwise = vcat (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 -> 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
+ docname = unLoc . tcdLName $ dataDecl
+ 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
+ | null instances = empty
+ | all (isNothing . snd) instances =
+ declWithDoc (vcat (map (ppInstDecl unicode) (map fst instances))) Nothing
+ | otherwise = vcat (map (ppDocInstance unicode) instances)
+
+isRecCon :: Located (ConDecl a) -> Bool
+isRecCon lcon = case con_details (unLoc lcon) of
+ RecCon _ -> True
+ _ -> False
+
+
+-- 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
+
+ppVerbBinder :: OccName -> LaTeX
+ppVerbBinder n
+ | isVarSym n = parens $ ppVerbOccName n
+ | otherwise = ppVerbOccName 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
+
+ppVerbDocBinder :: DocName -> LaTeX
+ppVerbDocBinder = ppVerbBinder . docNameOcc
+
+ppName :: Name -> LaTeX
+ppName = ppOccName . nameOccName
+
+ppVerbName :: Name -> LaTeX
+ppVerbName = ppVerbOccName . nameOccName
+
+latexFilter :: String -> String
+latexFilter = foldr latexMunge ""
+
+latexMonoFilter :: String -> String
+latexMonoFilter = foldr latexMonoMunge ""
+
+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 ' ' 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 v -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
+ markupEmphasis = \p v -> emph (p v),
+ markupMonospaced = \p v -> tt (p Mono),
+ markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
+ markupPic = \path v -> 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
+
+latexStripLeadingPara :: Doc a -> Doc a
+latexStripLeadingPara (DocParagraph p) = p
+latexStripLeadingPara (DocAppend l r) = DocAppend (latexStripLeadingPara l) r
+latexStripLeadingPara d = d
+
+-- -----------------------------------------------------------------------------
+-- 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
hunk ./src/Haddock/Options.hs 27
+ optLaTeXStyle,
hunk ./src/Haddock/Options.hs 61
+ | Flag_LaTeX
+ | Flag_LaTeXStyle String
hunk ./src/Haddock/Options.hs 100
+ Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
+ Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
hunk ./src/Haddock/Options.hs 224
+optLaTeXStyle :: [Flag] -> Maybe String
+optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
+
hunk ./src/Haddock/Utils.hs 40
+ spanWith,
hunk ./src/Haddock/Utils.hs 329
+spanWith :: (a -> Maybe b) -> [a] -> ([b],[a])
+spanWith p [] = ([],[])
+spanWith p xs@(a:as)
+ | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)
+ | otherwise = ([],xs)
hunk ./src/Main.hs 23
+import qualified Haddock.Backends.LaTeX as LaTeX
hunk ./src/Main.hs 183
+ opt_latex_style = optLaTeXStyle flags
hunk ./src/Main.hs 232
+ when (Flag_LaTeX `elem` flags) $ do
+ LaTeX.ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style
+ libDir
hunk ./src/Haddock/Backends/LaTeX.hs 12
-
-module Haddock.Backends.LaTeX (
+module Haddock.Backends.LaTeX (
hunk ./src/Haddock/Backends/LaTeX.hs 16
+
hunk ./src/Haddock/Backends/LaTeX.hs 74
-ppLaTeX :: String -- Title
+ppLaTeX :: String -- Title
hunk ./src/Haddock/Backends/LaTeX.hs 76
- -> [Interface]
- -> FilePath -- destination directory
- -> Maybe (Doc GHC.RdrName) -- prologue text, maybe
+ -> [Interface]
+ -> FilePath -- destination directory
+ -> Maybe (Doc GHC.RdrName) -- prologue text, maybe
hunk ./src/Haddock/Backends/LaTeX.hs 81
- -> IO ()
+ -> IO ()
hunk ./src/Haddock/Backends/LaTeX.hs 86
- when (isNothing maybe_style) $
+ when (isNothing maybe_style) $
hunk ./src/Haddock/Backends/LaTeX.hs 175
- case subdocs of
+ case subdocs of
hunk ./src/Haddock/Backends/LaTeX.hs 193
- = multiDecl [ ppTypeSig (getName name) typ False
+ = multiDecl [ ppTypeSig (getName name) typ False
hunk ./src/Haddock/Backends/LaTeX.hs 250
-moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
+moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
hunk ./src/Haddock/Backends/LaTeX.hs 266
- | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d
+ | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d
hunk ./src/Haddock/Backends/LaTeX.hs 275
- where
+ where
hunk ./src/Haddock/Backends/LaTeX.hs 278
-ppTyFam _ _ _ _ _ =
+ppTyFam _ _ _ _ _ =
hunk ./src/Haddock/Backends/LaTeX.hs 297
- = ppTypeOrFunSig loc name (unLoc ltype) doc
+ = ppTypeOrFunSig loc name (unLoc ltype) doc
hunk ./src/Haddock/Backends/LaTeX.hs 321
-ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0)
+ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0)
hunk ./src/Haddock/Backends/LaTeX.hs 323
- | Map.null argDocs =
+ | Map.null argDocs =
hunk ./src/Haddock/Backends/LaTeX.hs 325
- | otherwise =
+ | otherwise =
hunk ./src/Haddock/Backends/LaTeX.hs 332
- do_largs n leader (L _ t) = do_args n leader t
+ do_largs n leader (L _ t) = do_args n leader t
hunk ./src/Haddock/Backends/LaTeX.hs 342
-
+
hunk ./src/Haddock/Backends/LaTeX.hs 358
-ppTypeSig nm ty unicode =
+ppTypeSig nm ty unicode =
hunk ./src/Haddock/Backends/LaTeX.hs 372
- text "\\end{tabular}]" <>
+ text "\\end{tabular}]" <>
hunk ./src/Haddock/Backends/LaTeX.hs 408
-ppClassHdr summ lctxt n tvs fds unicode =
- keyword "class"
+ppClassHdr summ lctxt n tvs fds unicode =
+ keyword "class"
hunk ./src/Haddock/Backends/LaTeX.hs 412
- <+> ppFds fds unicode
+ <+> ppFds fds unicode
hunk ./src/Haddock/Backends/LaTeX.hs 417
- if null fds then empty else
- char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+ if null fds then empty else
+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
hunk ./src/Haddock/Backends/LaTeX.hs 420
- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
- hsep (map ppDocName vars2)
+ fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
+ hsep (map ppDocName vars2)
hunk ./src/Haddock/Backends/LaTeX.hs 428
- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 431
- where
+ where
hunk ./src/Haddock/Backends/LaTeX.hs 439
-
+
hunk ./src/Haddock/Backends/LaTeX.hs 494
-
+
hunk ./src/Haddock/Backends/LaTeX.hs 502
- resTy = (con_res . unLoc . head) cons
-
+ resTy = (con_res . unLoc . head) cons
+
hunk ./src/Haddock/Backends/LaTeX.hs 508
- | otherwise = case resTy of
+ | otherwise = case resTy of
hunk ./src/Haddock/Backends/LaTeX.hs 512
- constrBit
+ constrBit
hunk ./src/Haddock/Backends/LaTeX.hs 516
- vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
+ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
hunk ./src/Haddock/Backends/LaTeX.hs 526
-isRecCon lcon = case con_details (unLoc lcon) of
+isRecCon lcon = case con_details (unLoc lcon) of
hunk ./src/Haddock/Backends/LaTeX.hs 542
- ppForall = case forall of
+ ppForall = case forall of
hunk ./src/Haddock/Backends/LaTeX.hs 548
-ppSideBySideConstr subdocs unicode leader (L _ con) =
+ppSideBySideConstr subdocs unicode leader (L _ con) =
hunk ./src/Haddock/Backends/LaTeX.hs 550
- case con_res con of
- ResTyH98 -> case con_details con of
+ case con_res con of
+ ResTyH98 -> case con_details con of
hunk ./src/Haddock/Backends/LaTeX.hs 553
- PrefixCon args ->
- decltt (hsep ((header_ unicode <+> ppBinder occ) :
+ PrefixCon args ->
+ decltt (hsep ((header_ unicode <+> ppBinder occ) :
hunk ./src/Haddock/Backends/LaTeX.hs 558
- RecCon fields ->
+ RecCon fields ->
hunk ./src/Haddock/Backends/LaTeX.hs 564
- InfixCon arg1 arg2 ->
- decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
- ppBinder occ,
+ InfixCon arg1 arg2 ->
+ decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
+ ppBinder occ,
hunk ./src/Haddock/Backends/LaTeX.hs 569
-
+
hunk ./src/Haddock/Backends/LaTeX.hs 576
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
hunk ./src/Haddock/Backends/LaTeX.hs 578
- where
+ where
hunk ./src/Haddock/Backends/LaTeX.hs 659
- | otherwise =
+ | otherwise =
hunk ./src/Haddock/Backends/LaTeX.hs 661
- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
+ (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>
hunk ./src/Haddock/Backends/LaTeX.hs 675
-ppTyClBinderWithVars summ decl =
+ppTyClBinderWithVars summ decl =
hunk ./src/Haddock/Backends/LaTeX.hs 691
-ppAppDocNameNames _summ n ns =
+ppAppDocNameNames _summ n ns =
hunk ./src/Haddock/Backends/LaTeX.hs 708
--- Contexts
+-- Contexts
hunk ./src/Haddock/Backends/LaTeX.hs 751
-ppBang HsNoBang = empty
+ppBang HsNoBang = empty
hunk ./src/Haddock/Backends/LaTeX.hs 756
-tupleParens Unboxed = ubxParenList
+tupleParens Unboxed = ubxParenList
hunk ./src/Haddock/Backends/LaTeX.hs 759
--- Rendering of HsType
---
+-- Rendering of HsType
+--
hunk ./src/Haddock/Backends/LaTeX.hs 782
-ppLParendType unicode y = ppParendType unicode (unLoc y)
+ppLParendType unicode y = ppParendType unicode (unLoc y)
hunk ./src/Haddock/Backends/LaTeX.hs 787
-ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
+ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
+ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
hunk ./src/Haddock/Backends/LaTeX.hs 807
- forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
hunk ./src/Haddock/Backends/LaTeX.hs 811
-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 815
-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 836
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 840
-ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 847
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 851
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
hunk ./src/Haddock/Backends/LaTeX.hs 855
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
hunk ./src/Haddock/Backends/LaTeX.hs 942
- markupEmpty = \_ -> empty,
+ markupEmpty = \_ -> empty,
hunk ./src/Haddock/Backends/LaTeX.hs 954
- markupURL = \u _ -> text "\\url" <> braces (text u),
- markupAName = \_ _ -> empty,
+ markupURL = \u _ -> text "\\url" <> braces (text u),
+ markupAName = \_ _ -> empty,
hunk ./src/Haddock/Backends/LaTeX.hs 963
- markupId id v =
+ markupId id v =
hunk ./src/Haddock/Backends/LaTeX.hs 1005
-latexStripTrailingWhitespace (DocParagraph p) =
+latexStripTrailingWhitespace (DocParagraph p) =
hunk ./src/Haddock/Backends/LaTeX.hs 1018
-itemizedList items =
+itemizedList items =
hunk ./src/Haddock/Backends/LaTeX.hs 1024
-enumeratedList items =
+enumeratedList items =
hunk ./src/Haddock/Backends/LaTeX.hs 1030
-descriptionList items =
+descriptionList items =
hunk ./tests/golden-tests/runtests.hs 60
- let base = mkDep "base" "4.2.0.1"
- process = mkDep "process" "1.0.1.2"
+ let base = mkDep "base" "4.2.0.2"
+ process = mkDep "process" "1.0.1.3"
hunk ./tests/golden-tests/tests/NoLayout.html.ref 100
->the class C
+>the class C
hunk ./src/Haddock/Utils.hs 330
-spanWith p [] = ([],[])
+spanWith _ [] = ([],[])
hunk ./src/Haddock/Interface/AttachInstances.hs 41
+ -- TODO: take an IfaceMap as input
+ ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
+
hunk ./src/Haddock/Interface/AttachInstances.hs 45
- newItems <- mapM attachExport $ ifaceExportItems iface
+ newItems <- mapM (attachToExportItem iface ifaceMap instIfaceMap)
+ (ifaceExportItems iface)
hunk ./src/Haddock/Interface/AttachInstances.hs 48
- 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 -> []
hunk ./src/Haddock/Interface/AttachInstances.hs 66
- attachExport export = return export
+ return export'
+ _ -> return export
hunk ./src/Haddock/Interface/AttachInstances.hs 70
-lookupInstDoc :: Name -> Interface -> InstIfaceMap -> Maybe (Doc Name)
+lookupInstDoc :: Name -> Interface -> IfaceMap -> InstIfaceMap -> Maybe (Doc Name)
hunk ./src/Haddock/Interface/AttachInstances.hs 73
-lookupInstDoc name iface ifaceMap =
+lookupInstDoc name iface ifaceMap instIfaceMap =
hunk ./src/Haddock/Interface/AttachInstances.hs 76
- 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
hunk ./haddock.cabal 188
+ Haddock.Backends.LaTeX
hunk ./src/Haddock/Backends/Xhtml/Decl.hs 13
+
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 13
+
hunk ./src/Haddock/Backends/Xhtml/Layout.hs 13
+
hunk ./src/Haddock/Backends/Xhtml/Names.hs 13
+
hunk ./src/Haddock/Backends/Xhtml/Types.hs 13
+
hunk ./src/Haddock/Backends/Xhtml/Util.hs 13
+
hunk ./html/xhaddock.css 52
+ul, ol, dl {
+ padding-top: 2px;
+ padding-left: 3em;
+ margin-bottom: 1em;
+}
+
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 31
- markupParagraph = paragraph,
- markupEmpty = toHtml "",
+ markupEmpty = noHtml,
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 33
+ markupParagraph = paragraph,
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 36
- 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,
+ markupModule = \m -> let (mdl,ref) = break (=='#') m
+ in ppModule (mkModuleNoPackage mdl) ref,
+ markupEmphasis = emphasize,
+ markupMonospaced = tt,
+ markupUnorderedList = unordList,
+ markupOrderedList = ordList,
+ markupDefList = defList,
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 45
- markupAName = \aname -> namedAnchor aname << toHtml "",
- markupExample = examplesToHtml
+ markupAName = \aname -> namedAnchor aname << toHtml ""
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 68
-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
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 70
--- ugly extra whitespace with some browsers).
+-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 72
-docToHtml doc = markup htmlMarkup (markup htmlCleanup doc)
+docToHtml = markup fmt . cleanup
+ where fmt = parHtmlMarkup ppDocName (isTyConName . getName)
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 76
-origDocToHtml doc = markup htmlOrigMarkup (markup htmlCleanup doc)
+origDocToHtml = markup fmt . cleanup
+ where fmt = parHtmlMarkup ppName isTyConName
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 80
-rdrDocToHtml doc = markup htmlRdrMarkup (markup htmlCleanup doc)
+rdrDocToHtml = markup fmt . cleanup
+ where fmt = parHtmlMarkup ppRdrName isRdrTc
+
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 84
--- If there is a single paragraph, then surrounding it with
..
--- can add too much whitespace in some browsers (eg. IE). However if
--- we have multiple paragraphs, then we want the extra whitespace to
--- separate them. So we catch the single paragraph case and transform it
--- here.
-unParagraph :: Doc a -> Doc a
-unParagraph (DocParagraph d) = d
---NO: This eliminates line breaks in the code block: (SDM, 6/5/2003)
---unParagraph (DocCodeBlock d) = (DocMonospaced d)
-unParagraph doc = doc
hunk ./src/Haddock/Backends/Xhtml/DocMarkup.hs 85
-htmlCleanup :: DocMarkup a (Doc a)
-htmlCleanup = idMarkup {
- markupUnorderedList = DocUnorderedList . map unParagraph,
- markupOrderedList = DocOrderedList . map unParagraph
- }
+cleanup :: Doc a -> Doc a
+cleanup = markup fmtUnParagraphLists
+ where
+ -- If there is a single paragraph, then surrounding it with
(this causes
--- ugly extra whitespace with some browsers).
-docToHtml :: Doc DocName -> Html
-docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc))
-
-origDocToHtml :: Doc Name -> Html
-origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc))
-
-rdrDocToHtml :: Doc RdrName -> Html
-rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc))
-
--- If there is a single paragraph, then surrounding it with
"
-
- fn :: [String] -> [ModuleTree] -> Doc
- fn ss [x] = ppNode ss x
- fn ss (x:xs) = ppNode ss x $$ fn ss xs
- fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
-
- ppNode :: [String] -> ModuleTree -> Doc
- ppNode ss (Node s leaf _pkg _ []) =
- ppLeaf s ss leaf
- ppNode ss (Node s leaf _pkg _ ts) =
- ppLeaf s ss leaf $$
- text "
" $+$
- nest 4 (fn (s:ss) ts) $+$
- text "
"
-
- ppLeaf s ss isleaf =
- text "
" <> nest 4
- (text "") $+$
- text "
"
- where
- mdl = foldr (++) "" (s' : map ('.':) ss')
- (s':ss') = reverse (s:ss)
- -- reconstruct the module name
-
--------------------------------
-ppHHIndex :: FilePath -> Maybe String -> [Interface] -> IO ()
-ppHHIndex odir maybe_package ifaces = do
- let indexHHFile = package++".hhk"
-
- html =
- text "" $$
- text "" $$
- text "" $$
- text "" $$
- text "" $$
- text "" $$
- text "
" $+$
- nest 4 (ppList index) $+$
- text "
" $$
- text ""
- writeFile (joinPath [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 "
The Monad class defines the basic operations over a monad,
+a concept from a branch of mathematics known as category theory.
hunk ./tests/golden-tests/tests/CrossPackageDocs.html.ref 11
-think of a monad as an abstract datatype of actions.
-Haskell's do expressions provide a convenient syntax for writing
+think of a monad as an abstract datatype of actions.
+Haskell's do expressions provide a convenient syntax for writing
hunk ./tests/golden-tests/tests/CrossPackageDocs.html.ref 14
-
In a comment string we can refer to identifiers in scope with
-single quotes like this: T, and we can refer to modules by
-using double quotes: Foo. We can add emphasis like this.
-
This is a bulleted list
-
This is the next item (different kind of bullet)
-
This is an ordered list
-
2. This is the next item (different kind of bullet)
-
- This is a block of code, which can include other markup: R
+
In a comment string we can refer to identifiers in scope with
+single quotes like this: T, and we can refer to modules by
+using double quotes: Foo. We can add emphasis like this.
+
This is a bulleted list
+
This is the next item (different kind of bullet)
+
This is an ordered list
+
This is the next item (different kind of bullet)
+
cat
a small, furry, domesticated mammal
+
pineapple
a fruit grown in the tropics
+
+ This is a block of code, which can include other markup: R
hunk ./tests/golden-tests/tests/Test.html.ref 79
-
Instances