From 5d41d4396425fc5c2e9b90d3e1e0baa5dc1ac224 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Sat, 23 Aug 2014 10:09:34 +0100
Subject: Move sources under haddock-api/src
---
.ghci | 2 +-
haddock-api/.ghci | 1 +
haddock-api/src | 1 -
haddock-api/src/Documentation/Haddock.hs | 89 ++
haddock-api/src/Haddock.hs | 488 ++++++++
haddock-api/src/Haddock/Backends/HaddockDB.hs | 170 +++
haddock-api/src/Haddock/Backends/Hoogle.hs | 331 ++++++
haddock-api/src/Haddock/Backends/LaTeX.hs | 1221 ++++++++++++++++++++
haddock-api/src/Haddock/Backends/Xhtml.hs | 690 +++++++++++
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 885 ++++++++++++++
.../src/Haddock/Backends/Xhtml/DocMarkup.hs | 143 +++
haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 235 ++++
haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 171 +++
haddock-api/src/Haddock/Backends/Xhtml/Themes.hs | 209 ++++
haddock-api/src/Haddock/Backends/Xhtml/Types.hs | 37 +
haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 218 ++++
haddock-api/src/Haddock/Convert.hs | 403 +++++++
haddock-api/src/Haddock/Doc.hs | 31 +
haddock-api/src/Haddock/GhcUtils.hs | 304 +++++
haddock-api/src/Haddock/Interface.hs | 244 ++++
.../src/Haddock/Interface/AttachInstances.hs | 221 ++++
haddock-api/src/Haddock/Interface/Create.hs | 867 ++++++++++++++
haddock-api/src/Haddock/Interface/LexParseRn.hs | 146 +++
.../src/Haddock/Interface/ParseModuleHeader.hs | 150 +++
haddock-api/src/Haddock/Interface/Rename.hs | 506 ++++++++
haddock-api/src/Haddock/InterfaceFile.hs | 636 ++++++++++
haddock-api/src/Haddock/ModuleTree.hs | 56 +
haddock-api/src/Haddock/Options.hs | 287 +++++
haddock-api/src/Haddock/Parser.hs | 44 +
haddock-api/src/Haddock/Types.hs | 552 +++++++++
haddock-api/src/Haddock/Utils.hs | 480 ++++++++
haddock-api/src/Haddock/Version.hs | 30 +
haddock-api/src/haddock.sh | 7 +
haddock.cabal | 2 +-
src/Documentation/Haddock.hs | 89 --
src/Haddock.hs | 488 --------
src/Haddock/Backends/HaddockDB.hs | 170 ---
src/Haddock/Backends/Hoogle.hs | 331 ------
src/Haddock/Backends/LaTeX.hs | 1221 --------------------
src/Haddock/Backends/Xhtml.hs | 690 -----------
src/Haddock/Backends/Xhtml/Decl.hs | 885 --------------
src/Haddock/Backends/Xhtml/DocMarkup.hs | 143 ---
src/Haddock/Backends/Xhtml/Layout.hs | 235 ----
src/Haddock/Backends/Xhtml/Names.hs | 171 ---
src/Haddock/Backends/Xhtml/Themes.hs | 209 ----
src/Haddock/Backends/Xhtml/Types.hs | 37 -
src/Haddock/Backends/Xhtml/Utils.hs | 218 ----
src/Haddock/Convert.hs | 403 -------
src/Haddock/Doc.hs | 31 -
src/Haddock/GhcUtils.hs | 304 -----
src/Haddock/Interface.hs | 244 ----
src/Haddock/Interface/AttachInstances.hs | 221 ----
src/Haddock/Interface/Create.hs | 867 --------------
src/Haddock/Interface/LexParseRn.hs | 146 ---
src/Haddock/Interface/ParseModuleHeader.hs | 150 ---
src/Haddock/Interface/Rename.hs | 506 --------
src/Haddock/InterfaceFile.hs | 636 ----------
src/Haddock/ModuleTree.hs | 56 -
src/Haddock/Options.hs | 287 -----
src/Haddock/Parser.hs | 44 -
src/Haddock/Types.hs | 552 ---------
src/Haddock/Utils.hs | 480 --------
src/Haddock/Version.hs | 30 -
src/haddock.sh | 7 -
64 files changed, 9854 insertions(+), 9854 deletions(-)
create mode 100644 haddock-api/.ghci
delete mode 120000 haddock-api/src
create mode 100644 haddock-api/src/Documentation/Haddock.hs
create mode 100644 haddock-api/src/Haddock.hs
create mode 100644 haddock-api/src/Haddock/Backends/HaddockDB.hs
create mode 100644 haddock-api/src/Haddock/Backends/Hoogle.hs
create mode 100644 haddock-api/src/Haddock/Backends/LaTeX.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Names.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Types.hs
create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
create mode 100644 haddock-api/src/Haddock/Convert.hs
create mode 100644 haddock-api/src/Haddock/Doc.hs
create mode 100644 haddock-api/src/Haddock/GhcUtils.hs
create mode 100644 haddock-api/src/Haddock/Interface.hs
create mode 100644 haddock-api/src/Haddock/Interface/AttachInstances.hs
create mode 100644 haddock-api/src/Haddock/Interface/Create.hs
create mode 100644 haddock-api/src/Haddock/Interface/LexParseRn.hs
create mode 100644 haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
create mode 100644 haddock-api/src/Haddock/Interface/Rename.hs
create mode 100644 haddock-api/src/Haddock/InterfaceFile.hs
create mode 100644 haddock-api/src/Haddock/ModuleTree.hs
create mode 100644 haddock-api/src/Haddock/Options.hs
create mode 100644 haddock-api/src/Haddock/Parser.hs
create mode 100644 haddock-api/src/Haddock/Types.hs
create mode 100644 haddock-api/src/Haddock/Utils.hs
create mode 100644 haddock-api/src/Haddock/Version.hs
create mode 100644 haddock-api/src/haddock.sh
delete mode 100644 src/Documentation/Haddock.hs
delete mode 100644 src/Haddock.hs
delete mode 100644 src/Haddock/Backends/HaddockDB.hs
delete mode 100644 src/Haddock/Backends/Hoogle.hs
delete mode 100644 src/Haddock/Backends/LaTeX.hs
delete mode 100644 src/Haddock/Backends/Xhtml.hs
delete mode 100644 src/Haddock/Backends/Xhtml/Decl.hs
delete mode 100644 src/Haddock/Backends/Xhtml/DocMarkup.hs
delete mode 100644 src/Haddock/Backends/Xhtml/Layout.hs
delete mode 100644 src/Haddock/Backends/Xhtml/Names.hs
delete mode 100644 src/Haddock/Backends/Xhtml/Themes.hs
delete mode 100644 src/Haddock/Backends/Xhtml/Types.hs
delete mode 100644 src/Haddock/Backends/Xhtml/Utils.hs
delete mode 100644 src/Haddock/Convert.hs
delete mode 100644 src/Haddock/Doc.hs
delete mode 100644 src/Haddock/GhcUtils.hs
delete mode 100644 src/Haddock/Interface.hs
delete mode 100644 src/Haddock/Interface/AttachInstances.hs
delete mode 100644 src/Haddock/Interface/Create.hs
delete mode 100644 src/Haddock/Interface/LexParseRn.hs
delete mode 100644 src/Haddock/Interface/ParseModuleHeader.hs
delete mode 100644 src/Haddock/Interface/Rename.hs
delete mode 100644 src/Haddock/InterfaceFile.hs
delete mode 100644 src/Haddock/ModuleTree.hs
delete mode 100644 src/Haddock/Options.hs
delete mode 100644 src/Haddock/Parser.hs
delete mode 100644 src/Haddock/Types.hs
delete mode 100644 src/Haddock/Utils.hs
delete mode 100644 src/Haddock/Version.hs
delete mode 100644 src/haddock.sh
diff --git a/.ghci b/.ghci
index 5407b2c3..8166be36 100644
--- a/.ghci
+++ b/.ghci
@@ -1 +1 @@
-:set -isrc -itest -idist/build -idist/build/autogen -packageghc -optP-include -optPdist/build/autogen/cabal_macros.h
+:set --itest -idist/build -idist/build/autogen -packageghc -optP-include -optPdist/build/autogen/cabal_macros.h
diff --git a/haddock-api/.ghci b/haddock-api/.ghci
new file mode 100644
index 00000000..62e7c5d2
--- /dev/null
+++ b/haddock-api/.ghci
@@ -0,0 +1 @@
+:set -isrc -idist/build -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
diff --git a/haddock-api/src b/haddock-api/src
deleted file mode 120000
index e057607e..00000000
--- a/haddock-api/src
+++ /dev/null
@@ -1 +0,0 @@
-../src/
\ No newline at end of file
diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs
new file mode 100644
index 00000000..1ff5cf75
--- /dev/null
+++ b/haddock-api/src/Documentation/Haddock.hs
@@ -0,0 +1,89 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Documentation.Haddock
+-- Copyright : (c) David Waern 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskellorg
+-- Stability : experimental
+-- Portability : portable
+--
+-- The Haddock API: A rudimentory, highly experimental API exposing some of
+-- the internals of Haddock. Don't expect it to be stable.
+-----------------------------------------------------------------------------
+module Documentation.Haddock (
+
+ -- * Interface
+ Interface(..),
+ InstalledInterface(..),
+ createInterfaces,
+ processModules,
+
+ -- * Export items & declarations
+ ExportItem(..),
+ DocForDecl,
+ FnArgsDoc,
+
+ -- * Cross-referencing
+ LinkEnv,
+ DocName(..),
+
+ -- * Instances
+ DocInstance,
+ InstHead,
+
+ -- * Documentation comments
+ Doc,
+ DocH(..),
+ Example(..),
+ Hyperlink(..),
+ DocMarkup(..),
+ Documentation(..),
+ ArgMap,
+ AliasMap,
+ WarningMap,
+ DocMap,
+ HaddockModInfo(..),
+ markup,
+
+ -- * Interface files
+ InterfaceFile(..),
+ readInterfaceFile,
+ nameCacheFromGhc,
+ freshNameCache,
+ NameCacheAccessor,
+
+ -- * Flags and options
+ Flag(..),
+ DocOption(..),
+
+ -- * Error handling
+ HaddockException(..),
+
+ -- * Program entry point
+ haddock,
+ haddockWithGhc,
+ getGhcDirs,
+ withGhc
+) where
+
+
+import Haddock.InterfaceFile
+import Haddock.Interface
+import Haddock.Types
+import Haddock.Options
+import Haddock.Utils
+import Haddock
+
+
+-- | Create 'Interface' structures from a given list of Haddock command-line
+-- flags and file or module names (as accepted by 'haddock' executable). Flags
+-- that control documentation generation or show help or version information
+-- are ignored.
+createInterfaces
+ :: [Flag] -- ^ A list of command-line flags
+ -> [String] -- ^ File or module names
+ -> IO [Interface] -- ^ Resulting list of interfaces
+createInterfaces flags modules = do
+ (_, ifaces, _) <- withGhc flags (readPackagesAndProcessModules flags modules)
+ return ifaces
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
new file mode 100644
index 00000000..0cff5bd3
--- /dev/null
+++ b/haddock-api/src/Haddock.hs
@@ -0,0 +1,488 @@
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
+{-# LANGUAGE LambdaCase #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2010,
+-- Mateusz Kowalczyk 2014
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Haddock - A Haskell Documentation Tool
+--
+-- Program entry point and top-level code.
+-----------------------------------------------------------------------------
+module Haddock (
+ haddock,
+ haddockWithGhc,
+ getGhcDirs,
+ readPackagesAndProcessModules,
+ withGhc
+) where
+
+import Haddock.Backends.Xhtml
+import Haddock.Backends.Xhtml.Themes (getThemes)
+import Haddock.Backends.LaTeX
+import Haddock.Backends.Hoogle
+import Haddock.Interface
+import Haddock.Parser
+import Haddock.Types
+import Haddock.Version
+import Haddock.InterfaceFile
+import Haddock.Options
+import Haddock.Utils
+import Haddock.GhcUtils hiding (pretty)
+
+import Control.Monad hiding (forM_)
+import Data.Foldable (forM_)
+import Data.List (isPrefixOf)
+import Control.Exception
+import Data.Maybe
+import Data.IORef
+import qualified Data.Map as Map
+import System.IO
+import System.Exit
+import System.Directory
+
+#if defined(mingw32_HOST_OS)
+import Foreign
+import Foreign.C
+import Data.Int
+#endif
+
+#ifdef IN_GHC_TREE
+import System.FilePath
+#else
+import qualified GHC.Paths as GhcPaths
+import Paths_haddock_api (getDataDir)
+#endif
+
+import GHC hiding (verbosity)
+import Config
+import DynFlags hiding (verbosity)
+import StaticFlags (discardStaticFlags)
+import Panic (handleGhcException)
+import Module
+
+--------------------------------------------------------------------------------
+-- * Exception handling
+--------------------------------------------------------------------------------
+
+
+handleTopExceptions :: IO a -> IO a
+handleTopExceptions =
+ handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions
+
+
+-- | Either returns normally or throws an ExitCode exception;
+-- all other exceptions are turned into exit exceptions.
+handleNormalExceptions :: IO a -> IO a
+handleNormalExceptions inner =
+ (inner `onException` hFlush stdout)
+ `catches`
+ [ Handler (\(code :: ExitCode) -> exitWith code)
+
+ , Handler (\(ex :: AsyncException) ->
+ case ex of
+ StackOverflow -> do
+ putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
+ exitFailure
+ _ -> do
+ putStrLn ("haddock: " ++ show ex)
+ exitFailure)
+
+ , Handler (\(ex :: SomeException) -> do
+ putStrLn ("haddock: internal error: " ++ show ex)
+ exitFailure)
+ ]
+
+
+handleHaddockExceptions :: IO a -> IO a
+handleHaddockExceptions inner =
+ catches inner [Handler handler]
+ where
+ handler (e::HaddockException) = do
+ putStrLn $ "haddock: " ++ show e
+ exitFailure
+
+
+handleGhcExceptions :: IO a -> IO a
+handleGhcExceptions =
+ -- error messages propagated as exceptions
+ handleGhcException $ \e -> do
+ hFlush stdout
+ case e of
+ PhaseFailed _ code -> exitWith code
+ _ -> do
+ print (e :: GhcException)
+ exitFailure
+
+
+-------------------------------------------------------------------------------
+-- * Top level
+-------------------------------------------------------------------------------
+
+
+-- | Run Haddock with given list of arguments.
+--
+-- Haddock's own main function is defined in terms of this:
+--
+-- > main = getArgs >>= haddock
+haddock :: [String] -> IO ()
+haddock args = haddockWithGhc withGhc args
+
+haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
+haddockWithGhc ghc args = handleTopExceptions $ do
+
+ -- Parse command-line flags and handle some of them initially.
+ -- TODO: unify all of this (and some of what's in the 'render' function),
+ -- into one function that returns a record with a field for each option,
+ -- or which exits with an error or help message.
+ (flags, files) <- parseHaddockOpts args
+ shortcutFlags flags
+ qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
+
+ -- inject dynamic-too into flags before we proceed
+ flags' <- ghc flags $ do
+ df <- getDynFlags
+ case lookup "GHC Dynamic" (compilerInfo df) of
+ Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
+ _ -> return flags
+
+ unless (Flag_NoWarnings `elem` flags) $ do
+ forM_ (warnings args) $ \warning -> do
+ hPutStrLn stderr warning
+
+ ghc flags' $ do
+
+ dflags <- getDynFlags
+
+ if not (null files) then do
+ (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+ -- Dump an "interface file" (.haddock file), if requested.
+ forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
+ writeInterfaceFile path InterfaceFile {
+ ifInstalledIfaces = map toInstalledIface ifaces
+ , ifLinkEnv = homeLinks
+ }
+
+ -- Render the interfaces.
+ liftIO $ renderStep dflags flags qual packages ifaces
+
+ else do
+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+ throwE "No input file(s)."
+
+ -- Get packages supplied with --read-interface.
+ packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+
+ -- Render even though there are no input files (usually contents/index).
+ liftIO $ renderStep dflags flags qual packages []
+
+-- | Create warnings about potential misuse of -optghc
+warnings :: [String] -> [String]
+warnings = map format . filter (isPrefixOf "-optghc")
+ where
+ format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
+
+
+withGhc :: [Flag] -> Ghc a -> IO a
+withGhc flags action = do
+ libDir <- fmap snd (getGhcDirs flags)
+
+ -- Catches all GHC source errors, then prints and re-throws them.
+ let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
+ printException err
+ liftIO exitFailure
+
+ withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
+
+
+readPackagesAndProcessModules :: [Flag] -> [String]
+ -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+readPackagesAndProcessModules flags files = do
+ -- Get packages supplied with --read-interface.
+ packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
+
+ -- Create the interfaces -- this is the core part of Haddock.
+ let ifaceFiles = map snd packages
+ (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
+
+ return (packages, ifaces, homeLinks)
+
+
+renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags qual pkgs interfaces = do
+ updateHTMLXRefs pkgs
+ let
+ ifaceFiles = map snd pkgs
+ installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+ srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
+ render dflags flags qual interfaces installedIfaces srcMap
+
+
+-- | Render the interfaces with whatever backend is specified in the flags.
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render dflags flags qual ifaces installedIfaces srcMap = do
+
+ let
+ title = fromMaybe "" (optTitle flags)
+ unicode = Flag_UseUnicode `elem` flags
+ pretty = Flag_PrettyHtml `elem` flags
+ opt_wiki_urls = wikiUrls flags
+ opt_contents_url = optContentsUrl flags
+ opt_index_url = optIndexUrl flags
+ odir = outputDir flags
+ opt_latex_style = optLaTeXStyle flags
+
+ visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
+
+ -- /All/ visible interfaces including external package modules.
+ allIfaces = map toInstalledIface ifaces ++ installedIfaces
+ allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
+
+ pkgMod = ifaceMod (head ifaces)
+ pkgId = modulePackageId pkgMod
+ pkgStr = Just (packageIdString pkgId)
+ (pkgName,pkgVer) = modulePackageInfo pkgMod
+
+ (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
+ srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity
+ -- TODO: Get these from the interface files as with srcMap
+ srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity
+ sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
+
+ libDir <- getHaddockLibDir flags
+ prologue <- getPrologue dflags flags
+ themes <- getThemes libDir flags >>= either bye return
+
+ when (Flag_GenIndex `elem` flags) $ do
+ ppHtmlIndex odir title pkgStr
+ themes opt_contents_url sourceUrls' opt_wiki_urls
+ allVisibleIfaces pretty
+ copyHtmlBits odir libDir themes
+
+ when (Flag_GenContents `elem` flags) $ do
+ ppHtmlContents odir title pkgStr
+ themes opt_index_url sourceUrls' opt_wiki_urls
+ allVisibleIfaces True prologue pretty
+ (makeContentsQual qual)
+ copyHtmlBits odir libDir themes
+
+ when (Flag_Html `elem` flags) $ do
+ ppHtml title pkgStr visibleIfaces odir
+ prologue
+ themes sourceUrls' opt_wiki_urls
+ opt_contents_url opt_index_url unicode qual
+ pretty
+ copyHtmlBits odir libDir themes
+
+ when (Flag_Hoogle `elem` flags) $ do
+ let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
+ ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
+
+ when (Flag_LaTeX `elem` flags) $ do
+ ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
+ libDir
+
+
+-------------------------------------------------------------------------------
+-- * Reading and dumping interface files
+-------------------------------------------------------------------------------
+
+
+readInterfaceFiles :: MonadIO m
+ => NameCacheAccessor m
+ -> [(DocPaths, FilePath)]
+ -> m [(DocPaths, InterfaceFile)]
+readInterfaceFiles name_cache_accessor pairs = do
+ catMaybes `liftM` mapM tryReadIface pairs
+ where
+ -- try to read an interface, warn if we can't
+ tryReadIface (paths, file) =
+ readInterfaceFile name_cache_accessor file >>= \case
+ Left err -> liftIO $ do
+ putStrLn ("Warning: Cannot read " ++ file ++ ":")
+ putStrLn (" " ++ err)
+ putStrLn "Skipping this interface."
+ return Nothing
+ Right f -> return $ Just (paths, f)
+
+
+-------------------------------------------------------------------------------
+-- * Creating a GHC session
+-------------------------------------------------------------------------------
+
+
+-- | Start a GHC session with the -haddock flag set. Also turn off
+-- compilation and linking. Then run the given 'Ghc' action.
+withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
+withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
+ dynflags <- getSessionDynFlags
+ dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {
+ hscTarget = HscNothing,
+ ghcMode = CompManager,
+ ghcLink = NoLink
+ }
+ let dynflags'' = gopt_unset dynflags' Opt_SplitObjs
+ defaultCleanupHandler dynflags'' $ do
+ -- ignore the following return-value, which is a list of packages
+ -- that may need to be re-linked: Haddock doesn't do any
+ -- dynamic or static linking at all!
+ _ <- setSessionDynFlags dynflags''
+ ghcActs dynflags''
+ where
+ parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
+ parseGhcFlags dynflags = do
+ -- TODO: handle warnings?
+
+ -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot
+ -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if
+ -- we pass any, Haddock will fail. Since StaticFlags are global to the
+ -- GHC invocation, there's also no way to reparse/save them to set them
+ -- again properly.
+ --
+ -- This is a bit of a hack until we get rid of the rest of the remaining
+ -- StaticFlags. See GHC issue #8276.
+ let flags' = discardStaticFlags flags
+ (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
+ if not (null rest)
+ then throwE ("Couldn't parse GHC options: " ++ unwords flags')
+ else return dynflags'
+
+-------------------------------------------------------------------------------
+-- * Misc
+-------------------------------------------------------------------------------
+
+
+getHaddockLibDir :: [Flag] -> IO String
+getHaddockLibDir flags =
+ case [str | Flag_Lib str <- flags] of
+ [] -> do
+#ifdef IN_GHC_TREE
+ getInTreeDir
+#else
+ d <- getDataDir -- provided by Cabal
+ doesDirectoryExist d >>= \exists -> case exists of
+ True -> return d
+ False -> do
+ -- If directory does not exist then we are probably invoking from
+ -- ./dist/build/haddock/haddock so we use ./resources as a fallback.
+ doesDirectoryExist "resources" >>= \exists_ -> case exists_ of
+ True -> return "resources"
+ False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")
+#endif
+ fs -> return (last fs)
+
+
+getGhcDirs :: [Flag] -> IO (String, String)
+getGhcDirs flags = do
+ case [ dir | Flag_GhcLibDir dir <- flags ] of
+ [] -> do
+#ifdef IN_GHC_TREE
+ libDir <- getInTreeDir
+ return (ghcPath, libDir)
+#else
+ return (ghcPath, GhcPaths.libdir)
+#endif
+ xs -> return (ghcPath, last xs)
+ where
+#ifdef IN_GHC_TREE
+ ghcPath = "not available"
+#else
+ ghcPath = GhcPaths.ghc
+#endif
+
+
+shortcutFlags :: [Flag] -> IO ()
+shortcutFlags flags = do
+ usage <- getUsage
+
+ when (Flag_Help `elem` flags) (bye usage)
+ when (Flag_Version `elem` flags) byeVersion
+ when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n"))
+ when (Flag_CompatibleInterfaceVersions `elem` flags)
+ (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\n"))
+ when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n"))
+
+ when (Flag_PrintGhcPath `elem` flags) $ do
+ dir <- fmap fst (getGhcDirs flags)
+ bye $ dir ++ "\n"
+
+ when (Flag_PrintGhcLibDir `elem` flags) $ do
+ dir <- fmap snd (getGhcDirs flags)
+ bye $ dir ++ "\n"
+
+ when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $
+ throwE "Unicode can only be enabled for HTML output."
+
+ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+ && Flag_Html `elem` flags) $
+ throwE "-h cannot be used with --gen-index or --gen-contents"
+
+ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+ && Flag_Hoogle `elem` flags) $
+ throwE "--hoogle cannot be used with --gen-index or --gen-contents"
+
+ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+ && Flag_LaTeX `elem` flags) $
+ throwE "--latex cannot be used with --gen-index or --gen-contents"
+ where
+ byeVersion = bye $
+ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"
+ ++ "Ported to use the GHC API by David Waern 2006-2008\n"
+
+
+updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
+updateHTMLXRefs packages = do
+ writeIORef html_xrefs_ref (Map.fromList mapping)
+ writeIORef html_xrefs_ref' (Map.fromList mapping')
+ where
+ mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
+ , iface <- ifInstalledIfaces ifaces ]
+ mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
+
+
+getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))
+getPrologue dflags flags =
+ case [filename | Flag_Prologue filename <- flags ] of
+ [] -> return Nothing
+ [filename] -> withFile filename ReadMode $ \h -> do
+ hSetEncoding h utf8
+ str <- hGetContents h
+ return . Just $ parseParas dflags str
+ _ -> throwE "multiple -p/--prologue options"
+
+
+#ifdef IN_GHC_TREE
+
+getInTreeDir :: IO String
+getInTreeDir = getExecDir >>= \case
+ Nothing -> error "No GhcDir found"
+ Just d -> return (d </> ".." </> "lib")
+
+
+getExecDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
+getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
+#else
+getExecDir = return Nothing
+#endif
+
+#endif
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs
new file mode 100644
index 00000000..1c248bfb
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs
@@ -0,0 +1,170 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.HaddockDB
+-- Copyright : (c) Simon Marlow 2003
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.HaddockDB (ppDocBook) where
+
+{-
+import HaddockTypes
+import HaddockUtil
+import HsSyn2
+
+import Text.PrettyPrint
+-}
+
+-----------------------------------------------------------------------------
+-- Printing the results in DocBook format
+
+ppDocBook :: a
+ppDocBook = error "not working"
+{-
+ppDocBook :: FilePath -> [(Module, Interface)] -> String
+ppDocBook odir mods = render (ppIfaces mods)
+
+ppIfaces mods
+ = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
+ $$ text "]>"
+ $$ text "<book>"
+ $$ text "<bookinfo>"
+ $$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
+ $$ text "</bookinfo>"
+ $$ text "<article>"
+ $$ vcat (map do_mod mods)
+ $$ text "</article></book>"
+ where
+ do_mod (Module mod, iface)
+ = text "<sect1 id=\"sec-" <> text mod <> text "\">"
+ $$ text "<title><literal>"
+ <> text mod
+ <> text "</literal></title>"
+ $$ text "<indexterm><primary><literal>"
+ <> text mod
+ <> text "</literal></primary></indexterm>"
+ $$ text "<variablelist>"
+ $$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
+ $$ text "</variablelist>"
+ $$ text "</sect1>"
+
+ do_export mod decl | (nm:_) <- declBinders decl
+ = text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
+ $$ text "<term><literal>"
+ <> do_decl decl
+ <> text "</literal></term>"
+ $$ text "<listitem>"
+ $$ text "<para>"
+ $$ text "</para>"
+ $$ text "</listitem>"
+ $$ text "</varlistentry>"
+ do_export _ _ = empty
+
+ do_decl (HsTypeSig _ [nm] ty _)
+ = ppHsName nm <> text " :: " <> ppHsType ty
+ do_decl (HsTypeDecl _ nm args ty _)
+ = hsep ([text "type", ppHsName nm ]
+ ++ map ppHsName args
+ ++ [equals, ppHsType ty])
+ do_decl (HsNewTypeDecl loc ctx nm args con drv _)
+ = hsep ([text "data", ppHsName nm] -- data, not newtype
+ ++ map ppHsName args
+ ) <+> equals <+> ppHsConstr con -- ToDo: derivings
+ do_decl (HsDataDecl loc ctx nm args cons drv _)
+ = hsep ([text "data", {-ToDo: context-}ppHsName nm]
+ ++ map ppHsName args)
+ <+> vcat (zipWith (<+>) (equals : repeat (char '|'))
+ (map ppHsConstr cons))
+ do_decl (HsClassDecl loc ty fds decl _)
+ = hsep [text "class", ppHsType ty]
+ do_decl decl
+ = empty
+
+ppHsConstr :: HsConDecl -> Doc
+ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
+ ppHsName name
+ <> (braces . hsep . punctuate comma . map ppField $ fieldList)
+ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
+ hsep (ppHsName name : map ppHsBangType typeList)
+
+ppField (HsFieldDecl ns ty doc)
+ = hsep (punctuate comma (map ppHsName ns) ++
+ [text "::", ppHsBangType ty])
+
+ppHsBangType :: HsBangType -> Doc
+ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty
+ppHsBangType (HsUnBangedTy ty) = ppHsType ty
+
+ppHsContext :: HsContext -> Doc
+ppHsContext [] = empty
+ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
+ hsep (map ppHsAType b)) context)
+
+ppHsType :: HsType -> Doc
+ppHsType (HsForAllType Nothing context htype) =
+ hsep [ ppHsContext context, text "=>", ppHsType htype]
+ppHsType (HsForAllType (Just tvs) [] htype) =
+ hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
+ppHsType (HsForAllType (Just tvs) context htype) =
+ hsep (text "forall" : map ppHsName tvs ++ text "." :
+ ppHsContext context : text "=>" : [ppHsType htype])
+ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]
+ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
+ppHsType t = ppHsBType t
+
+ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+ = brackets $ ppHsType b
+ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
+ppHsBType t = ppHsAType t
+
+ppHsAType :: HsType -> Doc
+ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l
+ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
+-- special case
+ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
+ = brackets $ ppHsType b
+ppHsAType (HsTyVar name) = ppHsName name
+ppHsAType (HsTyCon name) = ppHsQName name
+ppHsAType t = parens $ ppHsType t
+
+ppHsQName :: HsQName -> Doc
+ppHsQName (UnQual str) = ppHsName str
+ppHsQName n@(Qual (Module mod) str)
+ | n == unit_con_name = ppHsName str
+ | isSpecial str = ppHsName str
+ | otherwise
+ = text "<link linkend=" <> ppLinkId mod str <> char '>'
+ <> ppHsName str
+ <> text "</link>"
+
+isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
+isSpecial (HsVarName id) | HsSpecial _ <- id = True
+isSpecial _ = False
+
+ppHsName :: HsName -> Doc
+ppHsName (HsTyClsName id) = ppHsIdentifier id
+ppHsName (HsVarName id) = ppHsIdentifier id
+
+ppHsIdentifier :: HsIdentifier -> Doc
+ppHsIdentifier (HsIdent str) = text str
+ppHsIdentifier (HsSymbol str) = text str
+ppHsIdentifier (HsSpecial str) = text str
+
+ppLinkId :: String -> HsName -> Doc
+ppLinkId mod str
+ = hcat [char '\"', text mod, char '.', ppHsName str, char '\"']
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+
+parenList :: [Doc] -> Doc
+parenList = parens . fsep . punctuate comma
+
+ubxParenList :: [Doc] -> Doc
+ubxParenList = ubxparens . fsep . punctuate comma
+
+ubxparens p = text "(#" <> p <> text "#)"
+-}
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
new file mode 100644
index 00000000..628e1cd0
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -0,0 +1,331 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Hoogle
+-- Copyright : (c) Neil Mitchell 2006-2008
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Write out Hoogle compatible documentation
+-- http://www.haskell.org/hoogle/
+-----------------------------------------------------------------------------
+module Haddock.Backends.Hoogle (
+ ppHoogle
+ ) where
+
+
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Utils hiding (out)
+import GHC
+import Outputable
+
+import Data.Char
+import Data.List
+import Data.Maybe
+import System.FilePath
+import System.IO
+
+prefix :: [String]
+prefix = ["-- Hoogle documentation, generated by Haddock"
+ ,"-- See Hoogle, http://www.haskell.org/hoogle/"
+ ,""]
+
+
+ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags package version synopsis prologue ifaces odir = do
+ let filename = package ++ ".txt"
+ contents = prefix ++
+ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
+ ["@package " ++ package] ++
+ ["@version " ++ version | version /= ""] ++
+ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+ h <- openFile (odir </> filename) WriteMode
+ hSetEncoding h utf8
+ hPutStr h (unlines contents)
+ hClose h
+
+ppModule :: DynFlags -> Interface -> [String]
+ppModule dflags iface =
+ "" : ppDocumentation dflags (ifaceDoc iface) ++
+ ["module " ++ moduleString (ifaceMod iface)] ++
+ concatMap (ppExport dflags) (ifaceExportItems iface) ++
+ concatMap (ppInstance dflags) (ifaceInstances iface)
+
+
+---------------------------------------------------------------------
+-- Utility functions
+
+dropHsDocTy :: HsType a -> HsType a
+dropHsDocTy = f
+ where
+ g (L src x) = L src (f x)
+ f (HsForAllTy a b c d) = HsForAllTy a b c (g d)
+ f (HsBangTy a b) = HsBangTy a (g b)
+ f (HsAppTy a b) = HsAppTy (g a) (g b)
+ f (HsFunTy a b) = HsFunTy (g a) (g b)
+ f (HsListTy a) = HsListTy (g a)
+ f (HsPArrTy a) = HsPArrTy (g a)
+ f (HsTupleTy a b) = HsTupleTy a (map g b)
+ f (HsOpTy a b c) = HsOpTy (g a) b (g c)
+ f (HsParTy a) = HsParTy (g a)
+ f (HsKindSig a b) = HsKindSig (g a) b
+ f (HsDocTy a _) = f $ unL a
+ f x = x
+
+outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
+outHsType dflags = out dflags . dropHsDocTy
+
+
+makeExplicit :: HsType a -> HsType a
+makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c
+makeExplicit x = x
+
+makeExplicitL :: LHsType a -> LHsType a
+makeExplicitL (L src x) = L src (makeExplicit x)
+
+
+dropComment :: String -> String
+dropComment (' ':'-':'-':' ':_) = []
+dropComment (x:xs) = x : dropComment xs
+dropComment [] = []
+
+
+out :: Outputable a => DynFlags -> a -> String
+out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
+ where
+ f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
+ f (x:xs) = x : f xs
+ f [] = []
+
+
+operator :: String -> String
+operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
+operator x = x
+
+
+---------------------------------------------------------------------
+-- How to print each export
+
+ppExport :: DynFlags -> ExportItem Name -> [String]
+ppExport dflags ExportDecl { expItemDecl = L _ decl
+ , expItemMbDoc = (dc, _)
+ , expItemSubDocs = subdocs
+ } = ppDocumentation dflags dc ++ f decl
+ where
+ f (TyClD d@DataDecl{}) = ppData dflags d subdocs
+ f (TyClD d@SynDecl{}) = ppSynonym dflags d
+ f (TyClD d@ClassDecl{}) = ppClass dflags d
+ f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+ f (SigD sig) = ppSig dflags sig
+ f _ = []
+ppExport _ _ = []
+
+
+ppSig :: DynFlags -> Sig Name -> [String]
+ppSig dflags (TypeSig names sig)
+ = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
+ where
+ prettyNames = intercalate ", " $ map (out dflags) names
+ typ = case unL sig of
+ HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
+ x -> x
+ppSig _ _ = []
+
+
+-- note: does not yet output documentation for class methods
+ppClass :: DynFlags -> TyClDecl Name -> [String]
+ppClass dflags x = out dflags x{tcdSigs=[]} :
+ concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
+ where
+ addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
+ addContext (MinimalSig sig) = MinimalSig sig
+ addContext _ = error "expected TypeSig"
+
+ f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
+ f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
+
+ context = nlHsTyConApp (tcdName x)
+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
+
+
+ppInstance :: DynFlags -> ClsInst -> [String]
+ppInstance dflags x = [dropComment $ out dflags x]
+
+
+ppSynonym :: DynFlags -> TyClDecl Name -> [String]
+ppSynonym dflags x = [out dflags x]
+
+ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
+ = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
+ concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
+ where
+
+ -- GHC gives out "data Bar =", we want to delete the equals
+ -- also writes data : a b, when we want data (:) a b
+ showData d = unwords $ map f $ if last xs == "=" then init xs else xs
+ where
+ xs = words $ out dflags d
+ nam = out dflags $ tyClDeclLName d
+ f w = if w == nam then operator nam else w
+ppData _ _ _ = panic "ppData"
+
+-- | for constructors, and named-fields...
+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]
+lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
+ Just (d, _) -> ppDocumentation dflags d
+ _ -> []
+
+ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
+ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
+ ++ f (con_details con)
+ where
+ f (PrefixCon args) = [typeSig name $ args ++ [resType]]
+ f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
+ f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
+ [lookupCon dflags subdocs (cd_fld_name r) ++
+ [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
+ | r <- recs]
+
+ funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
+ apps = foldl1 (\x y -> reL $ HsAppTy x y)
+
+ typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+ name = out dflags $ unL $ con_name con
+
+ resType = case con_res con of
+ ResTyH98 -> apps $ map (reL . HsTyVar) $
+ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
+ ResTyGADT x -> x
+
+
+---------------------------------------------------------------------
+-- DOCUMENTATION
+
+ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]
+ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w
+
+
+doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
+doc dflags = docWith dflags ""
+
+
+docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]
+docWith _ [] Nothing = []
+docWith dflags header d
+ = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $
+ [header | header /= ""] ++ ["" | header /= "" && isJust d] ++
+ maybe [] (showTags . markup (markupTag dflags)) d
+
+
+data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
+ deriving Show
+
+type Tags = [Tag]
+
+box :: (a -> b) -> a -> [b]
+box f x = [f x]
+
+str :: String -> [Tag]
+str a = [Str a]
+
+-- want things like paragraph, pre etc to be handled by blank lines in the source document
+-- and things like \n and \t converted away
+-- much like blogger in HTML mode
+-- everything else wants to be included as tags, neatly nested for some (ul,li,ol)
+-- or inlne for others (a,i,tt)
+-- entities (&,>,<) should always be appropriately escaped
+
+markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]
+markupTag dflags = Markup {
+ markupParagraph = box TagP,
+ markupEmpty = str "",
+ markupString = str,
+ markupAppend = (++),
+ markupIdentifier = box (TagInline "a") . str . out dflags,
+ markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
+ markupModule = box (TagInline "a") . str,
+ markupWarning = box (TagInline "i"),
+ markupEmphasis = box (TagInline "i"),
+ markupBold = box (TagInline "b"),
+ markupMonospaced = box (TagInline "tt"),
+ markupPic = const $ str " ",
+ markupUnorderedList = box (TagL 'u'),
+ markupOrderedList = box (TagL 'o'),
+ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
+ markupCodeBlock = box TagPre,
+ markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
+ markupAName = const $ str "",
+ markupProperty = box TagPre . str,
+ markupExample = box TagPre . str . unlines . map exampleToString,
+ markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h
+ }
+
+
+showTags :: [Tag] -> [String]
+showTags = intercalate [""] . map showBlock
+
+
+showBlock :: Tag -> [String]
+showBlock (TagP xs) = showInline xs
+showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"]
+ where mid = concatMap (showInline . box (TagInline "li")) xs
+showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"]
+showBlock x = showInline [x]
+
+
+asInline :: Tag -> Tags
+asInline (TagP xs) = xs
+asInline (TagPre xs) = [TagInline "pre" xs]
+asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs]
+asInline x = [x]
+
+
+showInline :: [Tag] -> [String]
+showInline = unwordsWrap 70 . words . concatMap f
+ where
+ fs = concatMap f
+ f (Str x) = escape x
+ f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">"
+ f x = fs $ asInline x
+
+ trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
+
+
+showPre :: [Tag] -> [String]
+showPre = trimFront . trimLines . lines . concatMap f
+ where
+ trimLines = dropWhile null . reverse . dropWhile null . reverse
+ trimFront xs = map (drop i) xs
+ where
+ ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""]
+ i = if null ns then 0 else minimum ns
+
+ fs = concatMap f
+ f (Str x) = escape x
+ f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">"
+ f x = fs $ asInline x
+
+
+unwordsWrap :: Int -> [String] -> [String]
+unwordsWrap n = f n []
+ where
+ f _ s [] = [g s | s /= []]
+ f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs
+ | otherwise = f (i - nx - 1) (x:s) xs
+ where nx = length x
+
+ g = unwords . reverse
+
+
+escape :: String -> String
+escape = concatMap f
+ where
+ f '<' = "<"
+ f '>' = ">"
+ f '&' = "&"
+ f x = [x]
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
new file mode 100644
index 00000000..7b72c030
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -0,0 +1,1221 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.LaTeX
+-- Copyright : (c) Simon Marlow 2010,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.LaTeX (
+ ppLaTeX
+) where
+
+
+import Haddock.Types
+import Haddock.Utils
+import Haddock.GhcUtils
+import Pretty hiding (Doc, quote)
+import qualified Pretty
+
+import GHC
+import OccName
+import Name ( nameOccName )
+import RdrName ( rdrNameOcc )
+import FastString ( unpackFS, unpackLitString, zString )
+
+import qualified Data.Map as Map
+import System.Directory
+import System.FilePath
+import Data.Char
+import Control.Monad
+import Data.Maybe
+import Data.List
+
+import Haddock.Doc (combineDocumentation)
+
+-- import Debug.Trace
+
+{- SAMPLE OUTPUT
+
+\haddockmoduleheading{\texttt{Data.List}}
+\hrulefill
+{\haddockverb\begin{verbatim}
+module Data.List (
+ (++), head, last, tail, init, null, length, map, reverse,
+ ) where\end{verbatim}}
+\hrulefill
+
+\section{Basic functions}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+head\ ::\ {\char 91}a{\char 93}\ ->\ a
+\end{tabular}]\haddockbegindoc
+Extract the first element of a list, which must be non-empty.
+\par
+
+\end{haddockdesc}
+\begin{haddockdesc}
+\item[\begin{tabular}{@{}l}
+last\ ::\ {\char 91}a{\char 93}\ ->\ a
+\end{tabular}]\haddockbegindoc
+Extract the last element of a list, which must be finite and non-empty.
+\par
+
+\end{haddockdesc}
+-}
+
+
+{- TODO
+ * don't forget fixity!!
+-}
+
+ppLaTeX :: String -- Title
+ -> Maybe String -- Package name
+ -> [Interface]
+ -> FilePath -- destination directory
+ -> Maybe (Doc GHC.RdrName) -- prologue text, maybe
+ -> Maybe String -- style file
+ -> FilePath
+ -> IO ()
+
+ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir
+ = do
+ createDirectoryIfMissing True odir
+ when (isNothing maybe_style) $
+ copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
+ ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
+ mapM_ (ppLaTeXModule title odir) visible_ifaces
+
+
+haddockSty :: FilePath
+haddockSty = "haddock.sty"
+
+
+type LaTeX = Pretty.Doc
+
+
+ppLaTeXTop
+ :: String
+ -> Maybe String
+ -> FilePath
+ -> Maybe (Doc GHC.RdrName)
+ -> Maybe String
+ -> [Interface]
+ -> IO ()
+
+ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
+
+ let tex = vcat [
+ text "\\documentclass{book}",
+ text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),
+ text "\\begin{document}",
+ text "\\begin{titlepage}",
+ text "\\begin{haddocktitle}",
+ text doctitle,
+ text "\\end{haddocktitle}",
+ case prologue of
+ Nothing -> empty
+ Just d -> vcat [text "\\begin{haddockprologue}",
+ rdrDocToLaTeX d,
+ text "\\end{haddockprologue}"],
+ text "\\end{titlepage}",
+ text "\\tableofcontents",
+ vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],
+ text "\\end{document}"
+ ]
+
+ mods = sort (map (moduleBasename.ifaceMod) ifaces)
+
+ filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
+
+ writeFile filename (show tex)
+
+
+ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
+ppLaTeXModule _title odir iface = do
+ createDirectoryIfMissing True odir
+ let
+ mdl = ifaceMod iface
+ mdl_str = moduleString mdl
+
+ exports = ifaceRnExportItems iface
+
+ tex = vcat [
+ text "\\haddockmoduleheading" <> braces (text mdl_str),
+ text "\\label{module:" <> text mdl_str <> char '}',
+ text "\\haddockbeginheader",
+ verb $ vcat [
+ text "module" <+> text mdl_str <+> lparen,
+ text " " <> fsep (punctuate (text ", ") $
+ map exportListItem $
+ filter forSummary exports),
+ text " ) where"
+ ],
+ text "\\haddockendheader" $$ text "",
+ description,
+ body
+ ]
+
+ description
+ = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
+
+ body = processExports exports
+ --
+ writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex)
+
+
+string_txt :: TextDetails -> String -> String
+string_txt (Chr c) s = c:s
+string_txt (Str s1) s2 = s1 ++ s2
+string_txt (PStr s1) s2 = unpackFS s1 ++ s2
+string_txt (ZStr s1) s2 = zString s1 ++ s2
+string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
+
+
+exportListItem :: ExportItem DocName -> LaTeX
+exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
+ = sep (punctuate comma . map ppDocBinder $ declNames decl) <>
+ case subdocs of
+ [] -> empty
+ _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
+exportListItem (ExportNoDecl y [])
+ = ppDocBinder y
+exportListItem (ExportNoDecl y subs)
+ = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))
+exportListItem (ExportModule mdl)
+ = text "module" <+> text (moduleString mdl)
+exportListItem _
+ = error "exportListItem"
+
+
+-- Deal with a group of undocumented exports together, to avoid lots
+-- of blank vertical space between them.
+processExports :: [ExportItem DocName] -> LaTeX
+processExports [] = empty
+processExports (decl : es)
+ | Just sig <- isSimpleSig decl
+ = multiDecl [ ppTypeSig (map getName names) typ False
+ | (names,typ) <- sig:sigs ] $$
+ processExports es'
+ where (sigs, es') = spanWith isSimpleSig es
+processExports (ExportModule mdl : es)
+ = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$
+ processExports es'
+ where (mdls, es') = spanWith isExportModule es
+processExports (e : es) =
+ processExport e $$ processExports es
+
+
+isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t)))
+ , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
+ | Map.null argDocs = Just (map unLoc lnames, t)
+isSimpleSig _ = Nothing
+
+
+isExportModule :: ExportItem DocName -> Maybe Module
+isExportModule (ExportModule m) = Just m
+isExportModule _ = Nothing
+
+
+processExport :: ExportItem DocName -> LaTeX
+processExport (ExportGroup lev _id0 doc)
+ = ppDocGroup lev (docToLaTeX doc)
+processExport (ExportDecl decl doc subdocs insts fixities _splice)
+ = ppDecl decl doc insts subdocs fixities
+processExport (ExportNoDecl y [])
+ = ppDocName y
+processExport (ExportNoDecl y subs)
+ = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))
+processExport (ExportModule mdl)
+ = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing
+processExport (ExportDoc doc)
+ = docToLaTeX doc
+
+
+ppDocGroup :: Int -> LaTeX -> LaTeX
+ppDocGroup lev doc = sec lev <> braces doc
+ where sec 1 = text "\\section"
+ sec 2 = text "\\subsection"
+ sec 3 = text "\\subsubsection"
+ sec _ = text "\\paragraph"
+
+
+declNames :: LHsDecl DocName -> [DocName]
+declNames (L _ decl) = case decl of
+ TyClD d -> [tcdName d]
+ SigD (TypeSig lnames _) -> map unLoc lnames
+ SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
+ ForD (ForeignImport (L _ n) _ _ _) -> [n]
+ ForD (ForeignExport (L _ n) _ _ _) -> [n]
+ _ -> error "declaration not supported by declNames"
+
+
+forSummary :: (ExportItem DocName) -> Bool
+forSummary (ExportGroup _ _ _) = False
+forSummary (ExportDoc _) = False
+forSummary _ = True
+
+
+moduleLaTeXFile :: Module -> FilePath
+moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"
+
+
+moduleBasename :: Module -> FilePath
+moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
+ (moduleNameString (moduleName mdl))
+
+
+-------------------------------------------------------------------------------
+-- * Decls
+-------------------------------------------------------------------------------
+
+
+ppDecl :: LHsDecl DocName
+ -> DocForDecl DocName
+ -> [DocInstance DocName]
+ -> [(DocName, DocForDecl DocName)]
+ -> [(DocName, Fixity)]
+ -> LaTeX
+
+ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
+ TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
+ TyClD d@(DataDecl {})
+ -> ppDataDecl instances subdocs loc (Just doc) d unicode
+ TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
+-- Family instances happen via FamInst now
+-- TyClD d@(TySynonym {})
+-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
+-- Family instances happen via FamInst now
+ TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
+ SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode
+ ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
+ InstD _ -> empty
+ _ -> error "declaration not supported by ppDecl"
+ where
+ unicode = False
+
+
+ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
+ TyClDecl DocName -> Bool -> LaTeX
+ppTyFam _ _ _ _ _ =
+ error "type family declarations are currently not supported by --latex"
+
+
+ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
+ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =
+ ppFunSig loc doc [name] typ unicode
+ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
+-- error "foreign declarations are currently not supported by --latex"
+
+
+-------------------------------------------------------------------------------
+-- * Type Synonyms
+-------------------------------------------------------------------------------
+
+
+-- we skip type patterns for now
+ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
+
+ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype }) unicode
+ = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
+ where
+ hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
+ full = hdr <+> char '=' <+> ppLType unicode ltype
+
+ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
+
+
+-------------------------------------------------------------------------------
+-- * Function signatures
+-------------------------------------------------------------------------------
+
+
+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
+ -> Bool -> LaTeX
+ppFunSig loc doc docnames typ unicode =
+ ppTypeOrFunSig loc docnames typ doc
+ ( ppTypeSig names typ False
+ , hsep . punctuate comma $ map ppSymName names
+ , dcolon unicode)
+ unicode
+ where
+ names = map getName docnames
+
+ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
+ -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
+ -> LHsContext DocName -> LHsContext DocName
+ -> Bool -> LaTeX
+ppLPatSig loc doc docname args typ prov req unicode =
+ ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode
+
+ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName
+ -> HsPatSynDetails (HsType DocName) -> HsType DocName
+ -> HsContext DocName -> HsContext DocName
+ -> Bool -> LaTeX
+ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)
+ where
+ pref1 = hsep [ keyword "pattern"
+ , pp_ctx prov
+ , pp_head
+ , dcolon unicode
+ , pp_ctx req
+ , ppType unicode typ
+ ]
+
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]
+
+ pp_type = ppParendType unicode
+ pp_ctx ctx = ppContext ctx unicode
+
+ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
+ -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
+ -> Bool -> LaTeX
+ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
+ unicode
+ | Map.null argDocs =
+ declWithDoc pref1 (documentationToLaTeX doc)
+ | otherwise =
+ declWithDoc pref2 $ Just $
+ text "\\haddockbeginargs" $$
+ do_args 0 sep0 typ $$
+ text "\\end{tabulary}\\par" $$
+ fromMaybe empty (documentationToLaTeX doc)
+ where
+ do_largs n leader (L _ t) = do_args n leader t
+
+ arg_doc n = rDoc (Map.lookup n argDocs)
+
+ do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
+ do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+ = decltt leader <->
+ decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
+ ppLContextNoArrow lctxt unicode) <+> nl $$
+ do_largs n (darrow unicode) ltype
+
+ do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+ | not (null (unLoc lctxt))
+ = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
+ do_largs n (darrow unicode) ltype
+ -- if we're not showing any 'forall' or class constraints or
+ -- anything, skip having an empty line for the context.
+ | otherwise
+ = do_largs n leader ltype
+ do_args n leader (HsFunTy lt r)
+ = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
+ do_largs (n+1) (arrow unicode) r
+ do_args n leader t
+ = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl
+
+
+ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX
+ppTypeSig nms ty unicode =
+ hsep (punctuate comma $ map ppSymName nms)
+ <+> dcolon unicode
+ <+> ppType unicode ty
+
+
+ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
+ppTyVars tvs = map ppSymName (tyvarNames tvs)
+
+
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
+
+
+declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
+declWithDoc decl doc =
+ text "\\begin{haddockdesc}" $$
+ text "\\item[\\begin{tabular}{@{}l}" $$
+ text (latexMonoFilter (show decl)) $$
+ text "\\end{tabular}]" <>
+ (if isNothing doc then empty else text "\\haddockbegindoc") $$
+ maybe empty id doc $$
+ text "\\end{haddockdesc}"
+
+
+-- in a group of decls, we don't put them all in the same tabular,
+-- because that would prevent the group being broken over a page
+-- boundary (breaks Foreign.C.Error for example).
+multiDecl :: [LaTeX] -> LaTeX
+multiDecl decls =
+ text "\\begin{haddockdesc}" $$
+ vcat [
+ text "\\item[" $$
+ text (latexMonoFilter (show decl)) $$
+ text "]"
+ | decl <- decls ] $$
+ text "\\end{haddockdesc}"
+
+
+-------------------------------------------------------------------------------
+-- * Rendering Doc
+-------------------------------------------------------------------------------
+
+
+maybeDoc :: Maybe (Doc DocName) -> LaTeX
+maybeDoc = maybe empty docToLaTeX
+
+
+-- for table cells, we strip paragraphs out to avoid extra vertical space
+-- and don't add a quote environment.
+rDoc :: Maybe (Doc DocName) -> LaTeX
+rDoc = maybeDoc . fmap latexStripTrailingWhitespace
+
+
+-------------------------------------------------------------------------------
+-- * Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+ -> Bool -> LaTeX
+ppClassHdr summ lctxt n tvs fds unicode =
+ keyword "class"
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
+ <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
+ <+> ppFds fds unicode
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX
+ppFds fds unicode =
+ if null fds then empty else
+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+ where
+ fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
+ hsep (map ppDocName vars2)
+
+
+ppClassDecl :: [DocInstance DocName] -> SrcSpan
+ -> Documentation DocName -> [(DocName, DocForDecl DocName)]
+ -> TyClDecl DocName -> Bool -> LaTeX
+ppClassDecl instances loc doc subdocs
+ (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
+ , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
+ = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
+ instancesBit
+ where
+ classheader
+ | null lsigs = hdr unicode
+ | otherwise = hdr unicode <+> keyword "where"
+
+ hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
+
+ body = catMaybes [documentationToLaTeX doc, body_]
+
+ body_
+ | null lsigs, null ats, null at_defs = Nothing
+ | null ats, null at_defs = Just methodTable
+--- | otherwise = atTable $$ methodTable
+ | otherwise = error "LaTeX.ppClassDecl"
+
+ methodTable =
+ text "\\haddockpremethods{}\\textbf{Methods}" $$
+ vcat [ ppFunSig loc doc names typ unicode
+ | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
+
+ instancesBit = ppDocInstances unicode instances
+
+ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX
+ppDocInstances _unicode [] = empty
+ppDocInstances unicode (i : rest)
+ | Just ihead <- isUndocdInstance i
+ = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$
+ ppDocInstances unicode rest'
+ | otherwise
+ = ppDocInstance unicode i $$ ppDocInstances unicode rest
+ where
+ (is, rest') = spanWith isUndocdInstance rest
+
+isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
+isUndocdInstance (i,Nothing) = Just i
+isUndocdInstance _ = Nothing
+
+-- | Print a possibly commented instance. The instance header is printed inside
+-- an 'argBox'. The comment is printed to the right of the box in normal comment
+-- style.
+ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
+ppDocInstance unicode (instHead, doc) =
+ declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)
+
+
+ppInstDecl :: Bool -> InstHead DocName -> LaTeX
+ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
+
+
+ppInstHead :: Bool -> InstHead DocName -> LaTeX
+ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
+ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ks ts unicode
+ <+> maybe empty (\t -> equals <+> ppType unicode t) rhs
+ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
+ error "data instances not supported by --latex yet"
+
+lookupAnySubdoc :: (Eq name1) =>
+ name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
+lookupAnySubdoc n subdocs = case lookup n subdocs of
+ Nothing -> noDocForDecl
+ Just docs -> docs
+
+
+-------------------------------------------------------------------------------
+-- * Data & newtype declarations
+-------------------------------------------------------------------------------
+
+
+ppDataDecl :: [DocInstance DocName] ->
+ [(DocName, DocForDecl DocName)] -> SrcSpan ->
+ Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
+ LaTeX
+ppDataDecl instances subdocs _loc doc dataDecl unicode
+
+ = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
+ (if null body then Nothing else Just (vcat body))
+ $$ instancesBit
+
+ where
+ cons = dd_cons (tcdDataDefn dataDecl)
+ resTy = (con_res . unLoc . head) cons
+
+ body = catMaybes [constrBit, doc >>= documentationToLaTeX]
+
+ (whereBit, leaders)
+ | null cons = (empty,[])
+ | otherwise = case resTy of
+ ResTyGADT _ -> (decltt (keyword "where"), repeat empty)
+ _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
+
+ constrBit
+ | null cons = Nothing
+ | otherwise = Just $
+ text "\\haddockbeginconstrs" $$
+ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
+ text "\\end{tabulary}\\par"
+
+ instancesBit = ppDocInstances unicode instances
+
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX
+ppConstrHdr forall tvs ctxt unicode
+ = (if null tvs then empty else ppForall)
+ <+>
+ (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
+ where
+ ppForall = case forall of
+ Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
+ Implicit -> empty
+
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
+ -> LConDecl DocName -> LaTeX
+ppSideBySideConstr subdocs unicode leader (L _ con) =
+ leader <->
+ case con_res con of
+ ResTyH98 -> case con_details con of
+
+ PrefixCon args ->
+ decltt (hsep ((header_ unicode <+> ppBinder occ) :
+ map (ppLParendType unicode) args))
+ <-> rDoc mbDoc <+> nl
+
+ RecCon fields ->
+ (decltt (header_ unicode <+> ppBinder occ)
+ <-> rDoc mbDoc <+> nl)
+ $$
+ doRecordFields fields
+
+ InfixCon arg1 arg2 ->
+ decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
+ ppBinder occ,
+ ppLParendType unicode arg2 ])
+ <-> rDoc mbDoc <+> nl
+
+ ResTyGADT resTy -> case con_details con of
+ -- prefix & infix could also use hsConDeclArgTys if it seemed to
+ -- simplify the code.
+ PrefixCon args -> doGADTCon args resTy
+ cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
+ doRecordFields fields
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+ where
+ doRecordFields fields =
+ vcat (map (ppSideBySideField subdocs unicode) fields)
+
+ doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [
+ ppForAll forall ltvs (con_cxt con) unicode,
+ ppLType unicode (foldr mkFunTy resTy args) ]
+ ) <-> rDoc mbDoc
+
+
+ header_ = ppConstrHdr forall tyVars context
+ occ = nameOccName . getName . unLoc . con_name $ con
+ ltvs = con_qvars con
+ tyVars = tyvarNames (con_qvars con)
+ context = unLoc (con_cxt con)
+ forall = con_explicit con
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
+ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
+ decltt (ppBinder (nameOccName . getName $ name)
+ <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
+ where
+ -- don't use cd_fld_doc for same reason we don't use con_doc above
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
+
+-- {-
+-- ppHsFullConstr :: HsConDecl -> LaTeX
+-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =
+-- declWithDoc False doc (
+-- hsep ((ppHsConstrHdr tvs ctxt +++
+-- ppHsBinder False nm) : map ppHsBangType typeList)
+-- )
+-- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
+-- td << vanillaTable << (
+-- case doc of
+-- Nothing -> aboves [hdr, fields_html]
+-- Just _ -> aboves [hdr, constr_doc, fields_html]
+-- )
+--
+-- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
+--
+-- constr_doc
+-- | isJust doc = docBox (docToLaTeX (fromJust doc))
+-- | otherwise = LaTeX.emptyTable
+--
+-- fields_html =
+-- td <<
+-- table ! [width "100%", cellpadding 0, cellspacing 8] << (
+-- aboves (map ppFullField (concat (map expandField fields)))
+-- )
+-- -}
+--
+-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX
+-- ppShortField summary unicode (ConDeclField (L _ name) ltype _)
+-- = tda [theclass "recfield"] << (
+-- ppBinder summary (docNameOcc name)
+-- <+> dcolon unicode <+> ppLType unicode ltype
+-- )
+--
+-- {-
+-- ppFullField :: HsFieldDecl -> LaTeX
+-- ppFullField (HsFieldDecl [n] ty doc)
+-- = declWithDoc False doc (
+-- ppHsBinder False n <+> dcolon <+> ppHsBangType ty
+-- )
+-- ppFullField _ = error "ppFullField"
+--
+-- expandField :: HsFieldDecl -> [HsFieldDecl]
+-- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
+-- -}
+
+
+-- | Print the LHS of a data\/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
+ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
+ , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
+ -- context
+ ppLContext ctxt unicode <+>
+ -- T a b c ..., or a :+: b
+ ppAppDocNameNames False name (tyvarNames tyvars)
+ppDataHeader _ _ = error "ppDataHeader: illegal argument"
+
+--------------------------------------------------------------------------------
+-- * Type applications
+--------------------------------------------------------------------------------
+
+
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX
+ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)
+
+
+-- | Print an application of a DocName and a list of Names
+ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
+ppAppDocNameNames _summ n ns =
+ ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName
+
+
+-- | General printing of type applications
+ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
+ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
+ | operator = opApp
+ where
+ operator = isNameSym . getName $ n
+ opApp = ppT t1 <+> ppDN n <+> ppT t2
+
+ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
+
+
+-------------------------------------------------------------------------------
+-- * Contexts
+-------------------------------------------------------------------------------
+
+
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
+ppLContext = ppContext . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX
+ppContextNoArrow [] _ = empty
+ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
+
+
+ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
+ppContextNoLocs [] _ = empty
+ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
+
+
+ppContext :: HsContext DocName -> Bool -> LaTeX
+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
+
+
+pp_hs_context :: [HsType DocName] -> Bool -> LaTeX
+pp_hs_context [] _ = empty
+pp_hs_context [p] unicode = ppType unicode p
+pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
+
+
+-------------------------------------------------------------------------------
+-- * Types and contexts
+-------------------------------------------------------------------------------
+
+
+ppBang :: HsBang -> LaTeX
+ppBang HsNoBang = empty
+ppBang _ = char '!' -- Unpacked args is an implementation detail,
+
+
+tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
+tupleParens HsUnboxedTuple = ubxParenList
+tupleParens _ = parenList
+
+
+-------------------------------------------------------------------------------
+-- * Rendering of HsType
+--
+-- Stolen from Html and tweaked for LaTeX generation
+-------------------------------------------------------------------------------
+
+
+pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
+
+pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC
+pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC
+ -- Used for LH arg of (->)
+pREC_OP = (2 :: Int) -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = (3 :: Int) -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
+
+maybeParen :: Int -- Precedence of context
+ -> Int -- Precedence of top-level operator
+ -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+ | otherwise = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX
+ppLType unicode y = ppType unicode (unLoc y)
+ppLParendType unicode y = ppParendType unicode (unLoc y)
+ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
+
+
+ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX
+ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
+ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
+ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode
+
+ppLKind :: Bool -> LHsKind DocName -> LaTeX
+ppLKind unicode y = ppKind unicode (unLoc y)
+
+ppKind :: Bool -> HsKind DocName -> LaTeX
+ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
+
+
+-- Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
+ -> Located (HsContext DocName) -> Bool -> LaTeX
+ppForAll expl tvs cxt unicode
+ | show_forall = forall_part <+> ppLContext cxt unicode
+ | otherwise = ppLContext cxt unicode
+ where
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
+ is_explicit = case expl of {Explicit -> True; Implicit -> False}
+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+
+
+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
+
+
+ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
+ = maybeParen ctxt_prec pREC_FUN $
+ hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
+
+ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
+ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
+ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
+ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
+ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
+ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy"
+
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
+ = maybeParen ctxt_prec pREC_OP $
+ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
+ = maybeParen ctxt_prec pREC_CON $
+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode
+ = maybeParen ctxt_prec pREC_FUN $
+ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
+ where
+ ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
+ occName = nameOccName . getName . unLoc $ op
+
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode
+-- = parens (ppr_mono_lty pREC_TOP ty)
+ = ppr_mono_lty ctxt_prec ty unicode
+
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
+ = ppr_mono_lty ctxt_prec ty unicode
+
+ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
+
+
+ppr_tylit :: HsTyLit -> Bool -> LaTeX
+ppr_tylit (HsNumTy n) _ = integer n
+ppr_tylit (HsStrTy s) _ = text (show s)
+ -- XXX: Ok in verbatim, but not otherwise
+ -- XXX: Do something with Unicode parameter?
+
+
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
+ppr_fun_ty ctxt_prec ty1 ty2 unicode
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode
+ in
+ maybeParen ctxt_prec pREC_FUN $
+ sep [p1, arrow unicode <+> p2]
+
+
+-------------------------------------------------------------------------------
+-- * Names
+-------------------------------------------------------------------------------
+
+
+ppBinder :: OccName -> LaTeX
+ppBinder n
+ | isInfixName n = parens $ ppOccName n
+ | otherwise = ppOccName n
+
+ppBinderInfix :: OccName -> LaTeX
+ppBinderInfix n
+ | isInfixName n = ppOccName n
+ | otherwise = quotes $ ppOccName n
+
+isInfixName :: OccName -> Bool
+isInfixName n = isVarSym n || isConSym n
+
+ppSymName :: Name -> LaTeX
+ppSymName name
+ | isNameSym name = parens $ ppName name
+ | otherwise = ppName name
+
+
+ppVerbOccName :: OccName -> LaTeX
+ppVerbOccName = text . latexFilter . occNameString
+
+ppIPName :: HsIPName -> LaTeX
+ppIPName ip = text $ unpackFS $ hsIPNameFS ip
+
+ppOccName :: OccName -> LaTeX
+ppOccName = text . occNameString
+
+
+ppVerbDocName :: DocName -> LaTeX
+ppVerbDocName = ppVerbOccName . nameOccName . getName
+
+
+ppVerbRdrName :: RdrName -> LaTeX
+ppVerbRdrName = ppVerbOccName . rdrNameOcc
+
+
+ppDocName :: DocName -> LaTeX
+ppDocName = ppOccName . nameOccName . getName
+
+
+ppLDocName :: Located DocName -> LaTeX
+ppLDocName (L _ d) = ppDocName d
+
+
+ppDocBinder :: DocName -> LaTeX
+ppDocBinder = ppBinder . nameOccName . getName
+
+ppDocBinderInfix :: DocName -> LaTeX
+ppDocBinderInfix = ppBinderInfix . nameOccName . getName
+
+
+ppName :: Name -> LaTeX
+ppName = ppOccName . nameOccName
+
+
+latexFilter :: String -> String
+latexFilter = foldr latexMunge ""
+
+
+latexMonoFilter :: String -> String
+latexMonoFilter = foldr latexMonoMunge ""
+
+
+latexMunge :: Char -> String -> String
+latexMunge '#' s = "{\\char '43}" ++ s
+latexMunge '$' s = "{\\char '44}" ++ s
+latexMunge '%' s = "{\\char '45}" ++ s
+latexMunge '&' s = "{\\char '46}" ++ s
+latexMunge '~' s = "{\\char '176}" ++ s
+latexMunge '_' s = "{\\char '137}" ++ s
+latexMunge '^' s = "{\\char '136}" ++ s
+latexMunge '\\' s = "{\\char '134}" ++ s
+latexMunge '{' s = "{\\char '173}" ++ s
+latexMunge '}' s = "{\\char '175}" ++ s
+latexMunge '[' s = "{\\char 91}" ++ s
+latexMunge ']' s = "{\\char 93}" ++ s
+latexMunge c s = c : s
+
+
+latexMonoMunge :: Char -> String -> String
+latexMonoMunge ' ' s = '\\' : ' ' : s
+latexMonoMunge '\n' s = '\\' : '\\' : s
+latexMonoMunge c s = latexMunge c s
+
+
+-------------------------------------------------------------------------------
+-- * Doc Markup
+-------------------------------------------------------------------------------
+
+
+parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
+parLatexMarkup ppId = Markup {
+ markupParagraph = \p v -> p v <> text "\\par" $$ text "",
+ markupEmpty = \_ -> empty,
+ markupString = \s v -> text (fixString v s),
+ markupAppend = \l r v -> l v <> r v,
+ markupIdentifier = markupId ppId,
+ markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
+ markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
+ markupWarning = \p v -> emph (p v),
+ markupEmphasis = \p v -> emph (p v),
+ markupBold = \p v -> bold (p v),
+ markupMonospaced = \p _ -> tt (p Mono),
+ markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
+ markupPic = \p _ -> markupPic p,
+ markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
+ markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
+ markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
+ markupHyperlink = \l _ -> markupLink l,
+ markupAName = \_ _ -> empty,
+ markupProperty = \p _ -> quote $ verb $ text p,
+ markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
+ markupHeader = \(Header l h) p -> header l (h p)
+ }
+ where
+ header 1 d = text "\\section*" <> braces d
+ header 2 d = text "\\subsection*" <> braces d
+ header l d
+ | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
+ header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
+
+ fixString Plain s = latexFilter s
+ fixString Verb s = s
+ fixString Mono s = latexMonoFilter s
+
+ markupLink (Hyperlink url mLabel) = case mLabel of
+ Just label -> text "\\href" <> braces (text url) <> braces (text label)
+ Nothing -> text "\\url" <> braces (text url)
+
+ -- Is there a better way of doing this? Just a space is an aribtrary choice.
+ markupPic (Picture uri title) = parens (imageText title)
+ where
+ imageText Nothing = beg
+ imageText (Just t) = beg <> text " " <> text t
+
+ beg = text "image: " <> text uri
+
+ markupId ppId_ id v =
+ case v of
+ Verb -> theid
+ Mono -> theid
+ Plain -> text "\\haddockid" <> braces theid
+ where theid = ppId_ id
+
+
+latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
+latexMarkup = parLatexMarkup ppVerbDocName
+
+
+rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
+rdrLatexMarkup = parLatexMarkup ppVerbRdrName
+
+
+docToLaTeX :: Doc DocName -> LaTeX
+docToLaTeX doc = markup latexMarkup doc Plain
+
+
+documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
+documentationToLaTeX = fmap docToLaTeX . combineDocumentation
+
+
+rdrDocToLaTeX :: Doc RdrName -> LaTeX
+rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain
+
+
+data StringContext = Plain | Verb | Mono
+
+
+latexStripTrailingWhitespace :: Doc a -> Doc a
+latexStripTrailingWhitespace (DocString s)
+ | null s' = DocEmpty
+ | otherwise = DocString s
+ where s' = reverse (dropWhile isSpace (reverse s))
+latexStripTrailingWhitespace (DocAppend l r)
+ | DocEmpty <- r' = latexStripTrailingWhitespace l
+ | otherwise = DocAppend l r'
+ where
+ r' = latexStripTrailingWhitespace r
+latexStripTrailingWhitespace (DocParagraph p) =
+ latexStripTrailingWhitespace p
+latexStripTrailingWhitespace other = other
+
+
+-------------------------------------------------------------------------------
+-- * LaTeX utils
+-------------------------------------------------------------------------------
+
+
+itemizedList :: [LaTeX] -> LaTeX
+itemizedList items =
+ text "\\begin{itemize}" $$
+ vcat (map (text "\\item" $$) items) $$
+ text "\\end{itemize}"
+
+
+enumeratedList :: [LaTeX] -> LaTeX
+enumeratedList items =
+ text "\\begin{enumerate}" $$
+ vcat (map (text "\\item " $$) items) $$
+ text "\\end{enumerate}"
+
+
+descriptionList :: [(LaTeX,LaTeX)] -> LaTeX
+descriptionList items =
+ text "\\begin{description}" $$
+ vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$
+ text "\\end{description}"
+
+
+tt :: LaTeX -> LaTeX
+tt ltx = text "\\haddocktt" <> braces ltx
+
+
+decltt :: LaTeX -> LaTeX
+decltt ltx = text "\\haddockdecltt" <> braces ltx
+
+
+emph :: LaTeX -> LaTeX
+emph ltx = text "\\emph" <> braces ltx
+
+bold :: LaTeX -> LaTeX
+bold ltx = text "\\textbf" <> braces ltx
+
+verb :: LaTeX -> LaTeX
+verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
+ -- NB. swallow a trailing \n in the verbatim text by appending the
+ -- \end{verbatim} directly, otherwise we get spurious blank lines at the
+ -- end of code blocks.
+
+
+quote :: LaTeX -> LaTeX
+quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
+
+
+dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX
+dcolon unicode = text (if unicode then "∷" else "::")
+arrow unicode = text (if unicode then "→" else "->")
+darrow unicode = text (if unicode then "⇒" else "=>")
+forallSymbol unicode = text (if unicode then "∀" else "forall")
+
+
+dot :: LaTeX
+dot = char '.'
+
+
+parenList :: [LaTeX] -> LaTeX
+parenList = parens . hsep . punctuate comma
+
+
+ubxParenList :: [LaTeX] -> LaTeX
+ubxParenList = ubxparens . hsep . punctuate comma
+
+
+ubxparens :: LaTeX -> LaTeX
+ubxparens h = text "(#" <> h <> text "#)"
+
+
+pabrackets :: LaTeX -> LaTeX
+pabrackets h = text "[:" <> h <> text ":]"
+
+
+nl :: LaTeX
+nl = text "\\\\"
+
+
+keyword :: String -> LaTeX
+keyword = text
+
+
+infixr 4 <-> -- combining table cells
+(<->) :: LaTeX -> LaTeX -> LaTeX
+a <-> b = a <+> char '&' <+> b
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
new file mode 100644
index 00000000..9628a33d
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -0,0 +1,690 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
+module Haddock.Backends.Xhtml (
+ ppHtml, copyHtmlBits,
+ ppHtmlIndex, ppHtmlContents,
+) where
+
+
+import Prelude hiding (div)
+
+import Haddock.Backends.Xhtml.Decl
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Themes
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.ModuleTree
+import Haddock.Types
+import Haddock.Version
+import Haddock.Utils
+import Text.XHtml hiding ( name, title, p, quote )
+import Haddock.GhcUtils
+
+import Control.Monad ( when, unless )
+#if !MIN_VERSION_base(4,7,0)
+import Control.Monad.Instances ( ) -- for Functor Either a
+#endif
+import Data.Char ( toUpper )
+import Data.Functor ( (<$>) )
+import Data.List ( sortBy, groupBy, intercalate, isPrefixOf )
+import Data.Maybe
+import System.FilePath hiding ( (</>) )
+import System.Directory
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import qualified Data.Set as Set hiding ( Set )
+import Data.Function
+import Data.Ord ( comparing )
+
+import DynFlags (Language(..))
+import GHC hiding ( NoLink, moduleInfo )
+import Name
+import Module
+
+--------------------------------------------------------------------------------
+-- * Generating HTML documentation
+--------------------------------------------------------------------------------
+
+
+ppHtml :: String
+ -> Maybe String -- ^ Package
+ -> [Interface]
+ -> FilePath -- ^ Destination directory
+ -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe
+ -> Themes -- ^ Themes
+ -> SourceURLs -- ^ The source URL (--source)
+ -> WikiURLs -- ^ The wiki URL (--wiki)
+ -> Maybe String -- ^ The contents URL (--use-contents)
+ -> Maybe String -- ^ The index URL (--use-index)
+ -> Bool -- ^ Whether to use unicode in output (--use-unicode)
+ -> QualOption -- ^ How to qualify names
+ -> Bool -- ^ Output pretty html (newlines and indenting)
+ -> IO ()
+
+ppHtml doctitle maybe_package ifaces odir prologue
+ themes maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url unicode
+ qual debug = do
+ let
+ visible_ifaces = filter visible ifaces
+ visible i = OptHide `notElem` ifaceOptions i
+
+ when (isNothing maybe_contents_url) $
+ ppHtmlContents odir doctitle maybe_package
+ themes maybe_index_url maybe_source_url maybe_wiki_url
+ (map toInstalledIface visible_ifaces)
+ False -- we don't want to display the packages in a single-package contents
+ prologue debug (makeContentsQual qual)
+
+ when (isNothing maybe_index_url) $
+ ppHtmlIndex odir doctitle maybe_package
+ themes maybe_contents_url maybe_source_url maybe_wiki_url
+ (map toInstalledIface visible_ifaces) debug
+
+ mapM_ (ppHtmlModule odir doctitle themes
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
+
+
+copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
+copyHtmlBits odir libdir themes = do
+ let
+ libhtmldir = joinPath [libdir, "html"]
+ copyCssFile f = copyFile f (combine odir (takeFileName f))
+ copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
+ mapM_ copyCssFile (cssFiles themes)
+ mapM_ copyLibFile [ jsFile, framesFile ]
+
+
+headHtml :: String -> Maybe String -> Themes -> Html
+headHtml docTitle miniPage themes =
+ header << [
+ meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
+ thetitle << docTitle,
+ styleSheet themes,
+ script ! [src jsFile, thetype "text/javascript"] << noHtml,
+ script ! [thetype "text/javascript"]
+ -- NB: Within XHTML, the content of script tags needs to be
+ -- a <![CDATA[ section. Will break if the miniPage name could
+ -- have "]]>" in it!
+ << primHtml (
+ "//<![CDATA[\nwindow.onload = function () {pageLoad();"
+ ++ setSynopsis ++ "};\n//]]>\n")
+ ]
+ where
+ setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
+
+
+srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
+srcButton (Just src_base_url, _, _, _) Nothing =
+ Just (anchor ! [href src_base_url] << "Source")
+srcButton (_, Just src_module_url, _, _) (Just iface) =
+ let url = spliceURL (Just $ ifaceOrigFilename iface)
+ (Just $ ifaceMod iface) Nothing Nothing src_module_url
+ in Just (anchor ! [href url] << "Source")
+srcButton _ _ =
+ Nothing
+
+
+wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
+wikiButton (Just wiki_base_url, _, _) Nothing =
+ Just (anchor ! [href wiki_base_url] << "User Comments")
+
+wikiButton (_, Just wiki_module_url, _) (Just mdl) =
+ let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
+ in Just (anchor ! [href url] << "User Comments")
+
+wikiButton _ _ =
+ Nothing
+
+
+contentsButton :: Maybe String -> Maybe Html
+contentsButton maybe_contents_url
+ = Just (anchor ! [href url] << "Contents")
+ where url = fromMaybe contentsHtmlFile maybe_contents_url
+
+
+indexButton :: Maybe String -> Maybe Html
+indexButton maybe_index_url
+ = Just (anchor ! [href url] << "Index")
+ where url = fromMaybe indexHtmlFile maybe_index_url
+
+
+bodyHtml :: String -> Maybe Interface
+ -> SourceURLs -> WikiURLs
+ -> Maybe String -> Maybe String
+ -> Html -> Html
+bodyHtml doctitle iface
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url
+ pageContent =
+ body << [
+ divPackageHeader << [
+ unordList (catMaybes [
+ srcButton maybe_source_url iface,
+ wikiButton maybe_wiki_url (ifaceMod <$> iface),
+ contentsButton maybe_contents_url,
+ indexButton maybe_index_url])
+ ! [theclass "links", identifier "page-menu"],
+ nonEmptySectionName << doctitle
+ ],
+ divContent << pageContent,
+ divFooter << paragraph << (
+ "Produced by " +++
+ (anchor ! [href projectUrl] << toHtml projectName) +++
+ (" version " ++ projectVersion)
+ )
+ ]
+
+
+moduleInfo :: Interface -> Html
+moduleInfo iface =
+ let
+ info = ifaceInfo iface
+
+ doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
+ doOneEntry (fieldName, field) =
+ field info >>= \a -> return (th << fieldName <-> td << a)
+
+ entries :: [HtmlTable]
+ entries = mapMaybe doOneEntry [
+ ("Copyright",hmi_copyright),
+ ("License",hmi_license),
+ ("Maintainer",hmi_maintainer),
+ ("Stability",hmi_stability),
+ ("Portability",hmi_portability),
+ ("Safe Haskell",hmi_safety),
+ ("Language", lg)
+ ] ++ extsForm
+ where
+ lg inf = case hmi_language inf of
+ Nothing -> Nothing
+ Just Haskell98 -> Just "Haskell98"
+ Just Haskell2010 -> Just "Haskell2010"
+
+ extsForm
+ | OptShowExtensions `elem` ifaceOptions iface =
+ let fs = map (dropOpt . show) (hmi_extensions info)
+ in case map stringToHtml fs of
+ [] -> []
+ [x] -> extField x -- don't use a list for a single extension
+ xs -> extField $ unordList xs ! [theclass "extension-list"]
+ | otherwise = []
+ where
+ extField x = return $ th << "Extensions" <-> td << x
+ dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
+ in
+ case entries of
+ [] -> noHtml
+ _ -> table ! [theclass "info"] << aboves entries
+
+
+--------------------------------------------------------------------------------
+-- * Generate the module contents
+--------------------------------------------------------------------------------
+
+
+ppHtmlContents
+ :: FilePath
+ -> String
+ -> Maybe String
+ -> Themes
+ -> Maybe String
+ -> SourceURLs
+ -> WikiURLs
+ -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
+ -> Bool
+ -> Qualification -- ^ How to qualify names
+ -> IO ()
+ppHtmlContents odir doctitle _maybe_package
+ themes maybe_index_url
+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
+ let tree = mkModuleTree showPkgs
+ [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
+ html =
+ headHtml doctitle Nothing themes +++
+ bodyHtml doctitle Nothing
+ maybe_source_url maybe_wiki_url
+ Nothing maybe_index_url << [
+ ppPrologue qual doctitle prologue,
+ ppModuleTree qual tree
+ ]
+ createDirectoryIfMissing True odir
+ writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
+
+ -- XXX: think of a better place for this?
+ ppHtmlContentsFrame odir doctitle themes ifaces debug
+
+
+ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html
+ppPrologue _ _ Nothing = noHtml
+ppPrologue qual title (Just doc) =
+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
+
+
+ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree qual ts =
+ divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
+
+
+mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
+mkNodeList qual ss p ts = case ts of
+ [] -> noHtml
+ _ -> unordList (zipWith (mkNode qual ss) ps ts)
+ where
+ ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
+
+
+mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
+mkNode qual ss p (Node s leaf pkg short ts) =
+ htmlModule <+> shortDescr +++ htmlPkg +++ subtree
+ where
+ modAttrs = case (ts, leaf) of
+ (_:_, False) -> collapseControl p True "module"
+ (_, _ ) -> [theclass "module"]
+
+ cBtn = case (ts, leaf) of
+ (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml
+ (_, _ ) -> noHtml
+ -- We only need an explicit collapser button when the module name
+ -- is also a leaf, and so is a link to a module page. Indeed, the
+ -- spaceHtml is a minor hack and does upset the layout a fraction.
+
+ htmlModule = thespan ! modAttrs << (cBtn +++
+ if leaf
+ then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
+ (mkModuleName mdl))
+ else toHtml s
+ )
+
+ mdl = intercalate "." (reverse (s:ss))
+
+ shortDescr = maybe noHtml (origDocToHtml qual) short
+ htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
+
+ subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
+
+
+-- | Turn a module tree into a flat list of full module names. E.g.,
+-- @
+-- A
+-- +-B
+-- +-C
+-- @
+-- becomes
+-- @["A", "A.B", "A.B.C"]@
+flatModuleTree :: [InstalledInterface] -> [Html]
+flatModuleTree ifaces =
+ map (uncurry ppModule' . head)
+ . groupBy ((==) `on` fst)
+ . sortBy (comparing fst)
+ $ mods
+ where
+ mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
+ ppModule' txt mdl =
+ anchor ! [href (moduleHtmlFile mdl), target mainFrameName]
+ << toHtml txt
+
+
+ppHtmlContentsFrame :: FilePath -> String -> Themes
+ -> [InstalledInterface] -> Bool -> IO ()
+ppHtmlContentsFrame odir doctitle themes ifaces debug = do
+ let mods = flatModuleTree ifaces
+ html =
+ headHtml doctitle Nothing themes +++
+ miniBody << divModuleList <<
+ (sectionName << "Modules" +++
+ ulist << [ li ! [theclass "module"] << m | m <- mods ])
+ createDirectoryIfMissing True odir
+ writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)
+
+
+--------------------------------------------------------------------------------
+-- * Generate the index
+--------------------------------------------------------------------------------
+
+
+ppHtmlIndex :: FilePath
+ -> String
+ -> Maybe String
+ -> Themes
+ -> Maybe String
+ -> SourceURLs
+ -> WikiURLs
+ -> [InstalledInterface]
+ -> Bool
+ -> IO ()
+ppHtmlIndex odir doctitle _maybe_package themes
+ maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
+ let html = indexPage split_indices Nothing
+ (if split_indices then [] else index)
+
+ createDirectoryIfMissing True odir
+
+ when split_indices $ do
+ mapM_ (do_sub_index index) initialChars
+ -- Let's add a single large index as well for those who don't know exactly what they're looking for:
+ let mergedhtml = indexPage False Nothing index
+ writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
+
+ writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)
+
+ where
+ indexPage showLetters ch items =
+ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++
+ bodyHtml doctitle Nothing
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url Nothing << [
+ if showLetters then indexInitialLetterLinks else noHtml,
+ if null items then noHtml else
+ divIndex << [sectionName << indexName ch, buildIndex items]
+ ]
+
+ indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
+ merged_name = "All"
+
+ buildIndex items = table << aboves (map indexElt items)
+
+ -- an arbitrary heuristic:
+ -- too large, and a single-page will be slow to load
+ -- too small, and we'll have lots of letter-indexes with only one
+ -- or two members in them, which seems inefficient or
+ -- unnecessarily hard to use.
+ split_indices = length index > 150
+
+ indexInitialLetterLinks =
+ divAlphabet <<
+ unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
+ [ [c] | c <- initialChars
+ , any ((==c) . toUpper . head . fst) index ] ++
+ [merged_name])
+
+ -- todo: what about names/operators that start with Unicode
+ -- characters?
+ -- Exports beginning with '_' can be listed near the end,
+ -- presumably they're not as important... but would be listed
+ -- with non-split index!
+ initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
+
+ do_sub_index this_ix c
+ = unless (null index_part) $
+ writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
+ where
+ html = indexPage True (Just c) index_part
+ index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
+
+
+ index :: [(String, Map GHC.Name [(Module,Bool)])]
+ index = sortBy cmp (Map.toAscList full_index)
+ where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2
+
+ -- for each name (a plain string), we have a number of original HsNames that
+ -- it can refer to, and for each of those we have a list of modules
+ -- that export that entity. Each of the modules exports the entity
+ -- in a visible or invisible way (hence the Bool).
+ full_index :: Map String (Map GHC.Name [(Module,Bool)])
+ full_index = Map.fromListWith (flip (Map.unionWith (++)))
+ (concatMap getIfaceIndex ifaces)
+
+ getIfaceIndex iface =
+ [ (getOccString name
+ , Map.fromList [(name, [(mdl, name `Set.member` visible)])])
+ | name <- instExports iface ]
+ where
+ mdl = instMod iface
+ visible = Set.fromList (instVisibleExports iface)
+
+ indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
+ indexElt (str, entities) =
+ case Map.toAscList entities of
+ [(nm,entries)] ->
+ td ! [ theclass "src" ] << toHtml str <->
+ indexLinks nm entries
+ many_entities ->
+ td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
+ aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)
+
+ doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
+ doAnnotatedEntity (j,(nm,entries))
+ = td ! [ theclass "alt" ] <<
+ toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
+ indexLinks nm entries
+
+ ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
+ | isDataOcc n = toHtml "Data Constructor"
+ | otherwise = toHtml "Function"
+
+ indexLinks nm entries =
+ td ! [ theclass "module" ] <<
+ hsep (punctuate comma
+ [ if visible then
+ linkId mdl (Just nm) << toHtml (moduleString mdl)
+ else
+ toHtml (moduleString mdl)
+ | (mdl, visible) <- entries ])
+
+
+--------------------------------------------------------------------------------
+-- * Generate the HTML page for a module
+--------------------------------------------------------------------------------
+
+
+ppHtmlModule
+ :: FilePath -> String -> Themes
+ -> SourceURLs -> WikiURLs
+ -> Maybe String -> Maybe String -> Bool -> QualOption
+ -> Bool -> Interface -> IO ()
+ppHtmlModule odir doctitle themes
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url unicode qual debug iface = do
+ let
+ mdl = ifaceMod iface
+ aliases = ifaceModuleAliases iface
+ mdl_str = moduleString mdl
+ real_qual = makeModuleQual qual aliases mdl
+ html =
+ headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
+ bodyHtml doctitle (Just iface)
+ maybe_source_url maybe_wiki_url
+ maybe_contents_url maybe_index_url << [
+ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
+ ]
+
+ createDirectoryIfMissing True odir
+ writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
+ ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
+
+ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
+ -> Interface -> Bool -> Qualification -> Bool -> IO ()
+ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
+ let mdl = ifaceMod iface
+ html =
+ headHtml (moduleString mdl) Nothing themes +++
+ miniBody <<
+ (divModuleHeader << sectionName << moduleString mdl +++
+ miniSynopsis mdl iface unicode qual)
+ createDirectoryIfMissing True odir
+ writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
+
+
+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
+ = ppModuleContents qual exports +++
+ description +++
+ synopsis +++
+ divInterface (maybe_doc_hdr +++ bdy)
+ where
+ exports = numberSectionHeadings (ifaceRnExportItems iface)
+
+ -- todo: if something has only sub-docs, or fn-args-docs, should
+ -- it be measured here and thus prevent omitting the synopsis?
+ has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
+ has_doc (ExportNoDecl _ _) = False
+ has_doc (ExportModule _) = False
+ has_doc _ = True
+
+ no_doc_at_all = not (any has_doc exports)
+
+ description | isNoHtml doc = doc
+ | otherwise = divDescription $ sectionName << "Description" +++ doc
+ where doc = docSection qual (ifaceRnDoc iface)
+
+ -- omit the synopsis if there are no documentation annotations at all
+ synopsis
+ | no_doc_at_all = noHtml
+ | otherwise
+ = divSynposis $
+ paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
+ shortDeclList (
+ mapMaybe (processExport True linksInfo unicode qual) exports
+ ) ! (collapseSection "syn" False "" ++ collapseToggle "syn")
+
+ -- if the documentation doesn't begin with a section header, then
+ -- add one ("Documentation").
+ maybe_doc_hdr
+ = case exports of
+ [] -> noHtml
+ ExportGroup {} : _ -> noHtml
+ _ -> h1 << "Documentation"
+
+ bdy =
+ foldr (+++) noHtml $
+ mapMaybe (processExport False linksInfo unicode qual) exports
+
+ linksInfo = (maybe_source_url, maybe_wiki_url)
+
+
+miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
+miniSynopsis mdl iface unicode qual =
+ divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
+ where
+ exports = numberSectionHeadings (ifaceRnExportItems iface)
+
+
+processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
+ -> [Html]
+processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =
+ ((divTopDecl <<).(declElem <<)) <$> case decl0 of
+ TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
+ (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
+ (DataDecl{}) -> [keyword "data" <+> b]
+ (SynDecl{}) -> [keyword "type" <+> b]
+ (ClassDecl {}) -> [keyword "class" <+> b]
+ _ -> []
+ SigD (TypeSig lnames (L _ _)) ->
+ map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
+ _ -> []
+processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
+ [groupTag lvl << docToHtml qual txt]
+processForMiniSynopsis _ _ _ _ = []
+
+
+ppNameMini :: Notation -> Module -> OccName -> Html
+ppNameMini notation mdl nm =
+ anchor ! [ href (moduleNameUrl mdl nm)
+ , target mainFrameName ]
+ << ppBinder' notation nm
+
+
+ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
+ppTyClBinderWithVarsMini mdl decl =
+ let n = tcdName decl
+ ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
+ in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
+
+
+ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
+ppModuleContents qual exports
+ | null sections = noHtml
+ | otherwise = contentsDiv
+ where
+ contentsDiv = divTableOfContents << (
+ sectionName << "Contents" +++
+ unordList sections)
+
+ (sections, _leftovers{-should be []-}) = process 0 exports
+
+ process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
+ process _ [] = ([], [])
+ process n items@(ExportGroup lev id0 doc : rest)
+ | lev <= n = ( [], items )
+ | otherwise = ( html:secs, rest2 )
+ where
+ html = linkedAnchor (groupId id0)
+ << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs
+ (ssecs, rest1) = process lev rest
+ (secs, rest2) = process n rest1
+ process n (_ : rest) = process n rest
+
+ mk_subsections [] = noHtml
+ mk_subsections ss = unordList ss
+
+-- we need to assign a unique id to each section heading so we can hyperlink
+-- them from the contents:
+numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
+numberSectionHeadings = go 1
+ where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
+ go _ [] = []
+ go n (ExportGroup lev _ doc : es)
+ = ExportGroup lev (show n) doc : go (n+1) es
+ go n (other:es)
+ = other : go n es
+
+
+processExport :: Bool -> LinksInfo -> Bool -> Qualification
+ -> ExportItem DocName -> Maybe Html
+processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
+processExport summary _ _ qual (ExportGroup lev id0 doc)
+ = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
+processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
+ = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
+processExport summary _ _ qual (ExportNoDecl y [])
+ = processDeclOneLiner summary $ ppDocName qual Prefix True y
+processExport summary _ _ qual (ExportNoDecl y subs)
+ = processDeclOneLiner summary $
+ ppDocName qual Prefix True y
+ +++ parenList (map (ppDocName qual Prefix True) subs)
+processExport summary _ _ qual (ExportDoc doc)
+ = nothingIf summary $ docSection_ qual doc
+processExport summary _ _ _ (ExportModule mdl)
+ = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
+
+
+nothingIf :: Bool -> a -> Maybe a
+nothingIf True _ = Nothing
+nothingIf False a = Just a
+
+
+processDecl :: Bool -> Html -> Maybe Html
+processDecl True = Just
+processDecl False = Just . divTopDecl
+
+
+processDeclOneLiner :: Bool -> Html -> Maybe Html
+processDeclOneLiner True = Just
+processDeclOneLiner False = Just . divTopDecl . declElem
+
+groupHeading :: Int -> String -> Html -> Html
+groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]
+
+groupTag :: Int -> Html -> Html
+groupTag lev
+ | lev == 1 = h1
+ | lev == 2 = h2
+ | lev == 3 = h3
+ | otherwise = h4
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
new file mode 100644
index 00000000..8884f69f
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -0,0 +1,885 @@
+{-# LANGUAGE TransformListComp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Decl
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Decl (
+ ppDecl,
+
+ ppTyName, ppTyFamHeader, ppTypeApp,
+ tyvarNames
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Layout
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Doc (combineDocumentation)
+
+import Data.List ( intersperse, sort )
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Monoid ( mempty )
+import Text.XHtml hiding ( name, title, p, quote )
+
+import GHC
+import GHC.Exts
+import Name
+import BooleanFormula
+
+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
+ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
+ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
+ SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
+ SigD (PatSynSig lname args ty prov req) ->
+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
+ ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
+ InstD _ -> noHtml
+ _ -> error "declaration not supported by ppDecl"
+
+
+ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
+ ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
+ splice unicode qual
+
+ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
+ ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
+ splice unicode qual
+ where
+ pp_typ = ppType unicode qual typ
+
+ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ Located DocName ->
+ HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
+ LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
+ ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
+ (unLoc prov) (unLoc req) fixities splice unicode qual
+
+ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
+ DocName ->
+ HsPatSynDetails (HsType DocName) -> HsType DocName ->
+ HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
+ Splice -> Unicode -> Qualification -> Html
+ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
+ splice unicode qual
+ | summary = pref1
+ | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
+ +++ docSection qual doc
+ where
+ pref1 = hsep [ toHtml "pattern"
+ , pp_cxt prov
+ , pp_head
+ , dcolon unicode
+ , pp_cxt req
+ , ppType unicode qual typ
+ ]
+ pp_head = case args of
+ PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs
+ InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]
+
+ pp_cxt cxt = ppContext cxt unicode qual
+ pp_type = ppParendType unicode qual
+
+ occname = nameOccName . getName $ docname
+
+ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
+ [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
+ Splice -> Unicode -> Qualification -> Html
+ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
+ splice unicode qual =
+ ppTypeOrFunSig summary links loc docnames typ doc
+ ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
+ , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
+ , dcolon unicode
+ )
+ splice unicode qual
+ where
+ occnames = map (nameOccName . getName) docnames
+ addFixities html
+ | summary = html
+ | otherwise = html <+> ppFixities fixities qual
+
+
+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
+ -> DocForDecl DocName -> (Html, Html, Html)
+ -> Splice -> Unicode -> Qualification -> Html
+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
+ | summary = pref1
+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc
+ | otherwise = topDeclElem links loc splice docnames pref2 +++
+ subArguments qual (do_args 0 sep typ) +++ docSection qual doc
+ where
+ argDoc n = Map.lookup n argDocs
+
+ do_largs n leader (L _ t) = do_args n leader t
+ do_args :: Int -> Html -> HsType DocName -> [SubDecl]
+ do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+ = (leader <+>
+ hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
+ ppLContextNoArrow lctxt unicode qual,
+ Nothing, [])
+ : do_largs n (darrow unicode) ltype
+ do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+ | not (null (unLoc lctxt))
+ = (leader <+> ppLContextNoArrow lctxt unicode qual,
+ Nothing, [])
+ : do_largs n (darrow unicode) ltype
+ -- if we're not showing any 'forall' or class constraints or
+ -- anything, skip having an empty line for the context.
+ | otherwise
+ = do_largs n leader ltype
+ do_args n leader (HsFunTy lt r)
+ = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
+ : do_largs (n+1) (arrow unicode) r
+ do_args n leader t
+ = [(leader <+> ppType unicode qual t, argDoc n, [])]
+
+ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
+ppFixities [] _ = noHtml
+ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
+ where
+ ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<
+ (toHtml d <+> toHtml (show p) <+> ppNames ns)
+
+ ppDir InfixR = "infixr"
+ ppDir InfixL = "infixl"
+ ppDir InfixN = "infix"
+
+ ppNames = case fs of
+ _:[] -> const noHtml -- Don't display names for fixities on single names
+ _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)
+
+ uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs
+ , let d' = ppDir d
+ , then group by Down (p,d') using groupWith ]
+
+ rightEdge = thespan ! [theclass "rightedge"] << noHtml
+
+
+ppTyVars :: LHsTyVarBndrs DocName -> [Html]
+ppTyVars tvs = map ppTyName (tyvarNames tvs)
+
+
+tyvarNames :: LHsTyVarBndrs DocName -> [Name]
+tyvarNames = map getName . hsLTyVarNames
+
+
+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
+ -> ForeignDecl DocName -> [(DocName, Fixity)]
+ -> Splice -> Unicode -> Qualification -> Html
+ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
+ splice unicode qual
+ = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
+ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
+
+
+-- we skip type patterns for now
+ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
+ -> DocForDecl DocName -> TyClDecl DocName
+ -> Splice -> Unicode -> Qualification -> Html
+ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
+ , tcdRhs = ltype })
+ splice unicode qual
+ = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
+ (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
+ splice unicode qual
+ where
+ hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
+ full = hdr <+> equals <+> ppLType unicode qual ltype
+ occ = nameOccName . getName $ name
+ fixs
+ | summary = noHtml
+ | otherwise = ppFixities fixities qual
+ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
+
+
+ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
+ppTypeSig summary nms pp_ty unicode =
+ concatHtml htmlNames <+> dcolon unicode <+> pp_ty
+ where
+ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
+
+
+ppTyName :: Name -> Html
+ppTyName = ppName Prefix
+
+
+--------------------------------------------------------------------------------
+-- * Type families
+--------------------------------------------------------------------------------
+
+
+ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
+ -> Unicode -> Qualification -> Html
+ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
+ , fdKindSig = mkind })
+ unicode qual =
+ (case info of
+ OpenTypeFamily
+ | associated -> keyword "type"
+ | otherwise -> keyword "type family"
+ DataFamily
+ | associated -> keyword "data"
+ | otherwise -> keyword "data family"
+ ClosedTypeFamily _
+ -> keyword "type family"
+ ) <+>
+
+ ppFamDeclBinderWithVars summary d <+>
+
+ (case mkind of
+ Just kind -> dcolon unicode <+> ppLKind unicode qual kind
+ Nothing -> noHtml
+ )
+
+ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
+ [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
+ FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
+ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
+
+ | summary = ppTyFamHeader True associated decl unicode qual
+ | otherwise = header_ +++ docSection qual doc +++ instancesBit
+
+ where
+ docname = unLoc $ fdLName decl
+
+ header_ = topDeclElem links loc splice [docname] $
+ ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
+
+ instancesBit
+ | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
+ , not summary
+ = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
+
+ | otherwise
+ = ppInstances instances docname unicode qual
+
+ -- Individual equation of a closed type family
+ ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
+ , tfie_pats = HsWB { hswb_cts = ts }}
+ = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
+ <+> equals <+> ppType unicode qual (unLoc rhs)
+ , Nothing, [] )
+
+--------------------------------------------------------------------------------
+-- * Associated Types
+--------------------------------------------------------------------------------
+
+
+ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
+ -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
+ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
+ ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
+
+
+--------------------------------------------------------------------------------
+-- * TyClDecl helpers
+--------------------------------------------------------------------------------
+
+-- | Print a type family and its variables
+ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
+ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
+ ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
+
+-- | Print a newtype / data binder and its variables
+ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
+ppDataBinderWithVars summ decl =
+ ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
+
+--------------------------------------------------------------------------------
+-- * Type applications
+--------------------------------------------------------------------------------
+
+
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
+ -> Unicode -> Qualification -> Html
+ppAppNameTypes n ks ts unicode qual =
+ ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
+
+
+-- | Print an application of a DocName and a list of Names
+ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
+ppAppDocNameNames summ n ns =
+ ppTypeApp n [] ns ppDN ppTyName
+ where
+ ppDN notation = ppBinderFixity notation summ . nameOccName . getName
+ ppBinderFixity Infix = ppBinderInfix
+ ppBinderFixity _ = ppBinder
+
+-- | General printing of type applications
+ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n [] (t1:t2:rest) ppDN ppT
+ | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
+ | operator = opApp
+ where
+ operator = isNameSym . getName $ n
+ opApp = ppT t1 <+> ppDN Infix n <+> ppT t2
+
+ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
+
+
+-------------------------------------------------------------------------------
+-- * Contexts
+-------------------------------------------------------------------------------
+
+
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
+ -> Qualification -> Html
+ppLContext = ppContext . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
+ppContextNoArrow [] _ _ = noHtml
+ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
+
+
+ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
+ppContextNoLocs [] _ _ = noHtml
+ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
+ <+> darrow unicode
+
+
+ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
+ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
+
+
+ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html
+ppHsContext [] _ _ = noHtml
+ppHsContext [p] unicode qual = ppCtxType unicode qual p
+ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
+
+
+-------------------------------------------------------------------------------
+-- * Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
+ -> Unicode -> Qualification -> Html
+ppClassHdr summ lctxt n tvs fds unicode qual =
+ keyword "class"
+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
+ <+> ppAppDocNameNames summ n (tyvarNames tvs)
+ <+> ppFds fds unicode qual
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
+ppFds fds unicode qual =
+ if null fds then noHtml else
+ char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
+ where
+ fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ ppVars = hsep . map (ppDocName qual Prefix True)
+
+ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
+ -> [(DocName, DocForDecl DocName)]
+ -> Splice -> Unicode -> Qualification -> Html
+ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
+ , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
+ subdocs splice unicode qual =
+ if not (any isVanillaLSig sigs) && null ats
+ then (if summary then id else topDeclElem links loc splice [nm]) hdr
+ else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
+ +++ shortSubDecls False
+ (
+ [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
+ , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
+
+ -- ToDo: add associated type defaults
+
+ [ ppFunSig summary links loc doc names typ [] splice unicode qual
+ | L _ (TypeSig lnames (L _ typ)) <- sigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
+ )
+ where
+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
+ nm = unLoc lname
+ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+
+ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
+ -> SrcSpan -> Documentation DocName
+ -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
+ -> Splice -> Unicode -> Qualification -> Html
+ppClassDecl summary links instances fixities loc d subdocs
+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
+ splice unicode qual
+ | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
+ | otherwise = classheader +++ docSection qual d
+ +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
+ where
+ classheader
+ | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
+ | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
+
+ -- Only the fixity relevant to the class header
+ fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
+
+ nm = tcdName decl
+
+ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
+
+ -- ToDo: add assocatied typ defaults
+ atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
+ | at <- ats
+ , let n = unL . fdLName $ unL at
+ doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
+ subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
+
+ methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
+ | L _ (TypeSig lnames (L _ typ)) <- lsigs
+ , let doc = lookupAnySubdoc (head names) subdocs
+ subfixs = [ f | n <- names
+ , f@(n',_) <- fixities
+ , n == n' ]
+ names = map unLoc lnames ]
+ -- FIXME: is taking just the first name ok? Is it possible that
+ -- there are different subdocs for different names in a single
+ -- type signature?
+
+ minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
+ -- Miminal complete definition = every shown method
+ And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
+ sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
+ -> noHtml
+
+ -- Minimal complete definition = the only shown method
+ Var (L _ n) : _ | [getName n] ==
+ [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
+ -> noHtml
+
+ -- Minimal complete definition = nothing
+ And [] : _ -> subMinimal $ toHtml "Nothing"
+
+ m : _ -> subMinimal $ ppMinimal False m
+ _ -> noHtml
+
+ ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
+ ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs
+ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
+ where wrap | p = parens | otherwise = id
+
+ instancesBit = ppInstances instances nm unicode qual
+
+ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
+ppInstances instances baseName unicode qual
+ = subInstances qual instName (map instDecl instances)
+ where
+ instName = getOccString $ getName baseName
+ instDecl :: DocInstance DocName -> SubDecl
+ instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+ instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
+ <+> ppAppNameTypes n ks ts unicode qual
+ instHead (n, ks, ts, TypeInst rhs) = keyword "type"
+ <+> ppAppNameTypes n ks ts unicode qual
+ <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
+ instHead (n, ks, ts, DataInst dd) = keyword "data"
+ <+> ppAppNameTypes n ks ts unicode qual
+ <+> ppShortDataDecl False True dd unicode qual
+
+lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
+lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
+
+
+-------------------------------------------------------------------------------
+-- * Data & newtype declarations
+-------------------------------------------------------------------------------
+
+
+-- TODO: print contexts
+ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
+ppShortDataDecl summary dataInst dataDecl unicode qual
+
+ | [] <- cons = dataHeader
+
+ | [lcon] <- cons, ResTyH98 <- resTy,
+ (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
+ = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
+
+ | ResTyH98 <- resTy = dataHeader
+ +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
+
+ | otherwise = (dataHeader <+> keyword "where")
+ +++ shortSubDecls dataInst (map doGADTConstr cons)
+
+ where
+ dataHeader
+ | dataInst = noHtml
+ | otherwise = ppDataHeader summary dataDecl unicode qual
+ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
+ doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
+
+ cons = dd_cons (tcdDataDefn dataDecl)
+ resTy = (con_res . unLoc . head) cons
+
+
+ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
+ [(DocName, DocForDecl DocName)] ->
+ SrcSpan -> Documentation DocName -> TyClDecl DocName ->
+ Splice -> Unicode -> Qualification -> Html
+ppDataDecl summary links instances fixities subdocs loc doc dataDecl
+ splice unicode qual
+
+ | summary = ppShortDataDecl summary False dataDecl unicode qual
+ | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
+
+ where
+ docname = tcdName dataDecl
+ cons = dd_cons (tcdDataDefn dataDecl)
+ resTy = (con_res . unLoc . head) cons
+
+ header_ = topDeclElem links loc splice [docname] $
+ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
+
+ fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
+
+ whereBit
+ | null cons = noHtml
+ | otherwise = case resTy of
+ ResTyGADT _ -> keyword "where"
+ _ -> noHtml
+
+ constrBit = subConstructors qual
+ [ ppSideBySideConstr subdocs subfixs unicode qual c
+ | c <- cons
+ , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities
+ ]
+
+ instancesBit = ppInstances instances docname unicode qual
+
+
+
+ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html
+ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
+ where
+ (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual
+
+
+-- returns three pieces: header, body, footer so that header & footer can be
+-- incorporated into the declaration
+ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
+ppShortConstrParts summary dataInst con unicode qual = case con_res con of
+ ResTyH98 -> case con_details con of
+ PrefixCon args ->
+ (header_ unicode qual +++ hsep (ppBinder summary occ
+ : map (ppLParendType unicode qual) args), noHtml, noHtml)
+ RecCon fields ->
+ (header_ unicode qual +++ ppBinder summary occ <+> char '{',
+ doRecordFields fields,
+ char '}')
+ InfixCon arg1 arg2 ->
+ (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
+ ppBinderInfix summary occ, ppLParendType unicode qual arg2],
+ noHtml, noHtml)
+
+ ResTyGADT resTy -> case con_details con of
+ -- prefix & infix could use hsConDeclArgTys if it seemed to
+ -- simplify the code.
+ PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
+ -- display GADT records with the new syntax,
+ -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
+ -- (except each field gets its own line in docs, to match
+ -- non-GADT records)
+ RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
+ ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
+ doRecordFields fields,
+ char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
+ InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
+
+ where
+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)
+ doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
+ ppForAll forall_ ltvs lcontext unicode qual,
+ ppLType unicode qual (foldr mkFunTy resTy args) ]
+
+ header_ = ppConstrHdr forall_ tyVars context
+ occ = nameOccName . getName . unLoc . con_name $ con
+ ltvs = con_qvars con
+ tyVars = tyvarNames ltvs
+ lcontext = con_cxt con
+ context = unLoc (con_cxt con)
+ forall_ = con_explicit con
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
+ -> Qualification -> Html
+ppConstrHdr forall_ tvs ctxt unicode qual
+ = (if null tvs then noHtml else ppForall)
+ +++
+ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
+ <+> darrow unicode +++ toHtml " ")
+ where
+ ppForall = case forall_ of
+ Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "
+ Implicit -> noHtml
+
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
+ -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
+ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
+ where
+ decl = case con_res con of
+ ResTyH98 -> case con_details con of
+ PrefixCon args ->
+ hsep ((header_ +++ ppBinder False occ)
+ : map (ppLParendType unicode qual) args)
+ <+> fixity
+
+ RecCon _ -> header_ +++ ppBinder False occ <+> fixity
+
+ InfixCon arg1 arg2 ->
+ hsep [header_ +++ ppLParendType unicode qual arg1,
+ ppBinderInfix False occ,
+ ppLParendType unicode qual arg2]
+ <+> fixity
+
+ ResTyGADT resTy -> case con_details con of
+ -- prefix & infix could also use hsConDeclArgTys if it seemed to
+ -- simplify the code.
+ PrefixCon args -> doGADTCon args resTy
+ cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
+ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+ fieldPart = case con_details con of
+ RecCon fields -> [doRecordFields fields]
+ _ -> []
+
+ doRecordFields fields = subFields qual
+ (map (ppSideBySideField subdocs unicode qual) fields)
+ doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
+ doGADTCon args resTy = ppBinder False occ <+> dcolon unicode
+ <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
+ ppLType unicode qual (foldr mkFunTy resTy args) ]
+ <+> fixity
+
+ fixity = ppFixities fixities qual
+ header_ = ppConstrHdr forall_ tyVars context unicode qual
+ occ = nameOccName . getName . unLoc . con_name $ con
+ ltvs = con_qvars con
+ tyVars = tyvarNames (con_qvars con)
+ context = unLoc (con_cxt con)
+ forall_ = con_explicit con
+ -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+ -- or also because we want Haddock to do the doc-parsing, not GHC.
+ mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
+ mkFunTy a b = noLoc (HsFunTy a b)
+
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
+ -> ConDeclField DocName -> SubDecl
+ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
+ (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
+ mbDoc,
+ [])
+ where
+ -- don't use cd_fld_doc for same reason we don't use con_doc above
+ mbDoc = lookup name subdocs >>= combineDocumentation . fst
+
+
+ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
+ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
+ = ppBinder summary (nameOccName . getName $ name)
+ <+> dcolon unicode <+> ppLType unicode qual ltype
+
+
+-- | Print the LHS of a data\/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
+ppDataHeader summary decl@(DataDecl { tcdDataDefn =
+ HsDataDefn { dd_ND = nd
+ , dd_ctxt = ctxt
+ , dd_kindSig = ks } })
+ unicode qual
+ = -- newtype or data
+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
+ <+>
+ -- context
+ ppLContext ctxt unicode qual <+>
+ -- T a b c ..., or a :+: b
+ ppDataBinderWithVars summary decl
+ <+> case ks of
+ Nothing -> mempty
+ Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
+
+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
+
+--------------------------------------------------------------------------------
+-- * Types and contexts
+--------------------------------------------------------------------------------
+
+
+ppBang :: HsBang -> Html
+ppBang HsNoBang = noHtml
+ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
+ -- so we just show the strictness annotation
+
+
+tupleParens :: HsTupleSort -> [Html] -> Html
+tupleParens HsUnboxedTuple = ubxParenList
+tupleParens _ = parenList
+
+
+--------------------------------------------------------------------------------
+-- * Rendering of HsType
+--------------------------------------------------------------------------------
+
+
+pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int
+
+pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC
+pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type
+ -- (as opposed to (ctx1, ctx2) => type)
+pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC
+ -- Used for LH arg of (->)
+pREC_OP = 3 :: Int -- Used for arg of any infix operator
+ -- (we don't keep their fixities around)
+pREC_CON = 4 :: Int -- Used for arg of type applicn:
+ -- always parenthesise unless atomic
+
+maybeParen :: Int -- Precedence of context
+ -> Int -- Precedence of top-level operator
+ -> Html -> Html -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+ | otherwise = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
+ -> Located (HsType DocName) -> Html
+ppLType unicode qual y = ppType unicode qual (unLoc y)
+ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
+ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
+
+
+ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
+ -> HsType DocName -> Html
+ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
+ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
+ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
+ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
+
+ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
+ppLKind unicode qual y = ppKind unicode qual (unLoc y)
+
+ppKind :: Unicode -> Qualification -> HsKind DocName -> Html
+ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
+
+-- Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+
+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
+ -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
+ppForAll expl tvs cxt unicode qual
+ | show_forall = forall_part <+> ppLContext cxt unicode qual
+ | otherwise = ppLContext cxt unicode qual
+ where
+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
+ is_explicit = case expl of {Explicit -> True; Implicit -> False}
+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
+
+
+ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
+ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
+
+
+ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
+ = maybeParen ctxt_prec pREC_FUN $
+ hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
+
+-- UnicodeSyntax alternatives
+ppr_mono_ty _ (HsTyVar name) True _
+ | getOccString (getName name) == "*" = toHtml "★"
+ | getOccString (getName name) == "(->)" = toHtml "(→)"
+
+ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
+ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
+ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
+ppr_mono_ty _ (HsKindSig ty kind) u q =
+ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
+ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =
+ maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
+ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
+ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
+ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
+ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy"
+
+ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
+ = maybeParen ctxt_prec pREC_CTX $
+ ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
+
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
+ = maybeParen ctxt_prec pREC_CON $
+ hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
+
+ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
+ = maybeParen ctxt_prec pREC_FUN $
+ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
+ where
+ ppr_op = ppLDocName qual Infix op
+
+ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
+-- = parens (ppr_mono_lty pREC_TOP ty)
+ = ppr_mono_lty ctxt_prec ty unicode qual
+
+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
+ = ppr_mono_lty ctxt_prec ty unicode qual
+
+ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
+
+ppr_tylit :: HsTyLit -> Html
+ppr_tylit (HsNumTy n) = toHtml (show n)
+ppr_tylit (HsStrTy s) = toHtml (show s)
+
+
+ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
+ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
+ = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
+ p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
+ in
+ maybeParen ctxt_prec pREC_FUN $
+ hsep [p1, arrow unicode <+> p2]
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
new file mode 100644
index 00000000..5e27d9b0
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -0,0 +1,143 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.DocMarkup
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.DocMarkup (
+ docToHtml,
+ rdrDocToHtml,
+ origDocToHtml,
+ docToHtmlNoAnchors,
+
+ docElement, docSection, docSection_,
+) where
+
+import Control.Applicative ((<$>))
+
+import Haddock.Backends.Xhtml.Names
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils
+import Haddock.Doc (combineDocumentation)
+
+import Text.XHtml hiding ( name, p, quote )
+import Data.Maybe (fromMaybe)
+
+import GHC
+
+parHtmlMarkup :: Qualification -> Bool
+ -> (Bool -> a -> Html) -> DocMarkup a Html
+parHtmlMarkup qual insertAnchors ppId = Markup {
+ markupEmpty = noHtml,
+ markupString = toHtml,
+ markupParagraph = paragraph,
+ markupAppend = (+++),
+ markupIdentifier = thecode . ppId insertAnchors,
+ markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
+ markupModule = \m -> let (mdl,ref) = break (=='#') m
+ -- Accomodate for old style
+ -- foo\#bar anchors
+ mdl' = case reverse mdl of
+ '\\':_ -> init mdl
+ _ -> mdl
+ in ppModuleRef (mkModuleName mdl') ref,
+ markupWarning = thediv ! [theclass "warning"],
+ markupEmphasis = emphasize,
+ markupBold = strong,
+ markupMonospaced = thecode,
+ markupUnorderedList = unordList,
+ markupOrderedList = ordList,
+ markupDefList = defList,
+ markupCodeBlock = pre,
+ markupHyperlink = \(Hyperlink url mLabel)
+ -> if insertAnchors
+ then anchor ! [href url]
+ << fromMaybe url mLabel
+ else toHtml $ fromMaybe url mLabel,
+ markupAName = \aname -> namedAnchor aname << "",
+ markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
+ markupProperty = pre . toHtml,
+ markupExample = examplesToHtml,
+ markupHeader = \(Header l t) -> makeHeader l t
+ }
+ where
+ makeHeader :: Int -> Html -> Html
+ makeHeader 1 mkup = h1 mkup
+ makeHeader 2 mkup = h2 mkup
+ makeHeader 3 mkup = h3 mkup
+ makeHeader 4 mkup = h4 mkup
+ makeHeader 5 mkup = h5 mkup
+ makeHeader 6 mkup = h6 mkup
+ makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
+
+
+ examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
+
+ exampleToHtml (Example expression result) = htmlExample
+ where
+ htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
+ htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
+ htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
+
+
+-- If the doc is a single paragraph, don't surround it with <P> (this causes
+-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
+docToHtml :: Qualification -> Doc DocName -> Html
+docToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
+
+-- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
+-- in links. This is used to generate the Contents box elements.
+docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html
+docToHtmlNoAnchors qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
+
+origDocToHtml :: Qualification -> Doc Name -> Html
+origDocToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual True (const $ ppName Raw)
+
+
+rdrDocToHtml :: Qualification -> Doc RdrName -> Html
+rdrDocToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual True (const ppRdrName)
+
+
+docElement :: (Html -> Html) -> Html -> Html
+docElement el content_ =
+ if isNoHtml content_
+ then el ! [theclass "doc empty"] << spaceHtml
+ else el ! [theclass "doc"] << content_
+
+
+docSection :: Qualification -> Documentation DocName -> Html
+docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
+
+
+docSection_ :: Qualification -> Doc DocName -> Html
+docSection_ qual = (docElement thediv <<) . docToHtml qual
+
+
+cleanup :: Doc a -> Doc a
+cleanup = markup fmtUnParagraphLists
+ where
+ -- If there is a single paragraph, then surrounding it with <P>..</P>
+ -- can add too much whitespace in some browsers (eg. IE). However if
+ -- we have multiple paragraphs, then we want the extra whitespace to
+ -- separate them. So we catch the single paragraph case and transform it
+ -- here. We don't do this in code blocks as it eliminates line breaks.
+ unParagraph :: Doc a -> Doc a
+ unParagraph (DocParagraph d) = d
+ unParagraph doc = doc
+
+ fmtUnParagraphLists :: DocMarkup a (Doc a)
+ fmtUnParagraphLists = idMarkup {
+ markupUnorderedList = DocUnorderedList . map unParagraph,
+ markupOrderedList = DocOrderedList . map unParagraph
+ }
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
new file mode 100644
index 00000000..e84a57b3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -0,0 +1,235 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Layout
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Layout (
+ miniBody,
+
+ divPackageHeader, divContent, divModuleHeader, divFooter,
+ divTableOfContents, divDescription, divSynposis, divInterface,
+ divIndex, divAlphabet, divModuleList,
+
+ sectionName,
+ nonEmptySectionName,
+
+ shortDeclList,
+ shortSubDecls,
+
+ divTopDecl,
+
+ SubDecl,
+ subArguments,
+ subAssociatedTypes,
+ subConstructors,
+ subEquations,
+ subFields,
+ subInstances,
+ subMethods,
+ subMinimal,
+
+ topDeclElem, declElem,
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils (makeAnchorId)
+
+import qualified Data.Map as Map
+import Text.XHtml hiding ( name, title, p, quote )
+
+import FastString ( unpackFS )
+import GHC
+
+
+--------------------------------------------------------------------------------
+-- * Sections of the document
+--------------------------------------------------------------------------------
+
+
+miniBody :: Html -> Html
+miniBody = body ! [identifier "mini"]
+
+
+sectionDiv :: String -> Html -> Html
+sectionDiv i = thediv ! [identifier i]
+
+
+sectionName :: Html -> Html
+sectionName = paragraph ! [theclass "caption"]
+
+
+-- | Make an element that always has at least something (a non-breaking space).
+-- If it would have otherwise been empty, then give it the class ".empty".
+nonEmptySectionName :: Html -> Html
+nonEmptySectionName c
+ | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
+ | otherwise = paragraph ! [theclass "caption"] $ c
+
+
+divPackageHeader, divContent, divModuleHeader, divFooter,
+ divTableOfContents, divDescription, divSynposis, divInterface,
+ divIndex, divAlphabet, divModuleList
+ :: Html -> Html
+
+divPackageHeader = sectionDiv "package-header"
+divContent = sectionDiv "content"
+divModuleHeader = sectionDiv "module-header"
+divFooter = sectionDiv "footer"
+divTableOfContents = sectionDiv "table-of-contents"
+divDescription = sectionDiv "description"
+divSynposis = sectionDiv "synopsis"
+divInterface = sectionDiv "interface"
+divIndex = sectionDiv "index"
+divAlphabet = sectionDiv "alphabet"
+divModuleList = sectionDiv "module-list"
+
+
+--------------------------------------------------------------------------------
+-- * Declaration containers
+--------------------------------------------------------------------------------
+
+
+shortDeclList :: [Html] -> Html
+shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
+
+
+shortSubDecls :: Bool -> [Html] -> Html
+shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items
+ where i | inst = li ! [theclass "inst"]
+ | otherwise = li
+ c | inst = "inst"
+ | otherwise = "subs"
+
+
+divTopDecl :: Html -> Html
+divTopDecl = thediv ! [theclass "top"]
+
+
+type SubDecl = (Html, Maybe (Doc DocName), [Html])
+
+
+divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html
+divSubDecls cssClass captionName = maybe noHtml wrap
+ where
+ wrap = (subSection <<) . (subCaption +++)
+ subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
+ subCaption = paragraph ! [theclass "caption"] << captionName
+
+
+subDlist :: Qualification -> [SubDecl] -> Maybe Html
+subDlist _ [] = Nothing
+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
+ where
+ subEntry (decl, mdoc, subs) =
+ dterm ! [theclass "src"] << decl
+ +++
+ docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
+
+ clearDiv = thediv ! [ theclass "clear" ] << noHtml
+
+
+subTable :: Qualification -> [SubDecl] -> Maybe Html
+subTable _ [] = Nothing
+subTable qual decls = Just $ table << aboves (concatMap subRow decls)
+ where
+ subRow (decl, mdoc, subs) =
+ (td ! [theclass "src"] << decl
+ <->
+ docElement td << fmap (docToHtml qual) mdoc)
+ : map (cell . (td <<)) subs
+
+
+subBlock :: [Html] -> Maybe Html
+subBlock [] = Nothing
+subBlock hs = Just $ toHtml hs
+
+
+subArguments :: Qualification -> [SubDecl] -> Html
+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
+
+
+subAssociatedTypes :: [Html] -> Html
+subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
+
+
+subConstructors :: Qualification -> [SubDecl] -> Html
+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+
+
+subFields :: Qualification -> [SubDecl] -> Html
+subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+
+
+subEquations :: Qualification -> [SubDecl] -> Html
+subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+
+
+subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances qual nm = maybe noHtml wrap . instTable
+ where
+ wrap = (subSection <<) . (subCaption +++)
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+ subSection = thediv ! [theclass "subs instances"]
+ subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
+ id_ = makeAnchorId $ "i:" ++ nm
+
+subMethods :: [Html] -> Html
+subMethods = divSubDecls "methods" "Methods" . subBlock
+
+subMinimal :: Html -> Html
+subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
+
+
+-- a box for displaying code
+declElem :: Html -> Html
+declElem = paragraph ! [theclass "src"]
+
+
+-- a box for top level documented names
+-- it adds a source and wiki link at the right hand side of the box
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
+ declElem << (html <+> srcLink <+> wikiLink)
+ where srcLink = let nameUrl = Map.lookup origPkg sourceMap
+ lineUrl = Map.lookup origPkg lineMap
+ mUrl | splice = lineUrl
+ -- Use the lineUrl as a backup
+ | otherwise = maybe lineUrl Just nameUrl in
+ case mUrl of
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just origMod)
+ (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << "Source"
+
+ wikiLink =
+ case maybe_wiki_url of
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just mdl)
+ (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << "Comments"
+
+ -- For source links, we want to point to the original module,
+ -- because only that will have the source.
+ -- TODO: do something about type instances. They will point to
+ -- the module defining the type family, which is wrong.
+ origMod = nameModule n
+ origPkg = modulePackageId origMod
+
+ -- Name must be documented, otherwise we wouldn't get here
+ Documented n mdl = head names
+ -- FIXME: is it ok to simply take the first name?
+
+ fname = case loc of
+ RealSrcSpan l -> unpackFS (srcSpanFile l)
+ UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
new file mode 100644
index 00000000..cf12da40
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -0,0 +1,171 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Names
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Names (
+ ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
+ ppBinder, ppBinderInfix, ppBinder',
+ ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
+) where
+
+
+import Haddock.Backends.Xhtml.Utils
+import Haddock.GhcUtils
+import Haddock.Types
+import Haddock.Utils
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Data.Map as M
+import qualified Data.List as List
+
+import GHC
+import Name
+import RdrName
+import FastString (unpackFS)
+
+
+-- | Indicator of how to render a 'DocName' into 'Html'
+data Notation = Raw -- ^ Render as-is.
+ | Infix -- ^ Render using infix notation.
+ | Prefix -- ^ Render using prefix notation.
+ deriving (Eq, Show)
+
+ppOccName :: OccName -> Html
+ppOccName = toHtml . occNameString
+
+
+ppRdrName :: RdrName -> Html
+ppRdrName = ppOccName . rdrNameOcc
+
+ppIPName :: HsIPName -> Html
+ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
+
+
+ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
+
+
+-- The Bool indicates if it is to be rendered in infix notation
+ppLDocName :: Qualification -> Notation -> Located DocName -> Html
+ppLDocName qual notation (L _ d) = ppDocName qual notation True d
+
+ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
+ppDocName qual notation insertAnchors docName =
+ case docName of
+ Documented name mdl ->
+ linkIdOcc mdl (Just (nameOccName name)) insertAnchors
+ << ppQualifyName qual notation name mdl
+ Undocumented name
+ | isExternalName name || isWiredInName name ->
+ ppQualifyName qual notation name (nameModule name)
+ | otherwise -> ppName notation name
+
+-- | Render a name depending on the selected qualification mode
+ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
+ppQualifyName qual notation name mdl =
+ case qual of
+ NoQual -> ppName notation name
+ FullQual -> ppFullQualName notation mdl name
+ LocalQual localmdl ->
+ if moduleString mdl == moduleString localmdl
+ then ppName notation name
+ else ppFullQualName notation mdl name
+ RelativeQual localmdl ->
+ case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
+ -- local, A.x -> x
+ Just [] -> ppName notation name
+ -- sub-module, A.B.x -> B.x
+ Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
+ -- some module with same prefix, ABC.x -> ABC.x
+ Just _ -> ppFullQualName notation mdl name
+ -- some other module, D.x -> D.x
+ Nothing -> ppFullQualName notation mdl name
+ AliasedQual aliases localmdl ->
+ case (moduleString mdl == moduleString localmdl,
+ M.lookup mdl aliases) of
+ (False, Just alias) -> ppQualName notation alias name
+ _ -> ppName notation name
+
+
+ppFullQualName :: Notation -> Module -> Name -> Html
+ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname
+ where
+ qname = toHtml $ moduleString mdl ++ '.' : getOccString name
+
+ppQualName :: Notation -> ModuleName -> Name -> Html
+ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname
+ where
+ qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name
+
+ppName :: Notation -> Name -> Html
+ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)
+
+
+ppBinder :: Bool -> OccName -> Html
+-- The Bool indicates whether we are generating the summary, in which case
+-- the binder will be a link to the full definition.
+ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n
+ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+ << ppBinder' Prefix n
+
+ppBinderInfix :: Bool -> OccName -> Html
+ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n
+ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
+ << ppBinder' Infix n
+
+ppBinder' :: Notation -> OccName -> Html
+ppBinder' notation n = wrapInfix notation n $ ppOccName n
+
+wrapInfix :: Notation -> OccName -> Html -> Html
+wrapInfix notation n = case notation of
+ Infix | is_star_kind -> id
+ | not is_sym -> quote
+ Prefix | is_star_kind -> id
+ | is_sym -> parens
+ _ -> id
+ where
+ is_sym = isSymOcc n
+ is_star_kind = isTcOcc n && occNameString n == "*"
+
+linkId :: Module -> Maybe Name -> Html -> Html
+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True
+
+
+linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
+linkIdOcc mdl mbName insertAnchors =
+ if insertAnchors
+ then anchor ! [href url]
+ else id
+ where
+ url = case mbName of
+ Nothing -> moduleUrl mdl
+ Just name -> moduleNameUrl mdl name
+
+
+linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
+linkIdOcc' mdl mbName = anchor ! [href url]
+ where
+ url = case mbName of
+ Nothing -> moduleHtmlFile' mdl
+ Just name -> moduleNameUrl' mdl name
+
+
+ppModule :: Module -> Html
+ppModule mdl = anchor ! [href (moduleUrl mdl)]
+ << toHtml (moduleString mdl)
+
+
+ppModuleRef :: ModuleName -> String -> Html
+ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
+ << toHtml (moduleNameString mdl)
+ -- NB: The ref parameter already includes the '#'.
+ -- This function is only called from markupModule expanding a
+ -- DocModule, which doesn't seem to be ever be used.
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
new file mode 100644
index 00000000..79b093ec
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
@@ -0,0 +1,209 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Themes
+-- Copyright : (c) Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Themes (
+ Themes,
+ getThemes,
+
+ cssFiles, styleSheet
+ )
+ where
+
+import Haddock.Options
+
+import Control.Applicative
+import Control.Monad (liftM)
+import Data.Char (toLower)
+import Data.Either (lefts, rights)
+import Data.List (nub)
+import Data.Maybe (isJust, listToMaybe)
+
+import System.Directory
+import System.FilePath
+import Text.XHtml hiding ( name, title, p, quote, (</>) )
+import qualified Text.XHtml as XHtml
+
+
+--------------------------------------------------------------------------------
+-- * CSS Themes
+--------------------------------------------------------------------------------
+
+data Theme = Theme {
+ themeName :: String,
+ themeHref :: String,
+ themeFiles :: [FilePath]
+ }
+
+type Themes = [Theme]
+
+type PossibleTheme = Either String Theme
+type PossibleThemes = Either String Themes
+
+
+-- | Find a theme by name (case insensitive match)
+findTheme :: String -> Themes -> Maybe Theme
+findTheme s = listToMaybe . filter ((== ls).lower.themeName)
+ where lower = map toLower
+ ls = lower s
+
+
+-- | Standard theme used by default
+standardTheme :: FilePath -> IO PossibleThemes
+standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)
+
+
+-- | Default themes that are part of Haddock; added with --default-themes
+-- The first theme in this list is considered the standard theme.
+-- Themes are "discovered" by scanning the html sub-dir of the libDir,
+-- and looking for directories with the extension .theme or .std-theme.
+-- The later is, obviously, the standard theme.
+defaultThemes :: FilePath -> IO PossibleThemes
+defaultThemes libDir = do
+ themeDirs <- getDirectoryItems (libDir </> "html")
+ themes <- mapM directoryTheme $ discoverThemes themeDirs
+ return $ sequenceEither themes
+ where
+ discoverThemes paths =
+ filterExt ".std-theme" paths ++ filterExt ".theme" paths
+ filterExt ext = filter ((== ext).takeExtension)
+
+
+-- | Build a theme from a single .css file
+singleFileTheme :: FilePath -> IO PossibleTheme
+singleFileTheme path =
+ if isCssFilePath path
+ then retRight $ Theme name file [path]
+ else errMessage "File extension isn't .css" path
+ where
+ name = takeBaseName path
+ file = takeFileName path
+
+
+-- | Build a theme from a directory
+directoryTheme :: FilePath -> IO PossibleTheme
+directoryTheme path = do
+ items <- getDirectoryItems path
+ case filter isCssFilePath items of
+ [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items
+ [] -> errMessage "No .css file in theme directory" path
+ _ -> errMessage "More than one .css file in theme directory" path
+
+
+-- | Check if we have a built in theme
+doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
+doesBuiltInExist pts s = fmap (either (const False) test) pts
+ where test = isJust . findTheme s
+
+
+-- | Find a built in theme
+builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
+builtInTheme pts s = either Left fetch <$> pts
+ where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s
+
+
+--------------------------------------------------------------------------------
+-- * CSS Theme Arguments
+--------------------------------------------------------------------------------
+
+-- | Process input flags for CSS Theme arguments
+getThemes :: FilePath -> [Flag] -> IO PossibleThemes
+getThemes libDir flags =
+ liftM concatEither (mapM themeFlag flags) >>= someTheme
+ where
+ themeFlag :: Flag -> IO (Either String Themes)
+ themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)
+ themeFlag (Flag_BuiltInThemes) = builtIns
+ themeFlag _ = retRight []
+
+ theme :: FilePath -> IO PossibleTheme
+ theme path = pick path
+ [(doesFileExist, singleFileTheme),
+ (doesDirectoryExist, directoryTheme),
+ (doesBuiltInExist builtIns, builtInTheme builtIns)]
+ "Theme not found"
+
+ pick :: FilePath
+ -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String
+ -> IO PossibleTheme
+ pick path [] msg = errMessage msg path
+ pick path ((test,build):opts) msg = do
+ pass <- test path
+ if pass then build path else pick path opts msg
+
+
+ someTheme :: Either String Themes -> IO (Either String Themes)
+ someTheme (Right []) = standardTheme libDir
+ someTheme est = return est
+
+ builtIns = defaultThemes libDir
+
+
+errMessage :: String -> FilePath -> IO (Either String a)
+errMessage msg path = return (Left msg')
+ where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"
+
+
+retRight :: a -> IO (Either String a)
+retRight = return . Right
+
+
+--------------------------------------------------------------------------------
+-- * File Utilities
+--------------------------------------------------------------------------------
+
+
+getDirectoryItems :: FilePath -> IO [FilePath]
+getDirectoryItems path =
+ map (combine path) . filter notDot <$> getDirectoryContents path
+ where notDot s = s /= "." && s /= ".."
+
+
+isCssFilePath :: FilePath -> Bool
+isCssFilePath path = takeExtension path == ".css"
+
+
+--------------------------------------------------------------------------------
+-- * Style Sheet Utilities
+--------------------------------------------------------------------------------
+
+cssFiles :: Themes -> [String]
+cssFiles ts = nub $ concatMap themeFiles ts
+
+
+styleSheet :: Themes -> Html
+styleSheet ts = toHtml $ zipWith mkLink rels ts
+ where
+ rels = "stylesheet" : repeat "alternate stylesheet"
+ mkLink aRel t =
+ thelink
+ ! [ href (themeHref t), rel aRel, thetype "text/css",
+ XHtml.title (themeName t)
+ ]
+ << noHtml
+
+--------------------------------------------------------------------------------
+-- * Either Utilities
+--------------------------------------------------------------------------------
+
+-- These three routines are here because Haddock does not have access to the
+-- Control.Monad.Error module which supplies the Functor and Monad instances
+-- for Either String.
+
+sequenceEither :: [Either a b] -> Either a [b]
+sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es))
+
+
+liftEither :: (b -> c) -> Either a b -> Either a c
+liftEither f = either Left (Right . f)
+
+
+concatEither :: [Either a [b]] -> Either a [b]
+concatEither = liftEither concat . sequenceEither
+
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
new file mode 100644
index 00000000..122861c3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
@@ -0,0 +1,37 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Types
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Types (
+ SourceURLs, WikiURLs,
+ LinksInfo,
+ Splice,
+ Unicode,
+) where
+
+
+import Data.Map
+import GHC
+
+
+-- the base, module and entity URLs for the source code and wiki links.
+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)
+type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
+
+
+-- The URL for source and wiki links
+type LinksInfo = (SourceURLs, WikiURLs)
+
+-- Whether something is a splice or not
+type Splice = Bool
+
+-- Whether unicode syntax is to be used
+type Unicode = Bool
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
new file mode 100644
index 00000000..cbcbbd6d
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -0,0 +1,218 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Util
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Utils (
+ renderToString,
+
+ namedAnchor, linkedAnchor,
+ spliceURL,
+ groupId,
+
+ (<+>), (<=>), char,
+ keyword, punctuate,
+
+ braces, brackets, pabrackets, parens, parenList, ubxParenList,
+ arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
+
+ hsep, vcat,
+
+ collapseSection, collapseToggle, collapseControl,
+) where
+
+
+import Haddock.GhcUtils
+import Haddock.Utils
+
+import Data.Maybe
+
+import Text.XHtml hiding ( name, title, p, quote )
+import qualified Text.XHtml as XHtml
+
+import GHC ( SrcSpan(..), srcSpanStartLine, Name )
+import Module ( Module )
+import Name ( getOccString, nameOccName, isValOcc )
+
+
+spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
+ Maybe SrcSpan -> String -> String
+spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
+ where
+ file = fromMaybe "" maybe_file
+ mdl = case maybe_mod of
+ Nothing -> ""
+ Just m -> moduleString m
+
+ (name, kind) =
+ case maybe_name of
+ Nothing -> ("","")
+ Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
+ | otherwise -> (escapeStr (getOccString n), "t")
+
+ line = case maybe_loc of
+ Nothing -> ""
+ Just span_ ->
+ case span_ of
+ RealSrcSpan span__ ->
+ show $ srcSpanStartLine span__
+ UnhelpfulSpan _ ->
+ error "spliceURL UnhelpfulSpan"
+
+ run "" = ""
+ run ('%':'M':rest) = mdl ++ run rest
+ run ('%':'F':rest) = file ++ run rest
+ run ('%':'N':rest) = name ++ run rest
+ run ('%':'K':rest) = kind ++ run rest
+ run ('%':'L':rest) = line ++ run rest
+ run ('%':'%':rest) = '%' : run rest
+
+ run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
+ run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
+ run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest
+ run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest
+
+ run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
+ map (\x -> if x == '.' then c else x) mdl ++ run rest
+
+ run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =
+ map (\x -> if x == '/' then c else x) file ++ run rest
+
+ run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest
+
+ run (c:rest) = c : run rest
+
+
+renderToString :: Bool -> Html -> String
+renderToString debug html
+ | debug = renderHtml html
+ | otherwise = showHtml html
+
+
+hsep :: [Html] -> Html
+hsep [] = noHtml
+hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
+
+-- | Concatenate a series of 'Html' values vertically, with linebreaks in between.
+vcat :: [Html] -> Html
+vcat [] = noHtml
+vcat htmls = foldr1 (\a b -> a+++br+++b) htmls
+
+
+infixr 8 <+>
+(<+>) :: Html -> Html -> Html
+a <+> b = a +++ sep +++ b
+ where
+ sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " "
+
+-- | Join two 'Html' values together with a linebreak in between.
+-- Has 'noHtml' as left identity.
+infixr 8 <=>
+(<=>) :: Html -> Html -> Html
+a <=> b = a +++ sep +++ b
+ where
+ sep = if isNoHtml a then noHtml else br
+
+
+keyword :: String -> Html
+keyword s = thespan ! [theclass "keyword"] << toHtml s
+
+
+equals, comma :: Html
+equals = char '='
+comma = char ','
+
+
+char :: Char -> Html
+char c = toHtml [c]
+
+
+quote :: Html -> Html
+quote h = char '`' +++ h +++ '`'
+
+
+parens, brackets, pabrackets, braces :: Html -> Html
+parens h = char '(' +++ h +++ char ')'
+brackets h = char '[' +++ h +++ char ']'
+pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"
+braces h = char '{' +++ h +++ char '}'
+
+
+punctuate :: Html -> [Html] -> [Html]
+punctuate _ [] = []
+punctuate h (d0:ds) = go d0 ds
+ where
+ go d [] = [d]
+ go d (e:es) = (d +++ h) : go e es
+
+
+parenList :: [Html] -> Html
+parenList = parens . hsep . punctuate comma
+
+
+ubxParenList :: [Html] -> Html
+ubxParenList = ubxparens . hsep . punctuate comma
+
+
+ubxparens :: Html -> Html
+ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
+
+
+dcolon, arrow, darrow, forallSymbol :: Bool -> Html
+dcolon unicode = toHtml (if unicode then "∷" else "::")
+arrow unicode = toHtml (if unicode then "→" else "->")
+darrow unicode = toHtml (if unicode then "⇒" else "=>")
+forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
+
+
+dot :: Html
+dot = toHtml "."
+
+
+-- | Generate a named anchor
+namedAnchor :: String -> Html -> Html
+namedAnchor n = anchor ! [XHtml.name n]
+
+
+linkedAnchor :: String -> Html -> Html
+linkedAnchor n = anchor ! [href ('#':n)]
+
+
+-- | generate an anchor identifier for a group
+groupId :: String -> String
+groupId g = makeAnchorId ("g:" ++ g)
+
+--
+-- A section of HTML which is collapsible.
+--
+
+-- | Attributes for an area that can be collapsed
+collapseSection :: String -> Bool -> String -> [HtmlAttr]
+collapseSection id_ state classes = [ identifier sid, theclass cs ]
+ where cs = unwords (words classes ++ [pick state "show" "hide"])
+ sid = "section." ++ id_
+
+-- | Attributes for an area that toggles a collapsed area
+collapseToggle :: String -> [HtmlAttr]
+collapseToggle id_ = [ strAttr "onclick" js ]
+ where js = "toggleSection('" ++ id_ ++ "')";
+
+-- | Attributes for an area that toggles a collapsed area,
+-- and displays a control.
+collapseControl :: String -> Bool -> String -> [HtmlAttr]
+collapseControl id_ state classes =
+ [ identifier cid, theclass cs ] ++ collapseToggle id_
+ where cs = unwords (words classes ++ [pick state "collapser" "expander"])
+ cid = "control." ++ id_
+
+
+pick :: Bool -> a -> a -> a
+pick True t _ = t
+pick False _ f = f
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
new file mode 100644
index 00000000..73ff3f1a
--- /dev/null
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -0,0 +1,403 @@
+{-# LANGUAGE CPP, PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Convert
+-- Copyright : (c) Isaac Dupree 2009,
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Conversion between TyThing and HsDecl. This functionality may be moved into
+-- GHC at some point.
+-----------------------------------------------------------------------------
+module Haddock.Convert where
+-- Some other functions turned out to be useful for converting
+-- instance heads, which aren't TyThings, so just export everything.
+
+
+import HsSyn
+import TcType ( tcSplitSigmaTy )
+import TypeRep
+import Type(isStrLitTy)
+import Kind ( splitKindFunTys, synTyConResKind, isKind )
+import Name
+import Var
+import Class
+import TyCon
+import CoAxiom
+import ConLike
+import DataCon
+import PatSyn
+import FamInstEnv
+import BasicTypes ( TupleSort(..) )
+import TysPrim ( alphaTyVars )
+import TysWiredIn ( listTyConName, eqTyCon )
+import PrelNames (ipClassName)
+import Bag ( emptyBag )
+import Unique ( getUnique )
+import SrcLoc ( Located, noLoc, unLoc )
+import Data.List( partition )
+import Haddock.Types
+
+
+-- the main function here! yay!
+tyThingToLHsDecl :: TyThing -> LHsDecl Name
+tyThingToLHsDecl t = noLoc $ case t of
+ -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
+ -- Including built-in functions like seq.
+ -- foreign-imported functions could be represented with ForD
+ -- instead of SigD if we wanted...
+ --
+ -- in a future code version we could turn idVarDetails = foreign-call
+ -- into a ForD instead of a SigD if we wanted. Haddock doesn't
+ -- need to care.
+ AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
+
+ -- type-constructors (e.g. Maybe) are complicated, put the definition
+ -- later in the file (also it's used for class associated-types too.)
+ ATyCon tc
+ | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
+ -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a
+ extractFamilyDecl (FamDecl d) = noLoc d
+ extractFamilyDecl _ =
+ error "tyThingToLHsDecl: impossible associated tycon"
+
+ atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
+ atFamDecls = map extractFamilyDecl atTyClDecls in
+ TyClD $ ClassDecl
+ { tcdCtxt = synifyCtx (classSCTheta cl)
+ , tcdLName = synifyName cl
+ , tcdTyVars = synifyTyVars (classTyVars cl)
+ , tcdFDs = map (\ (l,r) -> noLoc
+ (map getName l, map getName r) ) $
+ snd $ classTvsFds cl
+ , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :
+ map (noLoc . synifyIdSig DeleteTopLevelQuantification)
+ (classMethods cl)
+ , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
+ -- class associated-types are a subset of TyCon:
+ , tcdATs = atFamDecls
+ , tcdATDefs = [] --ignore associated type defaults
+ , tcdDocs = [] --we don't have any docs at this point
+ , tcdFVs = placeHolderNames }
+ | otherwise
+ -> TyClD (synifyTyCon Nothing tc)
+
+ -- type-constructors (e.g. Maybe) are complicated, put the definition
+ -- later in the file (also it's used for class associated-types too.)
+ ACoAxiom ax -> synifyAxiom ax
+
+ -- a data-constructor alone just gets rendered as a function:
+ AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]
+ (synifyType ImplicitizeForAll (dataConUserType dc)))
+
+ AConLike (PatSynCon ps) ->
+#if MIN_VERSION_ghc(7,8,3)
+ let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
+#else
+ let (_, _, (req_theta, prov_theta)) = patSynSig ps
+#endif
+ in SigD $ PatSynSig (synifyName ps)
+#if MIN_VERSION_ghc(7,8,3)
+ (fmap (synifyType WithinType) (patSynTyDetails ps))
+ (synifyType WithinType res_ty)
+#else
+ (fmap (synifyType WithinType) (patSynTyDetails ps))
+ (synifyType WithinType (patSynType ps))
+#endif
+ (synifyCtx req_theta)
+ (synifyCtx prov_theta)
+
+synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
+synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
+ = let name = synifyName tc
+ typats = map (synifyType WithinType) args
+ hs_rhs = synifyType WithinType rhs
+ (kvs, tvs) = partition isKindVar tkvs
+ in TyFamInstEqn { tfie_tycon = name
+ , tfie_pats = HsWB { hswb_cts = typats
+ , hswb_kvs = map tyVarName kvs
+ , hswb_tvs = map tyVarName tvs }
+ , tfie_rhs = hs_rhs }
+
+synifyAxiom :: CoAxiom br -> HsDecl Name
+synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
+ | isOpenSynFamilyTyCon tc
+ , Just branch <- coAxiomSingleBranch_maybe ax
+ = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
+ , tfid_fvs = placeHolderNames }))
+
+ | Just ax' <- isClosedSynFamilyTyCon_maybe tc
+ , getUnique ax' == getUnique ax -- without the getUniques, type error
+ = TyClD (synifyTyCon (Just ax) tc)
+
+ | otherwise
+ = error "synifyAxiom: closed/open family confusion"
+
+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name
+synifyTyCon coax tc
+ | isFunTyCon tc || isPrimTyCon tc
+ = DataDecl { tcdLName = synifyName tc
+ , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
+ let mk_hs_tv realKind fakeTyVar
+ = noLoc $ KindedTyVar (getName fakeTyVar)
+ (synifyKindSig realKind)
+ in HsQTvs { hsq_kvs = [] -- No kind polymorphism
+ , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
+ alphaTyVars --a, b, c... which are unfortunately all kind *
+ }
+
+ , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
+ -- algebraic data nor newtype:
+ , dd_ctxt = noLoc []
+ , dd_cType = Nothing
+ , dd_kindSig = Just (synifyKindSig (tyConKind tc))
+ -- we have their kind accurately:
+ , dd_cons = [] -- No constructors
+ , dd_derivs = Nothing }
+ , tcdFVs = placeHolderNames }
+
+ | isSynFamilyTyCon tc
+ = case synTyConRhs_maybe tc of
+ Just rhs ->
+ let info = case rhs of
+ OpenSynFamilyTyCon -> OpenTypeFamily
+ ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
+ ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)
+ _ -> error "synifyTyCon: type/data family confusion"
+ in FamDecl (FamilyDecl { fdInfo = info
+ , fdLName = synifyName tc
+ , fdTyVars = synifyTyVars (tyConTyVars tc)
+ , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })
+ Nothing -> error "synifyTyCon: impossible open type synonym?"
+
+ | isDataFamilyTyCon tc
+ = --(why no "isOpenAlgTyCon"?)
+ case algTyConRhs tc of
+ DataFamilyTyCon ->
+ FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
+ Nothing) --always kind '*'
+ _ -> error "synifyTyCon: impossible open data type?"
+ | isSynTyCon tc
+ = case synTyConRhs_maybe tc of
+ Just (SynonymTyCon ty) ->
+ SynDecl { tcdLName = synifyName tc
+ , tcdTyVars = synifyTyVars (tyConTyVars tc)
+ , tcdRhs = synifyType WithinType ty
+ , tcdFVs = placeHolderNames }
+ _ -> error "synifyTyCon: impossible synTyCon"
+ | otherwise =
+ -- (closed) newtype and data
+ let
+ alg_nd = if isNewTyCon tc then NewType else DataType
+ alg_ctx = synifyCtx (tyConStupidTheta tc)
+ name = case coax of
+ Just a -> synifyName a -- Data families are named according to their
+ -- CoAxioms, not their TyCons
+ _ -> synifyName tc
+ tyvars = synifyTyVars (tyConTyVars tc)
+ kindSig = Just (tyConKind tc)
+ -- The data constructors.
+ --
+ -- Any data-constructors not exported from the module that *defines* the
+ -- type will not (cannot) be included.
+ --
+ -- Very simple constructors, Haskell98 with no existentials or anything,
+ -- probably look nicer in non-GADT syntax. In source code, all constructors
+ -- must be declared with the same (GADT vs. not) syntax, and it probably
+ -- is less confusing to follow that principle for the documentation as well.
+ --
+ -- There is no sensible infix-representation for GADT-syntax constructor
+ -- declarations. They cannot be made in source code, but we could end up
+ -- with some here in the case where some constructors use existentials.
+ -- That seems like an acceptable compromise (they'll just be documented
+ -- in prefix position), since, otherwise, the logic (at best) gets much more
+ -- complicated. (would use dataConIsInfix.)
+ use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
+ cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
+ -- "deriving" doesn't affect the signature, no need to specify any.
+ alg_deriv = Nothing
+ defn = HsDataDefn { dd_ND = alg_nd
+ , dd_ctxt = alg_ctx
+ , dd_cType = Nothing
+ , dd_kindSig = fmap synifyKindSig kindSig
+ , dd_cons = cons
+ , dd_derivs = alg_deriv }
+ in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
+ , tcdFVs = placeHolderNames }
+
+-- User beware: it is your responsibility to pass True (use_gadt_syntax)
+-- for any constructor that would be misrepresented by omitting its
+-- result-type.
+-- But you might want pass False in simple enough cases,
+-- if you think it looks better.
+synifyDataCon :: Bool -> DataCon -> LConDecl Name
+synifyDataCon use_gadt_syntax dc = noLoc $
+ let
+ -- dataConIsInfix allegedly tells us whether it was declared with
+ -- infix *syntax*.
+ use_infix_syntax = dataConIsInfix dc
+ use_named_field_syntax = not (null field_tys)
+ name = synifyName dc
+ -- con_qvars means a different thing depending on gadt-syntax
+ (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
+
+ qvars = if use_gadt_syntax
+ then synifyTyVars (univ_tvs ++ ex_tvs)
+ else synifyTyVars ex_tvs
+
+ -- skip any EqTheta, use 'orig'inal syntax
+ ctx = synifyCtx theta
+
+ linear_tys = zipWith (\ty bang ->
+ let tySyn = synifyType WithinType ty
+ src_bang = case bang of
+ HsUnpack {} -> HsUserBang (Just True) True
+ HsStrict -> HsUserBang (Just False) True
+ _ -> bang
+ in case src_bang of
+ HsNoBang -> tySyn
+ _ -> noLoc $ HsBangTy bang tySyn
+ -- HsNoBang never appears, it's implied instead.
+ )
+ arg_tys (dataConStrictMarks dc)
+ field_tys = zipWith (\field synTy -> ConDeclField
+ (synifyName field) synTy Nothing)
+ (dataConFieldLabels dc) linear_tys
+ hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
+ (True,True) -> error "synifyDataCon: contradiction!"
+ (True,False) -> RecCon field_tys
+ (False,False) -> PrefixCon linear_tys
+ (False,True) -> case linear_tys of
+ [a,b] -> InfixCon a b
+ _ -> error "synifyDataCon: infix with non-2 args?"
+ hs_res_ty = if use_gadt_syntax
+ then ResTyGADT (synifyType WithinType res_ty)
+ else ResTyH98
+ -- finally we get synifyDataCon's result!
+ in ConDecl name Implicit{-we don't know nor care-}
+ qvars ctx hs_arg_tys hs_res_ty Nothing
+ False --we don't want any "deprecated GADT syntax" warnings!
+
+
+synifyName :: NamedThing n => n -> Located Name
+synifyName = noLoc . getName
+
+
+synifyIdSig :: SynifyTypeState -> Id -> Sig Name
+synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
+
+
+synifyCtx :: [PredType] -> LHsContext Name
+synifyCtx = noLoc . map (synifyType WithinType)
+
+
+synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
+synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
+ , hsq_tvs = map synifyTyVar tvs }
+ where
+ (kvs, tvs) = partition isKindVar ktvs
+ synifyTyVar tv
+ | isLiftedTypeKind kind = noLoc (UserTyVar name)
+ | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))
+ where
+ kind = tyVarKind tv
+ name = getName tv
+
+--states of what to do with foralls:
+data SynifyTypeState
+ = WithinType
+ -- ^ normal situation. This is the safe one to use if you don't
+ -- quite understand what's going on.
+ | ImplicitizeForAll
+ -- ^ beginning of a function definition, in which, to make it look
+ -- less ugly, those rank-1 foralls are made implicit.
+ | DeleteTopLevelQuantification
+ -- ^ because in class methods the context is added to the type
+ -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
+ -- which is rather sensible,
+ -- but we want to restore things to the source-syntax situation where
+ -- the defining class gets to quantify all its functions for free!
+
+
+synifyType :: SynifyTypeState -> Type -> LHsType Name
+synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
+synifyType _ (TyConApp tc tys)
+ -- Use non-prefix tuple syntax where possible, because it looks nicer.
+ | isTupleTyCon tc, tyConArity tc == length tys =
+ noLoc $ HsTupleTy (case tupleTyConSort tc of
+ BoxedTuple -> HsBoxedTuple
+ ConstraintTuple -> HsConstraintTuple
+ UnboxedTuple -> HsUnboxedTuple)
+ (map (synifyType WithinType) tys)
+ -- ditto for lists
+ | getName tc == listTyConName, [ty] <- tys =
+ noLoc $ HsListTy (synifyType WithinType ty)
+ -- ditto for implicit parameter tycons
+ | tyConName tc == ipClassName
+ , [name, ty] <- tys
+ , Just x <- isStrLitTy name
+ = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
+ -- and equalities
+ | tc == eqTyCon
+ , [ty1, ty2] <- tys
+ = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
+ -- Most TyCons:
+ | otherwise =
+ foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
+ (noLoc $ HsTyVar (getName tc))
+ (map (synifyType WithinType) tys)
+synifyType _ (AppTy t1 t2) = let
+ s1 = synifyType WithinType t1
+ s2 = synifyType WithinType t2
+ in noLoc $ HsAppTy s1 s2
+synifyType _ (FunTy t1 t2) = let
+ s1 = synifyType WithinType t1
+ s2 = synifyType WithinType t2
+ in noLoc $ HsFunTy s1 s2
+synifyType s forallty@(ForAllTy _tv _ty) =
+ let (tvs, ctx, tau) = tcSplitSigmaTy forallty
+ in case s of
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
+ _ -> let
+ forallPlicitness = case s of
+ WithinType -> Explicit
+ ImplicitizeForAll -> Implicit
+ _ -> error "synifyType: impossible case!!!"
+ sTvs = synifyTyVars tvs
+ sCtx = synifyCtx ctx
+ sTau = synifyType WithinType tau
+ in noLoc $
+ HsForAllTy forallPlicitness sTvs sCtx sTau
+synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
+
+synifyTyLit :: TyLit -> HsTyLit
+synifyTyLit (NumTyLit n) = HsNumTy n
+synifyTyLit (StrTyLit s) = HsStrTy s
+
+synifyKindSig :: Kind -> LHsKind Name
+synifyKindSig k = synifyType WithinType k
+
+synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
+synifyInstHead (_, preds, cls, types) =
+ ( getName cls
+ , map (unLoc . synifyType WithinType) ks
+ , map (unLoc . synifyType WithinType) ts
+ , ClassInst $ map (unLoc . synifyType WithinType) preds
+ )
+ where (ks,ts) = break (not . isKind) types
+
+-- Convert a family instance, this could be a type family or data family
+synifyFamInst :: FamInst -> Bool -> InstHead Name
+synifyFamInst fi opaque =
+ ( fi_fam fi
+ , map (unLoc . synifyType WithinType) ks
+ , map (unLoc . synifyType WithinType) ts
+ , case fi_flavor fi of
+ SynFamilyInst | opaque -> TypeInst Nothing
+ SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+ DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
+ )
+ where (ks,ts) = break (not . isKind) $ fi_tys fi
diff --git a/haddock-api/src/Haddock/Doc.hs b/haddock-api/src/Haddock/Doc.hs
new file mode 100644
index 00000000..91ad709f
--- /dev/null
+++ b/haddock-api/src/Haddock/Doc.hs
@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Haddock.Doc ( module Documentation.Haddock.Doc
+ , docCodeBlock
+ , combineDocumentation
+ ) where
+
+import Data.Maybe
+import Documentation.Haddock.Doc
+import Haddock.Types
+
+combineDocumentation :: Documentation name -> Maybe (Doc name)
+combineDocumentation (Documentation Nothing Nothing) = Nothing
+combineDocumentation (Documentation mDoc mWarning) =
+ Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc)
+
+-- Drop trailing whitespace from @..@ code blocks. Otherwise this:
+--
+-- -- @
+-- -- foo
+-- -- @
+--
+-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
+-- gives an extra vertical space after the code block. The single space
+-- on the final line seems to trigger the extra vertical space.
+--
+docCodeBlock :: DocH mod id -> DocH mod id
+docCodeBlock (DocString s)
+ = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
+docCodeBlock (DocAppend l r)
+ = DocAppend l (docCodeBlock r)
+docCodeBlock d = d
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
new file mode 100644
index 00000000..c06b34a6
--- /dev/null
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -0,0 +1,304 @@
+{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.GhcUtils
+-- Copyright : (c) David Waern 2006-2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Utils for dealing with types from the GHC API
+-----------------------------------------------------------------------------
+module Haddock.GhcUtils where
+
+
+import Data.Version
+import Control.Applicative ( (<$>) )
+import Control.Arrow
+import Data.Foldable hiding (concatMap)
+import Data.Function
+import Data.Traversable
+import Distribution.Compat.ReadP
+import Distribution.Text
+
+import Exception
+import Outputable
+import Name
+import Packages
+import Module
+import RdrName (GlobalRdrEnv)
+import GhcMonad (withSession)
+import HscTypes
+import UniqFM
+import GHC
+import Class
+
+
+moduleString :: Module -> String
+moduleString = moduleNameString . moduleName
+
+
+-- return the (name,version) of the package
+modulePackageInfo :: Module -> (String, [Char])
+modulePackageInfo modu = case unpackPackageId pkg of
+ Nothing -> (packageIdString pkg, "")
+ Just x -> (display $ pkgName x, showVersion (pkgVersion x))
+ where pkg = modulePackageId modu
+
+
+-- This was removed from GHC 6.11
+-- XXX we shouldn't be using it, probably
+
+-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
+-- we could not parse it as such an object.
+unpackPackageId :: PackageId -> Maybe PackageIdentifier
+unpackPackageId p
+ = case [ pid | (pid,"") <- readP_to_S parse str ] of
+ [] -> Nothing
+ (pid:_) -> Just pid
+ where str = packageIdString p
+
+
+lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
+lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
+ case lookupUFM (hsc_HPT hsc_env) mod_name of
+ Just mod_info -> return (mi_globals (hm_iface mod_info))
+ _not_a_home_module -> return Nothing
+
+
+isNameSym :: Name -> Bool
+isNameSym = isSymOcc . nameOccName
+
+
+isVarSym :: OccName -> Bool
+isVarSym = isLexVarSym . occNameFS
+
+isConSym :: OccName -> Bool
+isConSym = isLexConSym . occNameFS
+
+
+getMainDeclBinder :: HsDecl name -> [name]
+getMainDeclBinder (TyClD d) = [tcdName d]
+getMainDeclBinder (ValD d) =
+ case collectHsBindBinders d of
+ [] -> []
+ (name:_) -> [name]
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
+getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
+getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
+getInstLoc (TyFamInstD (TyFamInstDecl
+ -- Since CoAxioms' Names refer to the whole line for type family instances
+ -- in particular, we need to dig a bit deeper to pull out the entire
+ -- equation. This does not happen for data family instances, for some reason.
+ { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l
+
+-- Useful when there is a signature with multiple names, e.g.
+-- foo, bar :: Types..
+-- but only one of the names is exported and we have to change the
+-- type signature to only include the exported names.
+filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)
+filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
+
+filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
+filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
+filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
+filterSigNames _ orig@(MinimalSig _) = Just orig
+filterSigNames p (TypeSig ns ty) =
+ case filter (p . unLoc) ns of
+ [] -> Nothing
+ filtered -> Just (TypeSig filtered ty)
+filterSigNames _ _ = Nothing
+
+ifTrueJust :: Bool -> name -> Maybe name
+ifTrueJust True = Just
+ifTrueJust False = const Nothing
+
+sigName :: LSig name -> [name]
+sigName (L _ sig) = sigNameNoLoc sig
+
+sigNameNoLoc :: Sig name -> [name]
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
+sigNameNoLoc (SpecSig n _ _) = [unLoc n]
+sigNameNoLoc (InlineSig n _) = [unLoc n]
+sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
+sigNameNoLoc _ = []
+
+
+isTyClD :: HsDecl a -> Bool
+isTyClD (TyClD _) = True
+isTyClD _ = False
+
+
+isClassD :: HsDecl a -> Bool
+isClassD (TyClD d) = isClassDecl d
+isClassD _ = False
+
+
+isDocD :: HsDecl a -> Bool
+isDocD (DocD _) = True
+isDocD _ = False
+
+
+isInstD :: HsDecl a -> Bool
+isInstD (InstD _) = True
+isInstD _ = False
+
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _) = True
+isValD _ = False
+
+
+declATs :: HsDecl a -> [a]
+declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
+declATs _ = []
+
+
+pretty :: Outputable a => DynFlags -> a -> String
+pretty = showPpr
+
+
+trace_ppr :: Outputable a => DynFlags -> a -> b -> b
+trace_ppr dflags x y = trace (pretty dflags x) y
+
+
+-------------------------------------------------------------------------------
+-- * Located
+-------------------------------------------------------------------------------
+
+
+unL :: Located a -> a
+unL (L _ x) = x
+
+
+reL :: a -> Located a
+reL = L undefined
+
+
+before :: Located a -> Located a -> Bool
+before = (<) `on` getLoc
+
+
+instance Foldable (GenLocated l) where
+ foldMap f (L _ x) = f x
+
+
+instance Traversable (GenLocated l) where
+ mapM f (L l x) = (return . L l) =<< f x
+ traverse f (L l x) = L l <$> f x
+
+-------------------------------------------------------------------------------
+-- * NamedThing instances
+-------------------------------------------------------------------------------
+
+
+instance NamedThing (TyClDecl Name) where
+ getName = tcdName
+
+
+instance NamedThing (ConDecl Name) where
+ getName = unL . con_name
+
+
+-------------------------------------------------------------------------------
+-- * Subordinates
+-------------------------------------------------------------------------------
+
+
+class Parent a where
+ children :: a -> [Name]
+
+
+instance Parent (ConDecl Name) where
+ children con =
+ case con_details con of
+ RecCon fields -> map (unL . cd_fld_name) fields
+ _ -> []
+
+
+instance Parent (TyClDecl Name) where
+ children d
+ | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d
+ | isClassDecl d =
+ map (unL . fdLName . unL) (tcdATs d) ++
+ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
+ | otherwise = []
+
+
+-- | A parent and its children
+family :: (NamedThing a, Parent a) => a -> (Name, [Name])
+family = getName &&& children
+
+
+-- | A mapping from the parent (main-binder) to its children and from each
+-- child to its grand-children, recursively.
+families :: TyClDecl Name -> [(Name, [Name])]
+families d
+ | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))
+ | isClassDecl d = [family d]
+ | otherwise = []
+
+
+-- | A mapping from child to parent
+parentMap :: TyClDecl Name -> [(Name, Name)]
+parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
+
+
+-- | The parents of a subordinate in a declaration
+parents :: Name -> HsDecl Name -> [Name]
+parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
+parents _ _ = []
+
+
+-------------------------------------------------------------------------------
+-- * Utils that work in monads defined by GHC
+-------------------------------------------------------------------------------
+
+
+modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
+modifySessionDynFlags f = do
+ dflags <- getSessionDynFlags
+ _ <- setSessionDynFlags (f dflags)
+ return ()
+
+
+-- | A variant of 'gbracket' where the return value from the first computation
+-- is not required.
+gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
+gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
+
+-- Extract the minimal complete definition of a Name, if one exists
+minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
+minimalDef n = do
+ mty <- lookupGlobalName n
+ case mty of
+ Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
+ _ -> return Nothing
+
+-------------------------------------------------------------------------------
+-- * DynFlags
+-------------------------------------------------------------------------------
+
+
+setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
+setObjectDir f d = d{ objectDir = Just f}
+setHiDir f d = d{ hiDir = Just f}
+setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
+ -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
+ -- \#included from the .hc file when compiling with -fvia-C.
+setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
+
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
new file mode 100644
index 00000000..60a20fe5
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -0,0 +1,244 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2010,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- This module typechecks Haskell modules using the GHC API and processes
+-- the result to create 'Interface's. The typechecking and the 'Interface'
+-- creation is interleaved, so that when a module is processed, the
+-- 'Interface's of all previously processed modules are available. The
+-- creation of an 'Interface' from a typechecked module is delegated to
+-- "Haddock.Interface.Create".
+--
+-- When all modules have been typechecked and processed, information about
+-- instances are attached to each 'Interface'. This task is delegated to
+-- "Haddock.Interface.AttachInstances". Note that this is done as a separate
+-- step because GHC can't know about all instances until all modules have been
+-- typechecked.
+--
+-- As a last step a link environment is built which maps names to the \"best\"
+-- places to link to in the documentation, and all 'Interface's are \"renamed\"
+-- using this environment.
+-----------------------------------------------------------------------------
+module Haddock.Interface (
+ processModules
+) where
+
+
+import Haddock.GhcUtils
+import Haddock.InterfaceFile
+import Haddock.Interface.Create
+import Haddock.Interface.AttachInstances
+import Haddock.Interface.Rename
+import Haddock.Options hiding (verbosity)
+import Haddock.Types
+import Haddock.Utils
+
+import Control.Monad
+import Data.List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Distribution.Verbosity
+import System.Directory
+import System.FilePath
+import Text.Printf
+
+import Digraph
+import DynFlags hiding (verbosity)
+import Exception
+import GHC hiding (verbosity)
+import HscTypes
+import FastString (unpackFS)
+
+-- | Create 'Interface's and a link environment by typechecking the list of
+-- modules using the GHC API and processing the resulting syntax trees.
+processModules
+ :: Verbosity -- ^ Verbosity of logging to 'stdout'
+ -> [String] -- ^ A list of file or module names sorted by
+ -- module topology
+ -> [Flag] -- ^ Command-line flags
+ -> [InterfaceFile] -- ^ Interface files of package dependencies
+ -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
+ -- environment
+processModules verbosity modules flags extIfaces = do
+
+ out verbosity verbose "Creating interfaces..."
+ let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
+ , iface <- ifInstalledIfaces ext ]
+ interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+
+ let exportedNames =
+ Set.unions $ map (Set.fromList . ifaceExports) $
+ filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
+ mods = Set.fromList $ map ifaceMod interfaces
+ out verbosity verbose "Attaching instances..."
+ interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap
+
+ out verbosity verbose "Building cross-linking environment..."
+ -- Combine the link envs of the external packages into one
+ let extLinks = Map.unions (map ifLinkEnv extIfaces)
+ homeLinks = buildHomeLinks interfaces -- Build the environment for the home
+ -- package
+ links = homeLinks `Map.union` extLinks
+
+ out verbosity verbose "Renaming interfaces..."
+ let warnings = Flag_NoWarnings `notElem` flags
+ dflags <- getDynFlags
+ let (interfaces'', msgs) =
+ runWriter $ mapM (renameInterface dflags links warnings) interfaces'
+ liftIO $ mapM_ putStrLn msgs
+
+ return (interfaces'', homeLinks)
+
+
+--------------------------------------------------------------------------------
+-- * Module typechecking and Interface creation
+--------------------------------------------------------------------------------
+
+
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 verbosity modules flags instIfaceMap =
+ -- Output dir needs to be set before calling depanal since depanal uses it to
+ -- compute output file names that are stored in the DynFlags of the
+ -- resulting ModSummaries.
+ (if useTempDir then withTempOutputDir else id) $ do
+ modGraph <- depAnalysis
+ if needsTemplateHaskell modGraph then do
+ modGraph' <- enableCompilation modGraph
+ createIfaces verbosity flags instIfaceMap modGraph'
+ else
+ createIfaces verbosity flags instIfaceMap modGraph
+
+ where
+ useTempDir :: Bool
+ useTempDir = Flag_NoTmpCompDir `notElem` flags
+
+
+ withTempOutputDir :: Ghc a -> Ghc a
+ withTempOutputDir action = do
+ tmp <- liftIO getTemporaryDirectory
+ x <- liftIO getProcessID
+ let dir = tmp </> ".haddock-" ++ show x
+ modifySessionDynFlags (setOutputDir dir)
+ withTempDir dir action
+
+
+ depAnalysis :: Ghc ModuleGraph
+ depAnalysis = do
+ targets <- mapM (\f -> guessTarget f Nothing) modules
+ setTargets targets
+ depanal [] False
+
+
+ enableCompilation :: ModuleGraph -> Ghc ModuleGraph
+ enableCompilation modGraph = do
+ let enableComp d = let platform = targetPlatform d
+ in d { hscTarget = defaultObjectTarget platform }
+ modifySessionDynFlags enableComp
+ -- We need to update the DynFlags of the ModSummaries as well.
+ let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
+ let modGraph' = map upd modGraph
+ return modGraph'
+
+
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces verbosity flags instIfaceMap mods = do
+ let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
+ out verbosity normal "Haddock coverage:"
+ (ifaces, _) <- foldM f ([], Map.empty) sortedMods
+ return (reverse ifaces)
+ where
+ f (ifaces, ifaceMap) modSummary = do
+ x <- processModule verbosity modSummary flags ifaceMap instIfaceMap
+ return $ case x of
+ Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
+ Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
+
+
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule verbosity modsum flags modMap instIfaceMap = do
+ out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
+ tm <- loadModule =<< typecheckModule =<< parseModule modsum
+ if not $ isBootSummary modsum then do
+ out verbosity verbose "Creating interface..."
+ (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+ liftIO $ mapM_ putStrLn msg
+ dflags <- getDynFlags
+ let (haddockable, haddocked) = ifaceHaddockCoverage interface
+ percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
+ modString = moduleString (ifaceMod interface)
+ coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
+ header = case ifaceDoc interface of
+ Documentation Nothing _ -> False
+ _ -> True
+ undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
+ , expItemMbDoc = (Documentation Nothing _, _)
+ } <- ifaceExportItems interface ]
+ where
+ formatName :: SrcSpan -> HsDecl Name -> String
+ formatName loc n = p (getMainDeclBinder n) ++ case loc of
+ RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
+ _ -> ""
+
+ p [] = ""
+ p (x:_) = let n = pretty dflags x
+ ms = modString ++ "."
+ in if ms `isPrefixOf` n
+ then drop (length ms) n
+ else n
+
+ out verbosity normal coverageMsg
+ when (Flag_PrintMissingDocs `elem` flags
+ && not (null undocumentedExports && header)) $ do
+ out verbosity normal " Missing documentation for:"
+ unless header $ out verbosity normal " Module header"
+ mapM_ (out verbosity normal . (" " ++)) undocumentedExports
+ interface' <- liftIO $ evaluate interface
+ return (Just interface')
+ else
+ return Nothing
+
+
+--------------------------------------------------------------------------------
+-- * Building of cross-linking environment
+--------------------------------------------------------------------------------
+
+
+-- | Build a mapping which for each original name, points to the "best"
+-- place to link to in the documentation. For the definition of
+-- "best", we use "the module nearest the bottom of the dependency
+-- graph which exports this name", not including hidden modules. When
+-- there are multiple choices, we pick a random one.
+--
+-- The interfaces are passed in in topologically sorted order, but we start
+-- by reversing the list so we can do a foldl.
+buildHomeLinks :: [Interface] -> LinkEnv
+buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
+ where
+ upd old_env iface
+ | OptHide `elem` ifaceOptions iface = old_env
+ | OptNotHome `elem` ifaceOptions iface =
+ foldl' keep_old old_env exported_names
+ | otherwise = foldl' keep_new old_env exported_names
+ where
+ exported_names = ifaceVisibleExports iface
+ mdl = ifaceMod iface
+ keep_old env n = Map.insertWith (\_ old -> old) n mdl env
+ keep_new env n = Map.insert n mdl env
+
+
+--------------------------------------------------------------------------------
+-- * Utils
+--------------------------------------------------------------------------------
+
+
+withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
+withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
+ (liftIO $ removeDirectoryRecursive dir)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
new file mode 100644
index 00000000..a0bac8fc
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE CPP, MagicHash #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.AttachInstances
+-- Copyright : (c) Simon Marlow 2006,
+-- David Waern 2006-2009,
+-- Isaac Dupree 2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.AttachInstances (attachInstances) where
+
+
+import Haddock.Types
+import Haddock.Convert
+import Haddock.GhcUtils
+
+import Control.Arrow
+import Data.List
+import Data.Ord (comparing)
+import Data.Function (on)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Class
+import FamInstEnv
+import FastString
+import GHC
+import GhcMonad (withSession)
+import Id
+import InstEnv
+import MonadUtils (liftIO)
+import Name
+import PrelNames
+import TcRnDriver (tcRnGetInfo)
+import TcType (tcSplitSigmaTy)
+import TyCon
+import TypeRep
+import TysPrim( funTyCon )
+import Var hiding (varName)
+#define FSLIT(x) (mkFastString# (x#))
+
+type ExportedNames = Set.Set Name
+type Modules = Set.Set Module
+type ExportInfo = (ExportedNames, Modules)
+
+-- Also attaches fixities
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
+ where
+ -- TODO: take an IfaceMap as input
+ ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
+
+ attach iface = do
+ newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
+ (ifaceExportItems iface)
+ return $ iface { ifaceExportItems = newItems }
+
+
+attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
+attachToExportItem expInfo iface ifaceMap instIfaceMap export =
+ case attachFixities export of
+ e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+ mb_info <- getAllInfo (tcdName d)
+ let export' =
+ e {
+ expItemInstances =
+ case mb_info of
+ Just (_, _, cls_instances, fam_instances) ->
+ let fam_insts = [ (synifyFamInst i opaque, n)
+ | i <- sortBy (comparing instFam) fam_instances
+ , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
+ , not $ isNameHidden expInfo (fi_fam i)
+ , not $ any (isTypeHidden expInfo) (fi_tys i)
+ , let opaque = isTypeHidden expInfo (fi_rhs i)
+ ]
+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
+ | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
+ , not $ isInstanceHidden expInfo cls tys
+ ]
+ in cls_insts ++ fam_insts
+ Nothing -> []
+ }
+ return export'
+ e -> return e
+ where
+ attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
+ nubBy ((==) `on` fst) $ expItemFixities e ++
+ [ (n',f) | n <- getMainDeclBinder d
+ , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
+ , n' <- n : subs
+ , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ ] }
+
+ attachFixities e = e
+
+
+instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
+ -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
+instLookup f name iface ifaceMap instIfaceMap =
+ case Map.lookup name (f $ toInstalledIface iface) of
+ res@(Just _) -> res
+ Nothing -> do
+ let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
+ iface' <- Map.lookup (nameModule name) ifaceMaps
+ Map.lookup name (f iface')
+
+-- | Like GHC's 'instanceHead' but drops "silent" arguments.
+instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
+instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
+ where
+ dfun = is_dfun ispec
+ (tvs, cls, tys) = instanceHead ispec
+ (_, theta, _) = tcSplitSigmaTy (idType dfun)
+
+-- | Drop "silent" arguments. See GHC Note [Silent superclass
+-- arguments].
+dropSilentArgs :: DFunId -> ThetaType -> ThetaType
+dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
+
+
+-- | Like GHC's getInfo but doesn't cut things out depending on the
+-- interative context, which we don't set sufficiently anyway.
+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
+getAllInfo name = withSession $ \hsc_env -> do
+ (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
+ return r
+
+
+--------------------------------------------------------------------------------
+-- Collecting and sorting instances
+--------------------------------------------------------------------------------
+
+
+-- | Simplified type for sorting types, ignoring qualification (not visible
+-- in Haddock output) and unifying special tycons with normal ones.
+-- For the benefit of the user (looks nice and predictable) and the
+-- tests (which prefer output to be deterministic).
+data SimpleType = SimpleType Name [SimpleType]
+ | SimpleTyLit TyLit
+ deriving (Eq,Ord)
+
+
+instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
+instHead (_, _, cls, args)
+ = (map argCount args, className cls, map simplify args)
+
+argCount :: Type -> Int
+argCount (AppTy t _) = argCount t + 1
+argCount (TyConApp _ ts) = length ts
+argCount (FunTy _ _ ) = 2
+argCount (ForAllTy _ t) = argCount t
+argCount _ = 0
+
+simplify :: Type -> SimpleType
+simplify (ForAllTy _ t) = simplify t
+simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
+simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
+ where (SimpleType s ts) = simplify t1
+simplify (TyVarTy v) = SimpleType (tyVarName v) []
+simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
+simplify (LitTy l) = SimpleTyLit l
+
+-- Used for sorting
+instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
+instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
+ = (map argCount ts, n, map simplify ts, argCount t, simplify t)
+
+
+funTyConName :: Name
+funTyConName = mkWiredInName gHC_PRIM
+ (mkOccNameFS tcName FSLIT("(->)"))
+ funTyConKey
+ (ATyCon funTyCon) -- Relevant TyCon
+ BuiltInSyntax
+
+--------------------------------------------------------------------------------
+-- Filtering hidden instances
+--------------------------------------------------------------------------------
+
+-- | A class or data type is hidden iff
+--
+-- * it is defined in one of the modules that are being processed
+--
+-- * and it is not exported by any non-hidden module
+isNameHidden :: ExportInfo -> Name -> Bool
+isNameHidden (names, modules) name =
+ nameModule name `Set.member` modules &&
+ not (name `Set.member` names)
+
+-- | We say that an instance is «hidden» iff its class or any (part)
+-- of its type(s) is hidden.
+isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool
+isInstanceHidden expInfo cls tys =
+ instClassHidden || instTypeHidden
+ where
+ instClassHidden :: Bool
+ instClassHidden = isNameHidden expInfo $ getName cls
+
+ instTypeHidden :: Bool
+ instTypeHidden = any (isTypeHidden expInfo) tys
+
+isTypeHidden :: ExportInfo -> Type -> Bool
+isTypeHidden expInfo = typeHidden
+ where
+ typeHidden :: Type -> Bool
+ typeHidden t =
+ case t of
+ TyVarTy {} -> False
+ AppTy t1 t2 -> typeHidden t1 || typeHidden t2
+ TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
+ FunTy t1 t2 -> typeHidden t1 || typeHidden t2
+ ForAllTy _ ty -> typeHidden ty
+ LitTy _ -> False
+
+ nameHidden :: Name -> Bool
+ nameHidden = isNameHidden expInfo
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
new file mode 100644
index 00000000..b66773ae
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -0,0 +1,867 @@
+{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
+{-# OPTIONS_GHC -Wwarn #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.Create
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.Create (createInterface) where
+
+import Documentation.Haddock.Doc (docAppend)
+import Haddock.Types
+import Haddock.Options
+import Haddock.GhcUtils
+import Haddock.Utils
+import Haddock.Convert
+import Haddock.Interface.LexParseRn
+
+import qualified Data.Map as M
+import Data.Map (Map)
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Data.Ord
+import Control.Applicative
+import Control.Arrow (second)
+import Control.DeepSeq
+import Control.Monad
+import Data.Function (on)
+import qualified Data.Foldable as F
+
+import qualified Packages
+import qualified Module
+import qualified SrcLoc
+import GHC
+import HscTypes
+import Name
+import Bag
+import RdrName
+import TcRnTypes
+import FastString (concatFS)
+
+
+-- | Use a 'TypecheckedModule' to produce an 'Interface'.
+-- To do this, we need access to already processed modules in the topological
+-- sort. That's what's in the 'IfaceMap'.
+createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
+createInterface tm flags modMap instIfaceMap = do
+
+ let ms = pm_mod_summary . tm_parsed_module $ tm
+ mi = moduleInfo tm
+ L _ hsm = parsedSource tm
+ !safety = modInfoSafe mi
+ mdl = ms_mod ms
+ dflags = ms_hspp_opts ms
+ !instances = modInfoInstances mi
+ !fam_instances = md_fam_insts md
+ !exportedNames = modInfoExports mi
+
+ (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
+
+ -- The renamed source should always be available to us, but it's best
+ -- to be on the safe side.
+ (group_, mayExports, mayDocHeader) <-
+ case renamedSource tm of
+ Nothing -> do
+ liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
+ return (emptyRnGroup, Nothing, Nothing)
+ Just (x, _, y, z) -> return (x, y, z)
+
+ opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
+ let opts
+ | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
+ | otherwise = opts0
+
+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
+
+ let declsWithDocs = topDecls group_
+ fixMap = mkFixMap group_
+ (decls, _) = unzip declsWithDocs
+ localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
+ ++ map getName fam_instances
+ -- Locations of all TH splices
+ splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
+
+ maps@(!docMap, !argMap, !subMap, !declMap, _) =
+ mkMaps dflags gre localInsts declsWithDocs
+
+ let exports0 = fmap (reverse . map unLoc) mayExports
+ exports
+ | OptIgnoreExports `elem` opts = Nothing
+ | otherwise = exports0
+ warningMap = mkWarningMap dflags warnings gre exportedNames
+
+ let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
+
+ exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
+ maps fixMap splices exports instIfaceMap dflags
+
+ let !visibleNames = mkVisibleNames maps exportItems opts
+
+ -- Measure haddock documentation coverage.
+ let prunedExportItems0 = pruneExportItems exportItems
+ !haddockable = 1 + length exportItems -- module + exports
+ !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
+ !coverage = (haddockable, haddocked)
+
+ -- Prune the export list to just those declarations that have
+ -- documentation, if the 'prune' option is on.
+ let prunedExportItems'
+ | OptPrune `elem` opts = prunedExportItems0
+ | otherwise = exportItems
+ !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
+
+ let !aliases =
+ mkAliasMap dflags $ tm_renamed_source tm
+ modWarn = moduleWarning dflags gre warnings
+
+ return $! Interface {
+ ifaceMod = mdl
+ , ifaceOrigFilename = msHsFilePath ms
+ , ifaceInfo = info
+ , ifaceDoc = Documentation mbDoc modWarn
+ , ifaceRnDoc = Documentation Nothing Nothing
+ , ifaceOptions = opts
+ , ifaceDocMap = docMap
+ , ifaceArgMap = argMap
+ , ifaceRnDocMap = M.empty
+ , ifaceRnArgMap = M.empty
+ , ifaceExportItems = prunedExportItems
+ , ifaceRnExportItems = []
+ , ifaceExports = exportedNames
+ , ifaceVisibleExports = visibleNames
+ , ifaceDeclMap = declMap
+ , ifaceSubMap = subMap
+ , ifaceFixMap = fixMap
+ , ifaceModuleAliases = aliases
+ , ifaceInstances = instances
+ , ifaceFamInstances = fam_instances
+ , ifaceHaddockCoverage = coverage
+ , ifaceWarningMap = warningMap
+ }
+
+mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
+mkAliasMap dflags mRenamedSource =
+ case mRenamedSource of
+ Nothing -> M.empty
+ Just (_,impDecls,_,_) ->
+ M.fromList $
+ mapMaybe (\(SrcLoc.L _ impDecl) -> do
+ alias <- ideclAs impDecl
+ return $
+ (lookupModuleDyn dflags
+ (fmap Module.fsToPackageId $
+ ideclPkgQual impDecl)
+ (case ideclName impDecl of SrcLoc.L _ name -> name),
+ alias))
+ impDecls
+
+-- similar to GHC.lookupModule
+lookupModuleDyn ::
+ DynFlags -> Maybe PackageId -> ModuleName -> Module
+lookupModuleDyn _ (Just pkgId) mdlName =
+ Module.mkModule pkgId mdlName
+lookupModuleDyn dflags Nothing mdlName =
+ flip Module.mkModule mdlName $
+ case filter snd $
+ Packages.lookupModuleInAllPackages dflags mdlName of
+ (pkgId,_):_ -> Packages.packageConfigId pkgId
+ [] -> Module.mainPackageId
+
+
+-------------------------------------------------------------------------------
+-- Warnings
+-------------------------------------------------------------------------------
+
+mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
+mkWarningMap dflags warnings gre exps = case warnings of
+ NoWarnings -> M.empty
+ WarnAll _ -> M.empty
+ WarnSome ws ->
+ let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
+ , let n = gre_name elt, n `elem` exps ]
+ in M.fromList $ map (second $ parseWarning dflags gre) ws'
+
+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
+moduleWarning _ _ NoWarnings = Nothing
+moduleWarning _ _ (WarnSome _) = Nothing
+moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
+
+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
+parseWarning dflags gre w = force $ case w of
+ DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
+ WarningTxt msg -> format "Warning: " (concatFS msg)
+ where
+ format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
+ . processDocString dflags gre $ HsDocString xs
+
+
+-------------------------------------------------------------------------------
+-- Doc options
+--
+-- Haddock options that are embedded in the source file
+-------------------------------------------------------------------------------
+
+
+mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
+mkDocOpts mbOpts flags mdl = do
+ opts <- case mbOpts of
+ Just opts -> case words $ replace ',' ' ' opts of
+ [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
+ xs -> liftM catMaybes (mapM parseOption xs)
+ Nothing -> return []
+ hm <- if Flag_HideModule (moduleString mdl) `elem` flags
+ then return $ OptHide : opts
+ else return opts
+ if Flag_ShowExtensions (moduleString mdl) `elem` flags
+ then return $ OptShowExtensions : hm
+ else return hm
+
+
+parseOption :: String -> ErrMsgM (Maybe DocOption)
+parseOption "hide" = return (Just OptHide)
+parseOption "prune" = return (Just OptPrune)
+parseOption "ignore-exports" = return (Just OptIgnoreExports)
+parseOption "not-home" = return (Just OptNotHome)
+parseOption "show-extensions" = return (Just OptShowExtensions)
+parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
+
+
+--------------------------------------------------------------------------------
+-- Maps
+--------------------------------------------------------------------------------
+
+
+type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
+
+-- | Create 'Maps' by looping through the declarations. For each declaration,
+-- find its names, its subordinates, and its doc strings. Process doc strings
+-- into 'Doc's.
+mkMaps :: DynFlags
+ -> GlobalRdrEnv
+ -> [Name]
+ -> [(LHsDecl Name, [HsDocString])]
+ -> Maps
+mkMaps dflags gre instances decls =
+ let (a, b, c, d) = unzip4 $ map mappings decls
+ in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
+ where
+ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
+ f = M.fromListWith (<>) . concat
+
+ f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)
+ f' = M.fromListWith docAppend . concat
+
+ mappings :: (LHsDecl Name, [HsDocString])
+ -> ( [(Name, Doc Name)]
+ , [(Name, Map Int (Doc Name))]
+ , [(Name, [Name])]
+ , [(Name, [LHsDecl Name])]
+ )
+ mappings (ldecl, docStrs) =
+ let L l decl = ldecl
+ declDoc :: [HsDocString] -> Map Int HsDocString
+ -> (Maybe (Doc Name), Map Int (Doc Name))
+ declDoc strs m =
+ let doc' = processDocStrings dflags gre strs
+ m' = M.map (processDocStringParas dflags gre) m
+ in (doc', m')
+ (doc, args) = declDoc docStrs (typeDocs decl)
+ subs :: [(Name, [HsDocString], Map Int HsDocString)]
+ subs = subordinates instanceMap decl
+ (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
+ ns = names l decl
+ subNs = [ n | (n, _, _) <- subs ]
+ dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
+ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
+ sm = [ (n, subNs) | n <- ns ]
+ cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
+ in seqList ns `seq`
+ seqList subNs `seq`
+ doc `seq`
+ seqList subDocs `seq`
+ seqList subArgs `seq`
+ (dm, am, sm, cm)
+
+ instanceMap :: Map SrcSpan Name
+ instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
+
+ names :: SrcSpan -> HsDecl Name -> [Name]
+ names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
+ where loc = case d of
+ TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
+ _ -> getInstLoc d
+ names _ decl = getMainDeclBinder decl
+
+-- Note [2]:
+------------
+-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
+-- That should work for normal user-written instances (from looking at GHC
+-- sources). We can assume that commented instances are user-written.
+-- This lets us relate Names (from ClsInsts) to comments (associated
+-- with InstDecls).
+
+
+--------------------------------------------------------------------------------
+-- Declarations
+--------------------------------------------------------------------------------
+
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
+subordinates instMap decl = case decl of
+ InstD (ClsInstD d) -> do
+ DataFamInstDecl { dfid_tycon = L l _
+ , dfid_defn = def } <- unLoc <$> cid_datafam_insts d
+ [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def
+
+ InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
+ TyClD d | isClassDecl d -> classSubs d
+ | isDataDecl d -> dataSubs (tcdDataDefn d)
+ _ -> []
+ where
+ classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
+ , name <- getMainDeclBinder d, not (isValD d)
+ ]
+ dataSubs dd = constrs ++ fields
+ where
+ cons = map unL $ (dd_cons dd)
+ constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
+ | c <- cons ]
+ fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
+ | RecCon flds <- map con_details cons
+ , ConDeclField n _ doc <- flds ]
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsDecl Name -> Map Int HsDocString
+typeDocs d =
+ let docs = go 0 in
+ case d of
+ SigD (TypeSig _ ty) -> docs (unLoc ty)
+ SigD (PatSynSig _ arg_tys ty req prov) ->
+ let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]
+ in F.foldMap (docs . unLoc) allTys
+ ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
+ TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
+ _ -> M.empty
+ where
+ go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
+ go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
+ go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
+ go n (HsDocTy _ (L _ doc)) = M.singleton n doc
+ go _ _ = M.empty
+
+
+-- | All the sub declarations of a class (that we handle), ordered by
+-- source location, with documentation attached if it exists.
+classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+ where
+ decls = docs ++ defs ++ sigs ++ ats
+ docs = mkDecls tcdDocs DocD class_
+#if MIN_VERSION_ghc(7,8,3)
+ defs = mkDecls (bagToList . tcdMeths) ValD class_
+#else
+ defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_
+#endif
+ sigs = mkDecls tcdSigs SigD class_
+ ats = mkDecls tcdATs (TyClD . FamDecl) class_
+
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Extract a map of fixity declarations only
+mkFixMap :: HsGroup Name -> FixMap
+mkFixMap group_ = M.fromList [ (n,f)
+ | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
+
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup Name -> [LHsDecl Name]
+ungroup group_ =
+ mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
+ mkDecls hs_derivds DerivD group_ ++
+ mkDecls hs_defds DefD group_ ++
+ mkDecls hs_fords ForD group_ ++
+ mkDecls hs_docs DocD group_ ++
+ mkDecls hs_instds InstD group_ ++
+ mkDecls (typesigs . hs_valds) SigD group_ ++
+#if MIN_VERSION_ghc(7,8,3)
+ mkDecls (valbinds . hs_valds) ValD group_
+#else
+ mkDecls (map snd . valbinds . hs_valds) ValD group_
+#endif
+ where
+ typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
+ typesigs _ = error "expected ValBindsOut"
+
+ valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
+ valbinds _ = error "expected ValBindsOut"
+
+
+-- | Take a field of declarations from a data structure and create HsDecls
+-- using the given constructor
+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
+
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortBy (comparing getLoc)
+
+
+--------------------------------------------------------------------------------
+-- Filtering of declarations
+--
+-- We filter out declarations that we don't intend to handle later.
+--------------------------------------------------------------------------------
+
+
+-- | Filter out declarations that we don't handle in Haddock
+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterDecls = filter (isHandled . unL . fst)
+ where
+ isHandled (ForD (ForeignImport {})) = True
+ isHandled (TyClD {}) = True
+ isHandled (InstD {}) = True
+ isHandled (SigD d) = isVanillaLSig (reL d)
+ isHandled (ValD _) = True
+ -- we keep doc declarations to be able to get at named docs
+ isHandled (DocD _) = True
+ isHandled _ = False
+
+
+-- | Go through all class declarations and filter their sub-declarations
+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
+ | x@(L loc d, doc) <- decls ]
+ where
+ filterClass (TyClD c) =
+ TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }
+ filterClass _ = error "expected TyClD"
+
+
+--------------------------------------------------------------------------------
+-- Collect docs
+--
+-- To be able to attach the right Haddock comment to the right declaration,
+-- we sort the declarations by their SrcLoc and "collect" the docs for each
+-- declaration.
+--------------------------------------------------------------------------------
+
+
+-- | Collect docs and attach them to the right declarations.
+collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
+collectDocs = go Nothing []
+ where
+ go Nothing _ [] = []
+ go (Just prev) docs [] = finished prev docs []
+ go prev docs (L _ (DocD (DocCommentNext str)) : ds)
+ | Nothing <- prev = go Nothing (str:docs) ds
+ | Just decl <- prev = finished decl docs (go Nothing [str] ds)
+ go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
+ go Nothing docs (d:ds) = go (Just d) docs ds
+ go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
+
+ finished decl docs rest = (decl, reverse docs) : rest
+
+
+-- | Build the list of items that will become the documentation, from the
+-- export list. At this point, the list of ExportItems is in terms of
+-- original names.
+--
+-- We create the export items even if the module is hidden, since they
+-- might be useful when creating the export items for other modules.
+mkExportItems
+ :: IfaceMap
+ -> Module -- this module
+ -> WarningMap
+ -> GlobalRdrEnv
+ -> [Name] -- exported names (orig)
+ -> [LHsDecl Name]
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- splice locations
+ -> Maybe [IE Name]
+ -> InstIfaceMap
+ -> DynFlags
+ -> ErrMsgGhc [ExportItem Name]
+mkExportItems
+ modMap thisMod warnings gre exportedNames decls
+ maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
+ case optExports of
+ Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
+ Just exports -> liftM concat $ mapM lookupExport exports
+ where
+ lookupExport (IEVar x) = declWith x
+ lookupExport (IEThingAbs t) = declWith t
+ lookupExport (IEThingAll t) = declWith t
+ lookupExport (IEThingWith t _) = declWith t
+ lookupExport (IEModuleContents m) =
+ moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
+ lookupExport (IEGroup lev docStr) = return $
+ return . ExportGroup lev "" $ processDocString dflags gre docStr
+
+ lookupExport (IEDoc docStr) = return $
+ return . ExportDoc $ processDocStringParas dflags gre docStr
+
+ lookupExport (IEDocNamed str) = liftErrMsg $
+ findNamedDoc str [ unL d | d <- decls ] >>= return . \case
+ Nothing -> []
+ Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
+
+ declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
+ declWith t =
+ case findDecl t of
+ ([L l (ValD _)], (doc, _)) -> do
+ -- Top-level binding without type signature
+ export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
+ return [export]
+ (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
+ let declNames = getMainDeclBinder (unL decl)
+ in case () of
+ _
+ -- temp hack: we filter out separately exported ATs, since we haven't decided how
+ -- to handle them yet. We should really give an warning message also, and filter the
+ -- name out in mkVisibleNames...
+ | t `elem` declATs (unL decl) -> return []
+
+ -- We should not show a subordinate by itself if any of its
+ -- parents is also exported. See note [1].
+ | t `notElem` declNames,
+ Just p <- find isExported (parents t $ unL decl) ->
+ do liftErrMsg $ tell [
+ "Warning: " ++ moduleString thisMod ++ ": " ++
+ pretty dflags (nameOccName t) ++ " is exported separately but " ++
+ "will be documented under " ++ pretty dflags (nameOccName p) ++
+ ". Consider exporting it together with its parent(s)" ++
+ " for code clarity." ]
+ return []
+
+ -- normal case
+ | otherwise -> case decl of
+ -- A single signature might refer to many names, but we
+ -- create an export item for a single name only. So we
+ -- modify the signature to contain only that single name.
+ L loc (SigD sig) ->
+ -- fromJust is safe since we already checked in guards
+ -- that 't' is a name declared in this declaration.
+ let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
+ in return [ mkExportDecl t newDecl docs_ ]
+
+ L loc (TyClD cl@ClassDecl{}) -> do
+ mdef <- liftGhcToErrMsgGhc $ minimalDef t
+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ return [ mkExportDecl t
+ (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
+
+ _ -> return [ mkExportDecl t decl docs_ ]
+
+ -- Declaration from another package
+ ([], _) -> do
+ mayDecl <- hiDecl dflags t
+ case mayDecl of
+ Nothing -> return [ ExportNoDecl t [] ]
+ Just decl ->
+ -- We try to get the subs and docs
+ -- from the installed .haddock file for that package.
+ case M.lookup (nameModule t) instIfaceMap of
+ Nothing -> do
+ liftErrMsg $ tell
+ ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
+ let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
+ return [ mkExportDecl t decl (noDocForDecl, subs_) ]
+ Just iface ->
+ return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
+
+ _ -> return []
+
+
+ mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
+ mkExportDecl name decl (doc, subs) = decl'
+ where
+ decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
+ mdl = nameModule name
+ subs' = filter (isExported . fst) subs
+ sub_names = map fst subs'
+ fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
+
+
+ isExported = (`elem` exportedNames)
+
+
+ findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
+ findDecl n
+ | m == thisMod, Just ds <- M.lookup n declMap =
+ (ds, lookupDocs n warnings docMap argMap subMap)
+ | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
+ (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
+ | otherwise = ([], (noDocForDecl, []))
+ where
+ m = nameModule n
+
+
+hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
+hiDecl dflags t = do
+ mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
+ case mayTyThing of
+ Nothing -> do
+ liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
+ return Nothing
+ Just x -> return (Just (tyThingToLHsDecl x))
+
+
+hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
+hiValExportItem dflags name doc splice fixity = do
+ mayDecl <- hiDecl dflags name
+ case mayDecl of
+ Nothing -> return (ExportNoDecl name [])
+ Just decl -> return (ExportDecl decl doc [] [] fixities splice)
+ where
+ fixities = case fixity of
+ Just f -> [(name, f)]
+ Nothing -> []
+
+
+-- | Lookup docs for a declaration from maps.
+lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
+lookupDocs n warnings docMap argMap subMap =
+ let lookupArgDoc x = M.findWithDefault M.empty x argMap in
+ let doc = (lookupDoc n, lookupArgDoc n) in
+ let subs = M.findWithDefault [] n subMap in
+ let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
+ (doc, subDocs)
+ where
+ lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
+
+
+-- | Return all export items produced by an exported module. That is, we're
+-- interested in the exports produced by \"module B\" in such a scenario:
+--
+-- > module A (module B) where
+-- > import B (...) hiding (...)
+--
+-- There are three different cases to consider:
+--
+-- 1) B is hidden, in which case we return all its exports that are in scope in A.
+-- 2) B is visible, but not all its exports are in scope in A, in which case we
+-- only return those that are.
+-- 3) B is visible and all its exports are in scope, in which case we return
+-- a single 'ExportModule' item.
+moduleExports :: Module -- ^ Module A
+ -> ModuleName -- ^ The real name of B, the exported module
+ -> DynFlags -- ^ The flags used when typechecking A
+ -> WarningMap
+ -> GlobalRdrEnv -- ^ The renaming environment used for A
+ -> [Name] -- ^ All the exports of A
+ -> [LHsDecl Name] -- ^ All the declarations in A
+ -> IfaceMap -- ^ Already created interfaces
+ -> InstIfaceMap -- ^ Interfaces in other packages
+ -> Maps
+ -> FixMap
+ -> [SrcSpan] -- ^ Locations of all TH splices
+ -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
+moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
+ | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
+ | otherwise =
+ case M.lookup m ifaceMap of
+ Just iface
+ | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
+ | otherwise -> return [ ExportModule m ]
+
+ Nothing -> -- We have to try to find it in the installed interfaces
+ -- (external packages).
+ case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
+ Just iface -> return [ ExportModule (instMod iface) ]
+ Nothing -> do
+ liftErrMsg $
+ tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
+ "documentation for exported module: " ++ pretty dflags expMod]
+ return []
+ where
+ m = mkModule packageId expMod
+ packageId = modulePackageId thisMod
+
+
+-- Note [1]:
+------------
+-- It is unnecessary to document a subordinate by itself at the top level if
+-- any of its parents is also documented. Furthermore, if the subordinate is a
+-- record field or a class method, documenting it under its parent
+-- indicates its special status.
+--
+-- A user might expect that it should show up separately, so we issue a
+-- warning. It's a fine opportunity to also tell the user she might want to
+-- export the subordinate through the parent export item for clarity.
+--
+-- The code removes top-level subordinates also when the parent is exported
+-- through a 'module' export. I think that is fine.
+--
+-- (For more information, see Trac #69)
+
+
+fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
+ -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
+fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
+ liftM catMaybes $ mapM mkExportItem (expandSig decls)
+ where
+ -- A type signature can have multiple names, like:
+ -- foo, bar :: Types..
+ --
+ -- We go through the list of declarations and expand type signatures, so
+ -- that every type signature has exactly one name!
+ expandSig :: [LHsDecl name] -> [LHsDecl name]
+ expandSig = foldr f []
+ where
+ f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
+ f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
+ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
+ f x xs = x : xs
+
+ mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
+ mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
+ return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
+ mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
+ return . Just . ExportDoc $ processDocStringParas dflags gre docStr
+ mkExportItem (L l (ValD d))
+ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
+ -- Top-level binding without type signature.
+ let (doc, _) = lookupDocs name warnings docMap argMap subMap in
+ fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
+ | otherwise = return Nothing
+ mkExportItem decl@(L l (InstD d))
+ | Just name <- M.lookup (getInstLoc d) instMap =
+ let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
+ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
+ mdef <- liftGhcToErrMsgGhc $ minimalDef name
+ let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
+ expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
+ mkExportItem decl@(L l d)
+ | name:_ <- getMainDeclBinder d = expDecl decl l name
+ | otherwise = return Nothing
+
+ fixities name subs = [ (n,f) | n <- name : map fst subs
+ , Just f <- [M.lookup n fixMap] ]
+
+ expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
+ where (doc, subs) = lookupDocs name warnings docMap argMap subMap
+
+
+-- | Sometimes the declaration we want to export is not the "main" declaration:
+-- it might be an individual record selector or a class method. In these
+-- cases we have to extract the required declaration (and somehow cobble
+-- together a type signature for it...).
+extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
+extractDecl name mdl decl
+ | name `elem` getMainDeclBinder (unLoc decl) = decl
+ | otherwise =
+ case unLoc decl of
+ TyClD d@ClassDecl {} ->
+ let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
+ isVanillaLSig sig ] -- TODO: document fixity
+ in case matches of
+ [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
+ L pos sig = extractClassDecl n tyvar_names s0
+ in L pos (SigD sig)
+ _ -> error "internal: extractDecl (ClassDecl)"
+ TyClD d@DataDecl {} ->
+ let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
+ in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
+ InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
+ , dfid_pats = HsWB { hswb_cts = tys }
+ , dfid_defn = defn }) ->
+ SigD <$> extractRecSel name mdl n tys (dd_cons defn)
+ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
+ let matches = [ d | L _ d <- insts
+ , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
+ , ConDeclField { cd_fld_name = L _ n } <- rec
+ , n == name
+ ]
+ in case matches of
+ [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
+ _ -> error "internal: extractDecl (ClsInstD)"
+ _ -> error "internal: extractDecl"
+ where
+ getTyVars = hsLTyVarLocNames . tyClDeclTyVars
+
+
+toTypeNoLoc :: Located Name -> LHsType Name
+toTypeNoLoc = noLoc . HsTyVar . unLoc
+
+
+extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
+extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
+ L _ (HsForAllTy expl tvs (L _ preds) ty) ->
+ L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))
+ where
+ lctxt = noLoc . ctxt
+ ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
+extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
+
+
+extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
+ -> LSig Name
+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+
+extractRecSel nm mdl t tvs (L _ con : rest) =
+ case con_details con of
+ RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
+ _ -> extractRecSel nm mdl t tvs rest
+ where
+ matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
+ data_ty
+ | ResTyGADT ty <- con_res con = ty
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
+
+
+-- | Keep export items with docs.
+pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
+pruneExportItems = filter hasDoc
+ where
+ hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
+ hasDoc _ = True
+
+
+mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
+mkVisibleNames (_, _, _, _, instMap) exports opts
+ | OptHide `elem` opts = []
+ | otherwise = let ns = concatMap exportName exports
+ in seqList ns `seq` ns
+ where
+ exportName e@ExportDecl {} = name ++ subs
+ where subs = map fst (expItemSubDocs e)
+ name = case unLoc $ expItemDecl e of
+ InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
+ decl -> getMainDeclBinder decl
+ exportName ExportNoDecl {} = [] -- we don't count these as visible, since
+ -- we don't want links to go to them.
+ exportName _ = []
+
+seqList :: [a] -> ()
+seqList [] = ()
+seqList (x : xs) = x `seq` seqList xs
+
+-- | Find a stand-alone documentation comment by its name.
+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
+findNamedDoc name = search
+ where
+ search [] = do
+ tell ["Cannot find documentation for: $" ++ name]
+ return Nothing
+ search (DocD (DocCommentNamed name' doc) : rest)
+ | name == name' = return (Just doc)
+ | otherwise = search rest
+ search (_other_decl : rest) = search rest
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
new file mode 100644
index 00000000..f1021436
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -0,0 +1,146 @@
+{-# OPTIONS_GHC -Wwarn #-}
+{-# LANGUAGE BangPatterns #-}
+ -----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.LexParseRn
+-- Copyright : (c) Isaac Dupree 2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.LexParseRn
+ ( processDocString
+ , processDocStringParas
+ , processDocStrings
+ , processModuleHeader
+ ) where
+
+import Control.Applicative
+import Data.IntSet (toList)
+import Data.List
+import Documentation.Haddock.Doc (docConcat)
+import DynFlags (ExtensionFlag(..), languageExtensions)
+import FastString
+import GHC
+import Haddock.Interface.ParseModuleHeader
+import Haddock.Parser
+import Haddock.Types
+import Name
+import Outputable (showPpr)
+import RdrName
+
+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
+processDocStrings dflags gre strs =
+ case docConcat $ map (processDocStringParas dflags gre) strs of
+ DocEmpty -> Nothing
+ x -> Just x
+
+
+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocStringParas = process parseParas
+
+
+processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
+processDocString = process parseString
+
+process :: (DynFlags -> String -> Doc RdrName)
+ -> DynFlags
+ -> GlobalRdrEnv
+ -> HsDocString
+ -> Doc Name
+process parse dflags gre (HsDocString fs) =
+ rename dflags gre $ parse dflags (unpackFS fs)
+
+
+processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
+ -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
+processModuleHeader dflags gre safety mayStr = do
+ (hmi, doc) <-
+ case mayStr of
+ Nothing -> return failure
+ Just (L _ (HsDocString fs)) -> do
+ let str = unpackFS fs
+ (hmi, doc) = parseModuleHeader dflags str
+ !descr = rename dflags gre <$> hmi_description hmi
+ hmi' = hmi { hmi_description = descr }
+ doc' = rename dflags gre doc
+ return (hmi', Just doc')
+
+ let flags :: [ExtensionFlag]
+ -- We remove the flags implied by the language setting and we display the language instead
+ flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
+ return (hmi { hmi_safety = Just $ showPpr dflags safety
+ , hmi_language = language dflags
+ , hmi_extensions = flags
+ } , doc)
+ where
+ failure = (emptyHaddockModInfo, Nothing)
+
+
+rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
+rename dflags gre = rn
+ where
+ rn d = case d of
+ DocAppend a b -> DocAppend (rn a) (rn b)
+ DocParagraph doc -> DocParagraph (rn doc)
+ DocIdentifier x -> do
+ let choices = dataTcOccs' x
+ let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+ case names of
+ [] ->
+ case choices of
+ [] -> DocMonospaced (DocString (showPpr dflags x))
+ [a] -> outOfScope dflags a
+ a:b:_ | isRdrTc a -> outOfScope dflags a
+ | otherwise -> outOfScope dflags b
+ [a] -> DocIdentifier a
+ a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
+ -- If an id can refer to multiple things, we give precedence to type
+ -- constructors.
+
+ DocWarning doc -> DocWarning (rn doc)
+ DocEmphasis doc -> DocEmphasis (rn doc)
+ DocBold doc -> DocBold (rn doc)
+ DocMonospaced doc -> DocMonospaced (rn doc)
+ DocUnorderedList docs -> DocUnorderedList (map rn docs)
+ DocOrderedList docs -> DocOrderedList (map rn docs)
+ DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
+ DocCodeBlock doc -> DocCodeBlock (rn doc)
+ DocIdentifierUnchecked x -> DocIdentifierUnchecked x
+ DocModule str -> DocModule str
+ DocHyperlink l -> DocHyperlink l
+ DocPic str -> DocPic str
+ DocAName str -> DocAName str
+ DocProperty p -> DocProperty p
+ DocExamples e -> DocExamples e
+ DocEmpty -> DocEmpty
+ DocString str -> DocString str
+ DocHeader (Header l t) -> DocHeader $ Header l (rn t)
+
+dataTcOccs' :: RdrName -> [RdrName]
+-- If the input is a data constructor, return both it and a type
+-- constructor. This is useful when we aren't sure which we are
+-- looking at.
+--
+-- We use this definition instead of the GHC's to provide proper linking to
+-- functions accross modules. See ticket #253 on Haddock Trac.
+dataTcOccs' rdr_name
+ | isDataOcc occ = [rdr_name, rdr_name_tc]
+ | otherwise = [rdr_name]
+ where
+ occ = rdrNameOcc rdr_name
+ rdr_name_tc = setRdrNameSpace rdr_name tcName
+
+
+outOfScope :: DynFlags -> RdrName -> Doc a
+outOfScope dflags x =
+ case x of
+ Unqual occ -> monospaced occ
+ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
+ Orig _ occ -> monospaced occ
+ Exact name -> monospaced name -- Shouldn't happen since x is out of scope
+ where
+ monospaced a = DocMonospaced (DocString (showPpr dflags a))
diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
new file mode 100644
index 00000000..6848dc63
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs
@@ -0,0 +1,150 @@
+{-# OPTIONS_GHC -Wwarn #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.ParseModuleHeader
+-- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
+
+import Control.Applicative ((<$>))
+import Control.Monad (mplus)
+import Data.Char
+import DynFlags
+import Haddock.Parser
+import Haddock.Types
+import RdrName
+
+-- -----------------------------------------------------------------------------
+-- Parsing module headers
+
+-- NB. The headers must be given in the order Module, Description,
+-- Copyright, License, Maintainer, Stability, Portability, except that
+-- any or all may be omitted.
+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)
+parseModuleHeader dflags str0 =
+ let
+ getKey :: String -> String -> (Maybe String,String)
+ getKey key str = case parseKey key str of
+ Nothing -> (Nothing,str)
+ Just (value,rest) -> (Just value,rest)
+
+ (_moduleOpt,str1) = getKey "Module" str0
+ (descriptionOpt,str2) = getKey "Description" str1
+ (copyrightOpt,str3) = getKey "Copyright" str2
+ (licenseOpt,str4) = getKey "License" str3
+ (licenceOpt,str5) = getKey "Licence" str4
+ (maintainerOpt,str6) = getKey "Maintainer" str5
+ (stabilityOpt,str7) = getKey "Stability" str6
+ (portabilityOpt,str8) = getKey "Portability" str7
+
+ in (HaddockModInfo {
+ hmi_description = parseString dflags <$> descriptionOpt,
+ hmi_copyright = copyrightOpt,
+ hmi_license = licenseOpt `mplus` licenceOpt,
+ hmi_maintainer = maintainerOpt,
+ hmi_stability = stabilityOpt,
+ hmi_portability = portabilityOpt,
+ hmi_safety = Nothing,
+ hmi_language = Nothing, -- set in LexParseRn
+ hmi_extensions = [] -- also set in LexParseRn
+ }, parseParas dflags str8)
+
+-- | This function is how we read keys.
+--
+-- all fields in the header are optional and have the form
+--
+-- [spaces1][field name][spaces] ":"
+-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
+-- where each [spaces2] should have [spaces1] as a prefix.
+--
+-- Thus for the key "Description",
+--
+-- > Description : this is a
+-- > rather long
+-- >
+-- > description
+-- >
+-- > The module comment starts here
+--
+-- the value will be "this is a .. description" and the rest will begin
+-- at "The module comment".
+parseKey :: String -> String -> Maybe (String,String)
+parseKey key toParse0 =
+ do
+ let
+ (spaces0,toParse1) = extractLeadingSpaces toParse0
+
+ indentation = spaces0
+ afterKey0 <- extractPrefix key toParse1
+ let
+ afterKey1 = extractLeadingSpaces afterKey0
+ afterColon0 <- case snd afterKey1 of
+ ':':afterColon -> return afterColon
+ _ -> Nothing
+ let
+ (_,afterColon1) = extractLeadingSpaces afterColon0
+
+ return (scanKey True indentation afterColon1)
+ where
+ scanKey :: Bool -> String -> String -> (String,String)
+ scanKey _ _ [] = ([],[])
+ scanKey isFirst indentation str =
+ let
+ (nextLine,rest1) = extractNextLine str
+
+ accept = isFirst || sufficientIndentation || allSpaces
+
+ sufficientIndentation = case extractPrefix indentation nextLine of
+ Just (c:_) | isSpace c -> True
+ _ -> False
+
+ allSpaces = case extractLeadingSpaces nextLine of
+ (_,[]) -> True
+ _ -> False
+ in
+ if accept
+ then
+ let
+ (scanned1,rest2) = scanKey False indentation rest1
+
+ scanned2 = case scanned1 of
+ "" -> if allSpaces then "" else nextLine
+ _ -> nextLine ++ "\n" ++ scanned1
+ in
+ (scanned2,rest2)
+ else
+ ([],str)
+
+ extractLeadingSpaces :: String -> (String,String)
+ extractLeadingSpaces [] = ([],[])
+ extractLeadingSpaces (s@(c:cs))
+ | isSpace c =
+ let
+ (spaces1,cs1) = extractLeadingSpaces cs
+ in
+ (c:spaces1,cs1)
+ | otherwise = ([],s)
+
+ extractNextLine :: String -> (String,String)
+ extractNextLine [] = ([],[])
+ extractNextLine (c:cs)
+ | c == '\n' =
+ ([],cs)
+ | otherwise =
+ let
+ (line,rest) = extractNextLine cs
+ in
+ (c:line,rest)
+
+ -- comparison is case-insensitive.
+ extractPrefix :: String -> String -> Maybe String
+ extractPrefix [] s = Just s
+ extractPrefix _ [] = Nothing
+ extractPrefix (c1:cs1) (c2:cs2)
+ | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
+ | otherwise = Nothing
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
new file mode 100644
index 00000000..748e0210
--- /dev/null
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -0,0 +1,506 @@
+----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Interface.Rename
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Interface.Rename (renameInterface) where
+
+
+import Data.Traversable (traverse)
+
+import Haddock.GhcUtils
+import Haddock.Types
+
+import Bag (emptyBag)
+import GHC hiding (NoLink)
+import Name
+
+import Control.Applicative
+import Control.Monad hiding (mapM)
+import Data.List
+import qualified Data.Map as Map hiding ( Map )
+import Data.Traversable (mapM)
+import Prelude hiding (mapM)
+
+
+renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
+renameInterface dflags renamingEnv warnings iface =
+
+ -- first create the local env, where every name exported by this module
+ -- is mapped to itself, and everything else comes from the global renaming
+ -- env
+ let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
+ where fn env name = Map.insert name (ifaceMod iface) env
+
+ -- rename names in the exported declarations to point to things that
+ -- are closer to, or maybe even exported by, the current module.
+ (renamedExportItems, missingNames1)
+ = runRnFM localEnv (renameExportItems (ifaceExportItems iface))
+
+ (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))
+
+ (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
+
+ (finalModuleDoc, missingNames4)
+ = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
+
+ -- combine the missing names and filter out the built-ins, which would
+ -- otherwise allways be missing.
+ missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
+ (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)
+
+ -- filter out certain built in type constructors using their string
+ -- representation. TODO: use the Name constants from the GHC API.
+-- strings = filter (`notElem` ["()", "[]", "(->)"])
+-- (map pretty missingNames)
+ strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
+
+ in do
+ -- report things that we couldn't link to. Only do this for non-hidden
+ -- modules.
+ unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
+ tell ["Warning: " ++ moduleString (ifaceMod iface) ++
+ ": could not find link destinations for:\n"++
+ unwords (" " : strings) ]
+
+ return $ iface { ifaceRnDoc = finalModuleDoc,
+ ifaceRnDocMap = rnDocMap,
+ ifaceRnArgMap = rnArgMap,
+ ifaceRnExportItems = renamedExportItems }
+
+
+--------------------------------------------------------------------------------
+-- Monad for renaming
+--
+-- The monad does two things for us: it passes around the environment for
+-- renaming, and it returns a list of names which couldn't be found in
+-- the environment.
+--------------------------------------------------------------------------------
+
+
+newtype RnM a =
+ RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
+ -> (a,[Name])
+ }
+
+instance Monad RnM where
+ (>>=) = thenRn
+ return = returnRn
+
+instance Functor RnM where
+ fmap f x = do a <- x; return (f a)
+
+instance Applicative RnM where
+ pure = return
+ (<*>) = ap
+
+returnRn :: a -> RnM a
+returnRn a = RnM (const (a,[]))
+thenRn :: RnM a -> (a -> RnM b) -> RnM b
+m `thenRn` k = RnM (\lkp -> case unRn m lkp of
+ (a,out1) -> case unRn (k a) lkp of
+ (b,out2) -> (b,out1++out2))
+
+getLookupRn :: RnM (Name -> (Bool, DocName))
+getLookupRn = RnM (\lkp -> (lkp,[]))
+
+outRn :: Name -> RnM ()
+outRn name = RnM (const ((),[name]))
+
+lookupRn :: Name -> RnM DocName
+lookupRn name = do
+ lkp <- getLookupRn
+ case lkp name of
+ (False,maps_to) -> do outRn name; return maps_to
+ (True, maps_to) -> return maps_to
+
+
+runRnFM :: LinkEnv -> RnM a -> (a,[Name])
+runRnFM env rn = unRn rn lkp
+ where
+ lkp n = case Map.lookup n env of
+ Nothing -> (False, Undocumented n)
+ Just mdl -> (True, Documented n mdl)
+
+
+--------------------------------------------------------------------------------
+-- Renaming
+--------------------------------------------------------------------------------
+
+
+rename :: Name -> RnM DocName
+rename = lookupRn
+
+
+renameL :: Located Name -> RnM (Located DocName)
+renameL = mapM rename
+
+
+renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
+renameExportItems = mapM renameExportItem
+
+
+renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
+renameDocForDecl (doc, fnArgsDoc) =
+ (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
+
+
+renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
+renameDocumentation (Documentation mDoc mWarning) =
+ Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
+
+
+renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
+renameLDocHsSyn = return
+
+
+renameDoc :: Doc Name -> RnM (Doc DocName)
+renameDoc = traverse rename
+
+
+renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
+renameFnArgsDoc = mapM renameDoc
+
+
+renameLType :: LHsType Name -> RnM (LHsType DocName)
+renameLType = mapM renameType
+
+renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
+renameLKind = renameLType
+
+renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
+renameMaybeLKind = traverse renameLKind
+
+renameType :: HsType Name -> RnM (HsType DocName)
+renameType t = case t of
+ HsForAllTy expl tyvars lcontext ltype -> do
+ tyvars' <- renameLTyVarBndrs tyvars
+ lcontext' <- renameLContext lcontext
+ ltype' <- renameLType ltype
+ return (HsForAllTy expl tyvars' lcontext' ltype')
+
+ HsTyVar n -> return . HsTyVar =<< rename n
+ HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+
+ HsAppTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsAppTy a' b')
+
+ HsFunTy a b -> do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsFunTy a' b')
+
+ HsListTy ty -> return . HsListTy =<< renameLType ty
+ HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
+ HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
+ HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
+
+ HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
+
+ HsOpTy a (w, L loc op) b -> do
+ op' <- rename op
+ a' <- renameLType a
+ b' <- renameLType b
+ return (HsOpTy a' (w, L loc op') b')
+
+ HsParTy ty -> return . HsParTy =<< renameLType ty
+
+ HsKindSig ty k -> do
+ ty' <- renameLType ty
+ k' <- renameLKind k
+ return (HsKindSig ty' k')
+
+ HsDocTy ty doc -> do
+ ty' <- renameLType ty
+ doc' <- renameLDocHsSyn doc
+ return (HsDocTy ty' doc')
+
+ HsTyLit x -> return (HsTyLit x)
+
+ HsWrapTy a b -> HsWrapTy a <$> renameType b
+ HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
+ HsCoreTy a -> pure (HsCoreTy a)
+ HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
+ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
+ HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a
+ HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
+
+renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)
+renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c
+
+renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
+renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
+ = do { tvs' <- mapM renameLTyVarBndr tvs
+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
+ -- This is rather bogus, but I'm not sure what else to do
+
+renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
+renameLTyVarBndr (L loc (UserTyVar n))
+ = do { n' <- rename n
+ ; return (L loc (UserTyVar n')) }
+renameLTyVarBndr (L loc (KindedTyVar n kind))
+ = do { n' <- rename n
+ ; kind' <- renameLKind kind
+ ; return (L loc (KindedTyVar n' kind')) }
+
+renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
+renameLContext (L loc context) = do
+ context' <- mapM renameLType context
+ return (L loc context')
+
+
+renameInstHead :: InstHead Name -> RnM (InstHead DocName)
+renameInstHead (className, k, types, rest) = do
+ className' <- rename className
+ k' <- mapM renameType k
+ types' <- mapM renameType types
+ rest' <- case rest of
+ ClassInst cs -> ClassInst <$> mapM renameType cs
+ TypeInst ts -> TypeInst <$> traverse renameType ts
+ DataInst dd -> DataInst <$> renameTyClD dd
+ return (className', k', types', rest')
+
+
+renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
+renameLDecl (L loc d) = return . L loc =<< renameDecl d
+
+
+renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
+renameDecl decl = case decl of
+ TyClD d -> do
+ d' <- renameTyClD d
+ return (TyClD d')
+ SigD s -> do
+ s' <- renameSig s
+ return (SigD s')
+ ForD d -> do
+ d' <- renameForD d
+ return (ForD d')
+ InstD d -> do
+ d' <- renameInstD d
+ return (InstD d')
+ _ -> error "renameDecl"
+
+renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
+renameLThing fn (L loc x) = return . L loc =<< fn x
+
+renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
+renameTyClD d = case d of
+ ForeignType lname b -> do
+ lname' <- renameL lname
+ return (ForeignType lname' b)
+
+-- TyFamily flav lname ltyvars kind tckind -> do
+ FamDecl { tcdFam = decl } -> do
+ decl' <- renameFamilyDecl decl
+ return (FamDecl { tcdFam = decl' })
+
+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do
+ lname' <- renameL lname
+ tyvars' <- renameLTyVarBndrs tyvars
+ rhs' <- renameLType rhs
+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })
+
+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do
+ lname' <- renameL lname
+ tyvars' <- renameLTyVarBndrs tyvars
+ defn' <- renameDataDefn defn
+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })
+
+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
+ , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
+ lcontext' <- renameLContext lcontext
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ lfundeps' <- mapM renameLFunDep lfundeps
+ lsigs' <- mapM renameLSig lsigs
+ ats' <- mapM (renameLThing renameFamilyDecl) ats
+ at_defs' <- mapM (mapM renameTyFamInstD) at_defs
+ -- we don't need the default methods or the already collected doc entities
+ return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
+ , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
+
+ where
+ renameLFunDep (L loc (xs, ys)) = do
+ xs' <- mapM rename xs
+ ys' <- mapM rename ys
+ return (L loc (xs', ys'))
+
+ renameLSig (L loc sig) = return . L loc =<< renameSig sig
+
+renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
+renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
+ , fdTyVars = ltyvars, fdKindSig = tckind }) = do
+ info' <- renameFamilyInfo info
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ tckind' <- renameMaybeLKind tckind
+ return (FamilyDecl { fdInfo = info', fdLName = lname'
+ , fdTyVars = ltyvars', fdKindSig = tckind' })
+
+renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
+renameFamilyInfo DataFamily = return DataFamily
+renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
+renameFamilyInfo (ClosedTypeFamily eqns)
+ = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
+ ; return $ ClosedTypeFamily eqns' }
+
+renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
+renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
+ , dd_kindSig = k, dd_cons = cons }) = do
+ lcontext' <- renameLContext lcontext
+ k' <- renameMaybeLKind k
+ cons' <- mapM (mapM renameCon) cons
+ -- I don't think we need the derivings, so we return Nothing
+ return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
+ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
+
+renameCon :: ConDecl Name -> RnM (ConDecl DocName)
+renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
+ , con_cxt = lcontext, con_details = details
+ , con_res = restype, con_doc = mbldoc }) = do
+ lname' <- renameL lname
+ ltyvars' <- renameLTyVarBndrs ltyvars
+ lcontext' <- renameLContext lcontext
+ details' <- renameDetails details
+ restype' <- renameResType restype
+ mbldoc' <- mapM renameLDocHsSyn mbldoc
+ return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
+ , con_details = details', con_res = restype', con_doc = mbldoc' })
+ where
+ renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
+ renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
+ renameDetails (InfixCon a b) = do
+ a' <- renameLType a
+ b' <- renameLType b
+ return (InfixCon a' b')
+
+ renameResType (ResTyH98) = return ResTyH98
+ renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
+
+
+renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
+renameConDeclFieldField (ConDeclField name t doc) = do
+ name' <- renameL name
+ t' <- renameLType t
+ doc' <- mapM renameLDocHsSyn doc
+ return (ConDeclField name' t' doc')
+
+
+renameSig :: Sig Name -> RnM (Sig DocName)
+renameSig sig = case sig of
+ TypeSig lnames ltype -> do
+ lnames' <- mapM renameL lnames
+ ltype' <- renameLType ltype
+ return (TypeSig lnames' ltype')
+ PatSynSig lname args ltype lreq lprov -> do
+ lname' <- renameL lname
+ args' <- case args of
+ PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs
+ InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright
+ ltype' <- renameLType ltype
+ lreq' <- renameLContext lreq
+ lprov' <- renameLContext lprov
+ return $ PatSynSig lname' args' ltype' lreq' lprov'
+ FixSig (FixitySig lname fixity) -> do
+ lname' <- renameL lname
+ return $ FixSig (FixitySig lname' fixity)
+ MinimalSig s -> MinimalSig <$> traverse renameL s
+ -- we have filtered out all other kinds of signatures in Interface.Create
+ _ -> error "expected TypeSig"
+
+
+renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
+renameForD (ForeignImport lname ltype co x) = do
+ lname' <- renameL lname
+ ltype' <- renameLType ltype
+ return (ForeignImport lname' ltype' co x)
+renameForD (ForeignExport lname ltype co x) = do
+ lname' <- renameL lname
+ ltype' <- renameLType ltype
+ return (ForeignExport lname' ltype' co x)
+
+
+renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
+renameInstD (ClsInstD { cid_inst = d }) = do
+ d' <- renameClsInstD d
+ return (ClsInstD { cid_inst = d' })
+renameInstD (TyFamInstD { tfid_inst = d }) = do
+ d' <- renameTyFamInstD d
+ return (TyFamInstD { tfid_inst = d' })
+renameInstD (DataFamInstD { dfid_inst = d }) = do
+ d' <- renameDataFamInstD d
+ return (DataFamInstD { dfid_inst = d' })
+
+renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
+renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do
+ ltype' <- renameLType ltype
+ lATs' <- mapM (mapM renameTyFamInstD) lATs
+ lADTs' <- mapM (mapM renameDataFamInstD) lADTs
+ return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
+ , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
+
+
+renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
+renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+ = do { eqn' <- renameLThing renameTyFamInstEqn eqn
+ ; return (TyFamInstDecl { tfid_eqn = eqn'
+ , tfid_fvs = placeHolderNames }) }
+
+renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
+renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; rhs' <- renameLType rhs
+ ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
+ , tfie_rhs = rhs' }) }
+
+renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
+renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
+ = do { tc' <- renameL tc
+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
+ ; defn' <- renameDataDefn defn
+ ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }
+ , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
+
+renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
+renameExportItem item = case item of
+ ExportModule mdl -> return (ExportModule mdl)
+ ExportGroup lev id_ doc -> do
+ doc' <- renameDoc doc
+ return (ExportGroup lev id_ doc')
+ ExportDecl decl doc subs instances fixities splice -> do
+ decl' <- renameLDecl decl
+ doc' <- renameDocForDecl doc
+ subs' <- mapM renameSub subs
+ instances' <- forM instances $ \(inst, idoc) -> do
+ inst' <- renameInstHead inst
+ idoc' <- mapM renameDoc idoc
+ return (inst', idoc')
+ fixities' <- forM fixities $ \(name, fixity) -> do
+ name' <- lookupRn name
+ return (name', fixity)
+ return (ExportDecl decl' doc' subs' instances' fixities' splice)
+ ExportNoDecl x subs -> do
+ x' <- lookupRn x
+ subs' <- mapM lookupRn subs
+ return (ExportNoDecl x' subs')
+ ExportDoc doc -> do
+ doc' <- renameDoc doc
+ return (ExportDoc doc')
+
+
+renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
+renameSub (n,doc) = do
+ n' <- rename n
+ doc' <- renameDocForDecl doc
+ return (n', doc')
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
new file mode 100644
index 00000000..bb997b9a
--- /dev/null
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -0,0 +1,636 @@
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.InterfaceFile
+-- Copyright : (c) David Waern 2006-2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Reading and writing the .haddock interface file
+-----------------------------------------------------------------------------
+module Haddock.InterfaceFile (
+ InterfaceFile(..), ifPackageId,
+ readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
+ writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
+) where
+
+
+import Haddock.Types
+import Haddock.Utils hiding (out)
+
+import Control.Monad
+import Data.Array
+import Data.Functor ((<$>))
+import Data.IORef
+import Data.List
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Word
+
+import BinIface (getSymtabName, getDictFastString)
+import Binary
+import FastMutInt
+import FastString
+import GHC hiding (NoLink)
+import GhcMonad (withSession)
+import HscTypes
+import IfaceEnv
+import Name
+import UniqFM
+import UniqSupply
+import Unique
+
+
+data InterfaceFile = InterfaceFile {
+ ifLinkEnv :: LinkEnv,
+ ifInstalledIfaces :: [InstalledInterface]
+}
+
+
+ifPackageId :: InterfaceFile -> PackageId
+ifPackageId if_ =
+ case ifInstalledIfaces if_ of
+ [] -> error "empty InterfaceFile"
+ iface:_ -> modulePackageId $ instMod iface
+
+
+binaryInterfaceMagic :: Word32
+binaryInterfaceMagic = 0xD0Cface
+
+
+-- IMPORTANT: Since datatypes in the GHC API might change between major
+-- versions, and because we store GHC datatypes in our interface files, we need
+-- to make sure we version our interface files accordingly.
+--
+-- If you change the interface file format or adapt Haddock to work with a new
+-- major version of GHC (so that the format changes indirectly) *you* need to
+-- follow these steps:
+--
+-- (1) increase `binaryInterfaceVersion`
+--
+-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
+--
+binaryInterfaceVersion :: Word16
+#if __GLASGOW_HASKELL__ == 708
+binaryInterfaceVersion = 25
+
+binaryInterfaceVersionCompatibility :: [Word16]
+binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
+#else
+#error Unsupported GHC version
+#endif
+
+
+initBinMemSize :: Int
+initBinMemSize = 1024*1024
+
+
+writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
+writeInterfaceFile filename iface = do
+ bh0 <- openBinMem initBinMemSize
+ put_ bh0 binaryInterfaceMagic
+ put_ bh0 binaryInterfaceVersion
+
+ -- remember where the dictionary pointer will go
+ dict_p_p <- tellBin bh0
+ put_ bh0 dict_p_p
+
+ -- remember where the symbol table pointer will go
+ symtab_p_p <- tellBin bh0
+ put_ bh0 symtab_p_p
+
+ -- Make some intial state
+ symtab_next <- newFastMutInt
+ writeFastMutInt symtab_next 0
+ symtab_map <- newIORef emptyUFM
+ let bin_symtab = BinSymbolTable {
+ bin_symtab_next = symtab_next,
+ bin_symtab_map = symtab_map }
+ dict_next_ref <- newFastMutInt
+ writeFastMutInt dict_next_ref 0
+ dict_map_ref <- newIORef emptyUFM
+ let bin_dict = BinDictionary {
+ bin_dict_next = dict_next_ref,
+ bin_dict_map = dict_map_ref }
+
+ -- put the main thing
+ let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
+ (putFastString bin_dict)
+ put_ bh iface
+
+ -- write the symtab pointer at the front of the file
+ symtab_p <- tellBin bh
+ putAt bh symtab_p_p symtab_p
+ seekBin bh symtab_p
+
+ -- write the symbol table itself
+ symtab_next' <- readFastMutInt symtab_next
+ symtab_map' <- readIORef symtab_map
+ putSymbolTable bh symtab_next' symtab_map'
+
+ -- write the dictionary pointer at the fornt of the file
+ dict_p <- tellBin bh
+ putAt bh dict_p_p dict_p
+ seekBin bh dict_p
+
+ -- write the dictionary itself
+ dict_next <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
+ putDictionary bh dict_next dict_map
+
+ -- and send the result to the file
+ writeBinMem bh filename
+ return ()
+
+
+type NameCacheAccessor m = (m NameCache, NameCache -> m ())
+
+
+nameCacheFromGhc :: NameCacheAccessor Ghc
+nameCacheFromGhc = ( read_from_session , write_to_session )
+ where
+ read_from_session = do
+ ref <- withSession (return . hsc_NC)
+ liftIO $ readIORef ref
+ write_to_session nc' = do
+ ref <- withSession (return . hsc_NC)
+ liftIO $ writeIORef ref nc'
+
+
+freshNameCache :: NameCacheAccessor IO
+freshNameCache = ( create_fresh_nc , \_ -> return () )
+ where
+ create_fresh_nc = do
+ u <- mkSplitUniqSupply 'a' -- ??
+ return (initNameCache u [])
+
+
+-- | Read a Haddock (@.haddock@) interface file. Return either an
+-- 'InterfaceFile' or an error message.
+--
+-- This function can be called in two ways. Within a GHC session it will
+-- update the use and update the session's name cache. Outside a GHC session
+-- a new empty name cache is used. The function is therefore generic in the
+-- monad being used. The exact monad is whichever monad the first
+-- argument, the getter and setter of the name cache, requires.
+--
+readInterfaceFile :: forall m.
+ MonadIO m
+ => NameCacheAccessor m
+ -> FilePath
+ -> m (Either String InterfaceFile)
+readInterfaceFile (get_name_cache, set_name_cache) filename = do
+ bh0 <- liftIO $ readBinMem filename
+
+ magic <- liftIO $ get bh0
+ version <- liftIO $ get bh0
+
+ case () of
+ _ | magic /= binaryInterfaceMagic -> return . Left $
+ "Magic number mismatch: couldn't load interface file: " ++ filename
+ | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
+ "Interface file is of wrong version: " ++ filename
+ | otherwise -> with_name_cache $ \update_nc -> do
+
+ dict <- get_dictionary bh0
+
+ -- read the symbol table so we are capable of reading the actual data
+ bh1 <- do
+ let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
+ (getDictFastString dict)
+ symtab <- update_nc (get_symbol_table bh1)
+ return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)
+ (getDictFastString dict)
+
+ -- load the actual data
+ iface <- liftIO $ get bh1
+ return (Right iface)
+ where
+ with_name_cache :: forall a.
+ ((forall n b. MonadIO n
+ => (NameCache -> n (NameCache, b))
+ -> n b)
+ -> m a)
+ -> m a
+ with_name_cache act = do
+ nc_var <- get_name_cache >>= (liftIO . newIORef)
+ x <- act $ \f -> do
+ nc <- liftIO $ readIORef nc_var
+ (nc', x) <- f nc
+ liftIO $ writeIORef nc_var nc'
+ return x
+ liftIO (readIORef nc_var) >>= set_name_cache
+ return x
+
+ get_dictionary bin_handle = liftIO $ do
+ dict_p <- get bin_handle
+ data_p <- tellBin bin_handle
+ seekBin bin_handle dict_p
+ dict <- getDictionary bin_handle
+ seekBin bin_handle data_p
+ return dict
+
+ get_symbol_table bh1 theNC = liftIO $ do
+ symtab_p <- get bh1
+ data_p' <- tellBin bh1
+ seekBin bh1 symtab_p
+ (nc', symtab) <- getSymbolTable bh1 theNC
+ seekBin bh1 data_p'
+ return (nc', symtab)
+
+
+-------------------------------------------------------------------------------
+-- * Symbol table
+-------------------------------------------------------------------------------
+
+
+putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
+putName BinSymbolTable{
+ bin_symtab_map = symtab_map_ref,
+ bin_symtab_next = symtab_next } bh name
+ = do
+ symtab_map <- readIORef symtab_map_ref
+ case lookupUFM symtab_map name of
+ Just (off,_) -> put_ bh (fromIntegral off :: Word32)
+ Nothing -> do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! addToUFM symtab_map name (off,name)
+ put_ bh (fromIntegral off :: Word32)
+
+
+data BinSymbolTable = BinSymbolTable {
+ bin_symtab_next :: !FastMutInt, -- The next index to use
+ bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
+ -- indexed by Name
+ }
+
+
+putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putFastString BinDictionary { bin_dict_next = j_r,
+ bin_dict_map = out_r} bh f
+ = do
+ out <- readIORef out_r
+ let unique = getUnique f
+ case lookupUFM out unique of
+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)
+ Nothing -> do
+ j <- readFastMutInt j_r
+ put_ bh (fromIntegral j :: Word32)
+ writeFastMutInt j_r (j + 1)
+ writeIORef out_r $! addToUFM out unique (j, f)
+
+
+data BinDictionary = BinDictionary {
+ bin_dict_next :: !FastMutInt, -- The next index to use
+ bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
+ -- indexed by FastString
+ }
+
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable bh next_off symtab = do
+ put_ bh next_off
+ let names = elems (array (0,next_off-1) (eltsUFM symtab))
+ mapM_ (\n -> serialiseName bh n symtab) names
+
+
+getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
+getSymbolTable bh namecache = do
+ sz <- get bh
+ od_names <- replicateM sz (get bh)
+ let arr = listArray (0,sz-1) names
+ (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
+ return (namecache', arr)
+
+
+type OnDiskName = (PackageId, ModuleName, OccName)
+
+
+fromOnDiskName
+ :: Array Int Name
+ -> NameCache
+ -> OnDiskName
+ -> (NameCache, Name)
+fromOnDiskName _ nc (pid, mod_name, occ) =
+ let
+ modu = mkModule pid mod_name
+ cache = nsNames nc
+ in
+ case lookupOrigNameCache cache modu occ of
+ Just name -> (nc, name)
+ Nothing ->
+ let
+ us = nsUniqs nc
+ u = uniqFromSupply us
+ name = mkExternalName u modu occ noSrcSpan
+ new_cache = extendNameCache cache modu occ name
+ in
+ case splitUniqSupply us of { (us',_) ->
+ ( nc{ nsUniqs = us', nsNames = new_cache }, name )
+ }
+
+
+serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName bh name _ = do
+ let modu = nameModule name
+ put_ bh (modulePackageId modu, moduleName modu, nameOccName name)
+
+
+-------------------------------------------------------------------------------
+-- * GhcBinary instances
+-------------------------------------------------------------------------------
+
+
+instance (Ord k, Binary k, Binary v) => Binary (Map k v) where
+ put_ bh m = put_ bh (Map.toList m)
+ get bh = fmap (Map.fromList) (get bh)
+
+
+instance Binary InterfaceFile where
+ put_ bh (InterfaceFile env ifaces) = do
+ put_ bh env
+ put_ bh ifaces
+
+ get bh = do
+ env <- get bh
+ ifaces <- get bh
+ return (InterfaceFile env ifaces)
+
+
+instance Binary InstalledInterface where
+ put_ bh (InstalledInterface modu info docMap argMap
+ exps visExps opts subMap fixMap) = do
+ put_ bh modu
+ put_ bh info
+ put_ bh docMap
+ put_ bh argMap
+ put_ bh exps
+ put_ bh visExps
+ put_ bh opts
+ put_ bh subMap
+ put_ bh fixMap
+
+ get bh = do
+ modu <- get bh
+ info <- get bh
+ docMap <- get bh
+ argMap <- get bh
+ exps <- get bh
+ visExps <- get bh
+ opts <- get bh
+ subMap <- get bh
+ fixMap <- get bh
+
+ return (InstalledInterface modu info docMap argMap
+ exps visExps opts subMap fixMap)
+
+
+instance Binary DocOption where
+ put_ bh OptHide = do
+ putByte bh 0
+ put_ bh OptPrune = do
+ putByte bh 1
+ put_ bh OptIgnoreExports = do
+ putByte bh 2
+ put_ bh OptNotHome = do
+ putByte bh 3
+ put_ bh OptShowExtensions = do
+ putByte bh 4
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ return OptHide
+ 1 -> do
+ return OptPrune
+ 2 -> do
+ return OptIgnoreExports
+ 3 -> do
+ return OptNotHome
+ 4 -> do
+ return OptShowExtensions
+ _ -> fail "invalid binary data found"
+
+
+instance Binary Example where
+ put_ bh (Example expression result) = do
+ put_ bh expression
+ put_ bh result
+ get bh = do
+ expression <- get bh
+ result <- get bh
+ return (Example expression result)
+
+instance Binary Hyperlink where
+ put_ bh (Hyperlink url label) = do
+ put_ bh url
+ put_ bh label
+ get bh = do
+ url <- get bh
+ label <- get bh
+ return (Hyperlink url label)
+
+instance Binary Picture where
+ put_ bh (Picture uri title) = do
+ put_ bh uri
+ put_ bh title
+ get bh = do
+ uri <- get bh
+ title <- get bh
+ return (Picture uri title)
+
+instance Binary a => Binary (Header a) where
+ put_ bh (Header l t) = do
+ put_ bh l
+ put_ bh t
+ get bh = do
+ l <- get bh
+ t <- get bh
+ return (Header l t)
+
+{-* Generated by DrIFT : Look, but Don't Touch. *-}
+instance (Binary mod, Binary id) => Binary (DocH mod id) where
+ put_ bh DocEmpty = do
+ putByte bh 0
+ put_ bh (DocAppend aa ab) = do
+ putByte bh 1
+ put_ bh aa
+ put_ bh ab
+ put_ bh (DocString ac) = do
+ putByte bh 2
+ put_ bh ac
+ put_ bh (DocParagraph ad) = do
+ putByte bh 3
+ put_ bh ad
+ put_ bh (DocIdentifier ae) = do
+ putByte bh 4
+ put_ bh ae
+ put_ bh (DocModule af) = do
+ putByte bh 5
+ put_ bh af
+ put_ bh (DocEmphasis ag) = do
+ putByte bh 6
+ put_ bh ag
+ put_ bh (DocMonospaced ah) = do
+ putByte bh 7
+ put_ bh ah
+ put_ bh (DocUnorderedList ai) = do
+ putByte bh 8
+ put_ bh ai
+ put_ bh (DocOrderedList aj) = do
+ putByte bh 9
+ put_ bh aj
+ put_ bh (DocDefList ak) = do
+ putByte bh 10
+ put_ bh ak
+ put_ bh (DocCodeBlock al) = do
+ putByte bh 11
+ put_ bh al
+ put_ bh (DocHyperlink am) = do
+ putByte bh 12
+ put_ bh am
+ put_ bh (DocPic x) = do
+ putByte bh 13
+ put_ bh x
+ put_ bh (DocAName an) = do
+ putByte bh 14
+ put_ bh an
+ put_ bh (DocExamples ao) = do
+ putByte bh 15
+ put_ bh ao
+ put_ bh (DocIdentifierUnchecked x) = do
+ putByte bh 16
+ put_ bh x
+ put_ bh (DocWarning ag) = do
+ putByte bh 17
+ put_ bh ag
+ put_ bh (DocProperty x) = do
+ putByte bh 18
+ put_ bh x
+ put_ bh (DocBold x) = do
+ putByte bh 19
+ put_ bh x
+ put_ bh (DocHeader aa) = do
+ putByte bh 20
+ put_ bh aa
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ return DocEmpty
+ 1 -> do
+ aa <- get bh
+ ab <- get bh
+ return (DocAppend aa ab)
+ 2 -> do
+ ac <- get bh
+ return (DocString ac)
+ 3 -> do
+ ad <- get bh
+ return (DocParagraph ad)
+ 4 -> do
+ ae <- get bh
+ return (DocIdentifier ae)
+ 5 -> do
+ af <- get bh
+ return (DocModule af)
+ 6 -> do
+ ag <- get bh
+ return (DocEmphasis ag)
+ 7 -> do
+ ah <- get bh
+ return (DocMonospaced ah)
+ 8 -> do
+ ai <- get bh
+ return (DocUnorderedList ai)
+ 9 -> do
+ aj <- get bh
+ return (DocOrderedList aj)
+ 10 -> do
+ ak <- get bh
+ return (DocDefList ak)
+ 11 -> do
+ al <- get bh
+ return (DocCodeBlock al)
+ 12 -> do
+ am <- get bh
+ return (DocHyperlink am)
+ 13 -> do
+ x <- get bh
+ return (DocPic x)
+ 14 -> do
+ an <- get bh
+ return (DocAName an)
+ 15 -> do
+ ao <- get bh
+ return (DocExamples ao)
+ 16 -> do
+ x <- get bh
+ return (DocIdentifierUnchecked x)
+ 17 -> do
+ ag <- get bh
+ return (DocWarning ag)
+ 18 -> do
+ x <- get bh
+ return (DocProperty x)
+ 19 -> do
+ x <- get bh
+ return (DocBold x)
+ 20 -> do
+ aa <- get bh
+ return (DocHeader aa)
+ _ -> error "invalid binary data found in the interface file"
+
+
+instance Binary name => Binary (HaddockModInfo name) where
+ put_ bh hmi = do
+ put_ bh (hmi_description hmi)
+ put_ bh (hmi_copyright hmi)
+ put_ bh (hmi_license hmi)
+ put_ bh (hmi_maintainer hmi)
+ put_ bh (hmi_stability hmi)
+ put_ bh (hmi_portability hmi)
+ put_ bh (hmi_safety hmi)
+ put_ bh (fromEnum <$> hmi_language hmi)
+ put_ bh (map fromEnum $ hmi_extensions hmi)
+
+ get bh = do
+ descr <- get bh
+ copyr <- get bh
+ licen <- get bh
+ maint <- get bh
+ stabi <- get bh
+ porta <- get bh
+ safet <- get bh
+ langu <- fmap toEnum <$> get bh
+ exten <- map toEnum <$> get bh
+ return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten)
+
+instance Binary DocName where
+ put_ bh (Documented name modu) = do
+ putByte bh 0
+ put_ bh name
+ put_ bh modu
+ put_ bh (Undocumented name) = do
+ putByte bh 1
+ put_ bh name
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ name <- get bh
+ modu <- get bh
+ return (Documented name modu)
+ 1 -> do
+ name <- get bh
+ return (Undocumented name)
+ _ -> error "get DocName: Bad h"
diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs
new file mode 100644
index 00000000..2a7fbfcc
--- /dev/null
+++ b/haddock-api/src/Haddock/ModuleTree.hs
@@ -0,0 +1,56 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.ModuleTree
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
+
+
+import Haddock.Types ( Doc )
+
+import GHC ( Name )
+import Module ( Module, moduleNameString, moduleName, modulePackageId,
+ packageIdString )
+
+
+data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree]
+
+
+mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree]
+mkModuleTree showPkgs mods =
+ foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ]
+ where
+ modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_))
+ | otherwise = Nothing
+ fn (mod_,pkg,short) = addToTrees mod_ pkg short
+
+
+addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree]
+addToTrees [] _ _ ts = ts
+addToTrees ss pkg short [] = mkSubTree ss pkg short
+addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
+ | s1 > s2 = t : addToTrees (s1:ss) pkg short ts
+ | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
+ | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
+ where
+ this_pkg = if null ss then pkg else node_pkg
+ this_short = if null ss then short else node_short
+
+
+mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree]
+mkSubTree [] _ _ = []
+mkSubTree [s] pkg short = [Node s True pkg short []]
+mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
+
+
+splitModule :: Module -> [String]
+splitModule mdl = split (moduleNameString (moduleName mdl))
+ where split mod0 = case break (== '.') mod0 of
+ (s1, '.':s2) -> s1 : split s2
+ (s1, _) -> [s1]
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
new file mode 100644
index 00000000..b166de46
--- /dev/null
+++ b/haddock-api/src/Haddock/Options.hs
@@ -0,0 +1,287 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Options
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Definition of the command line interface of Haddock.
+-----------------------------------------------------------------------------
+module Haddock.Options (
+ parseHaddockOpts,
+ Flag(..),
+ getUsage,
+ optTitle,
+ outputDir,
+ optContentsUrl,
+ optIndexUrl,
+ optCssFile,
+ sourceUrls,
+ wikiUrls,
+ optDumpInterfaceFile,
+ optLaTeXStyle,
+ qualification,
+ verbosity,
+ ghcFlags,
+ readIfaceArgs
+) where
+
+
+import Distribution.Verbosity
+import Haddock.Utils
+import Haddock.Types
+import System.Console.GetOpt
+import qualified Data.Char as Char
+
+
+data Flag
+ = Flag_BuiltInThemes
+ | Flag_CSS String
+-- | Flag_DocBook
+ | Flag_ReadInterface String
+ | Flag_DumpInterface String
+ | Flag_Heading String
+ | Flag_Html
+ | Flag_Hoogle
+ | Flag_Lib String
+ | Flag_OutputDir FilePath
+ | Flag_Prologue FilePath
+ | Flag_SourceBaseURL String
+ | Flag_SourceModuleURL String
+ | Flag_SourceEntityURL String
+ | Flag_SourceLEntityURL String
+ | Flag_WikiBaseURL String
+ | Flag_WikiModuleURL String
+ | Flag_WikiEntityURL String
+ | Flag_LaTeX
+ | Flag_LaTeXStyle String
+ | Flag_Help
+ | Flag_Verbosity String
+ | Flag_Version
+ | Flag_CompatibleInterfaceVersions
+ | Flag_InterfaceVersion
+ | Flag_UseContents String
+ | Flag_GenContents
+ | Flag_UseIndex String
+ | Flag_GenIndex
+ | Flag_IgnoreAllExports
+ | Flag_HideModule String
+ | Flag_ShowExtensions String
+ | Flag_OptGhc String
+ | Flag_GhcLibDir String
+ | Flag_GhcVersion
+ | Flag_PrintGhcPath
+ | Flag_PrintGhcLibDir
+ | Flag_NoWarnings
+ | Flag_UseUnicode
+ | Flag_NoTmpCompDir
+ | Flag_Qualification String
+ | Flag_PrettyHtml
+ | Flag_PrintMissingDocs
+ deriving (Eq)
+
+
+options :: Bool -> [OptDescr Flag]
+options backwardsCompat =
+ [
+ Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR")
+ "path to a GHC lib dir, to override the default path",
+ Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR")
+ "directory in which to put the output files",
+ Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR")
+ "location of Haddock's auxiliary files",
+ Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
+ "read an interface from FILE",
+ Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
+ "write the resulting interface to FILE",
+-- Option ['S'] ["docbook"] (NoArg Flag_DocBook)
+-- "output in DocBook XML",
+ Option ['h'] ["html"] (NoArg Flag_Html)
+ "output in HTML (XHTML 1.0)",
+ Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
+ Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
+ Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
+ Option [] ["hoogle"] (NoArg Flag_Hoogle)
+ "output for Hoogle",
+ Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL")
+ "URL for a source code link on the contents\nand index pages",
+ Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
+ (ReqArg Flag_SourceModuleURL "URL")
+ "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
+ Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL")
+ "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
+ Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
+ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
+ Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL")
+ "URL for a comments link on the contents\nand index pages",
+ Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL")
+ "URL for a comments link for each module\n(using the %{MODULE} var)",
+ Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL")
+ "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
+ Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH")
+ "the CSS file or theme directory to use for HTML output",
+ Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes)
+ "include all the built-in haddock themes",
+ Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE")
+ "file containing prologue text",
+ Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
+ "page heading",
+ Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")
+ "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
+ Option ['?'] ["help"] (NoArg Flag_Help)
+ "display this help and exit",
+ Option ['V'] ["version"] (NoArg Flag_Version)
+ "output version information and exit",
+ Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions)
+ "output compatible interface file versions and exit",
+ Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
+ "output interface file version and exit",
+ Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
+ "set verbosity level",
+ Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
+ "use a separately-generated HTML contents page",
+ Option [] ["gen-contents"] (NoArg Flag_GenContents)
+ "generate an HTML contents from specified\ninterfaces",
+ Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
+ "use a separately-generated HTML index",
+ Option [] ["gen-index"] (NoArg Flag_GenIndex)
+ "generate an HTML index from specified\ninterfaces",
+ Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
+ "behave as if all modules have the\nignore-exports atribute",
+ Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
+ "behave as if MODULE has the hide attribute",
+ Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")
+ "behave as if MODULE has the show-extensions attribute",
+ Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")
+ "option to be forwarded to GHC",
+ Option [] ["ghc-version"] (NoArg Flag_GhcVersion)
+ "output GHC version in numeric format",
+ Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath)
+ "output path to GHC binary",
+ Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir)
+ "output GHC lib dir",
+ Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
+ Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
+ "do not re-direct compilation output to a temporary directory",
+ Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
+ "generate html with newlines and indenting (for use with --html)",
+ Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs)
+ "print information about any undocumented entities"
+ ]
+
+
+getUsage :: IO String
+getUsage = do
+ prog <- getProgramName
+ return $ usageInfo (usageHeader prog) (options False)
+ where
+ usageHeader :: String -> String
+ usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
+
+
+parseHaddockOpts :: [String] -> IO ([Flag], [String])
+parseHaddockOpts params =
+ case getOpt Permute (options True) params of
+ (flags, args, []) -> return (flags, args)
+ (_, _, errors) -> do
+ usage <- getUsage
+ throwE (concat errors ++ usage)
+
+
+optTitle :: [Flag] -> Maybe String
+optTitle flags =
+ case [str | Flag_Heading str <- flags] of
+ [] -> Nothing
+ (t:_) -> Just t
+
+
+outputDir :: [Flag] -> FilePath
+outputDir flags =
+ case [ path | Flag_OutputDir path <- flags ] of
+ [] -> "."
+ paths -> last paths
+
+
+optContentsUrl :: [Flag] -> Maybe String
+optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ]
+
+
+optIndexUrl :: [Flag] -> Maybe String
+optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]
+
+
+optCssFile :: [Flag] -> Maybe FilePath
+optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
+
+
+sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
+sourceUrls flags =
+ (optLast [str | Flag_SourceBaseURL str <- flags]
+ ,optLast [str | Flag_SourceModuleURL str <- flags]
+ ,optLast [str | Flag_SourceEntityURL str <- flags]
+ ,optLast [str | Flag_SourceLEntityURL str <- flags])
+
+
+wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
+wikiUrls flags =
+ (optLast [str | Flag_WikiBaseURL str <- flags]
+ ,optLast [str | Flag_WikiModuleURL str <- flags]
+ ,optLast [str | Flag_WikiEntityURL str <- flags])
+
+
+optDumpInterfaceFile :: [Flag] -> Maybe FilePath
+optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
+
+
+optLaTeXStyle :: [Flag] -> Maybe String
+optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
+
+
+qualification :: [Flag] -> Either String QualOption
+qualification flags =
+ case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
+ [] -> Right OptNoQual
+ ["none"] -> Right OptNoQual
+ ["full"] -> Right OptFullQual
+ ["local"] -> Right OptLocalQual
+ ["relative"] -> Right OptRelativeQual
+ ["aliased"] -> Right OptAliasedQual
+ [arg] -> Left $ "unknown qualification type " ++ show arg
+ _:_ -> Left "qualification option given multiple times"
+
+
+verbosity :: [Flag] -> Verbosity
+verbosity flags =
+ case [ str | Flag_Verbosity str <- flags ] of
+ [] -> normal
+ x:_ -> case parseVerbosity x of
+ Left e -> throwE e
+ Right v -> v
+
+
+ghcFlags :: [Flag] -> [String]
+ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
+
+
+readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
+readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
+ where
+ parseIfaceOption :: String -> (DocPaths, FilePath)
+ parseIfaceOption str =
+ case break (==',') str of
+ (fpath, ',':rest) ->
+ case break (==',') rest of
+ (src, ',':file) -> ((fpath, Just src), file)
+ (file, _) -> ((fpath, Nothing), file)
+ (file, _) -> (("", Nothing), file)
+
+
+-- | Like 'listToMaybe' but returns the last element instead of the first.
+optLast :: [a] -> Maybe a
+optLast [] = Nothing
+optLast xs = Just (last xs)
diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs
new file mode 100644
index 00000000..ea4b7a3f
--- /dev/null
+++ b/haddock-api/src/Haddock/Parser.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving
+ , FlexibleInstances, UndecidableInstances
+ , IncoherentInstances #-}
+{-# LANGUAGE LambdaCase #-}
+-- |
+-- Module : Haddock.Parser
+-- Copyright : (c) Mateusz Kowalczyk 2013,
+-- Simon Hengel 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+
+module Haddock.Parser ( parseParas
+ , parseString
+ , parseIdent
+ ) where
+
+import qualified Documentation.Haddock.Parser as P
+import DynFlags (DynFlags)
+import FastString (mkFastString)
+import Documentation.Haddock.Types
+import Lexer (mkPState, unP, ParseResult(POk))
+import Parser (parseIdentifier)
+import RdrName (RdrName)
+import SrcLoc (mkRealSrcLoc, unLoc)
+import StringBuffer (stringToStringBuffer)
+
+parseParas :: DynFlags -> String -> DocH mod RdrName
+parseParas d = P.overIdentifier (parseIdent d) . P.parseParas
+
+parseString :: DynFlags -> String -> DocH mod RdrName
+parseString d = P.overIdentifier (parseIdent d) . P.parseString
+
+parseIdent :: DynFlags -> String -> Maybe RdrName
+parseIdent dflags str0 =
+ let buffer = stringToStringBuffer str0
+ realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
+ pstate = mkPState dflags buffer realSrcLc
+ in case unP parseIdentifier pstate of
+ POk _ name -> Just (unLoc name)
+ _ -> Nothing
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
new file mode 100644
index 00000000..85b3a592
--- /dev/null
+++ b/haddock-api/src/Haddock/Types.hs
@@ -0,0 +1,552 @@
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Types
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mateusz Kowalczyk 2013
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskellorg
+-- Stability : experimental
+-- Portability : portable
+--
+-- Types that are commonly used through-out Haddock. Some of the most
+-- important types are defined here, like 'Interface' and 'DocName'.
+-----------------------------------------------------------------------------
+module Haddock.Types (
+ module Haddock.Types
+ , HsDocString, LHsDocString
+ , Fixity(..)
+ , module Documentation.Haddock.Types
+ ) where
+
+import Control.Exception
+import Control.Arrow hiding ((<+>))
+import Control.DeepSeq
+import Data.Typeable
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Documentation.Haddock.Types
+import BasicTypes (Fixity(..))
+import GHC hiding (NoLink)
+import DynFlags (ExtensionFlag, Language)
+import OccName
+import Outputable
+import Control.Applicative (Applicative(..))
+import Control.Monad (ap)
+
+-----------------------------------------------------------------------------
+-- * Convenient synonyms
+-----------------------------------------------------------------------------
+
+
+type IfaceMap = Map Module Interface
+type InstIfaceMap = Map Module InstalledInterface -- TODO: rename
+type DocMap a = Map Name (Doc a)
+type ArgMap a = Map Name (Map Int (Doc a))
+type SubMap = Map Name [Name]
+type DeclMap = Map Name [LHsDecl Name]
+type InstMap = Map SrcSpan Name
+type FixMap = Map Name Fixity
+type SrcMap = Map PackageId FilePath
+type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
+
+
+-----------------------------------------------------------------------------
+-- * Interface
+-----------------------------------------------------------------------------
+
+
+-- | 'Interface' holds all information used to render a single Haddock page.
+-- It represents the /interface/ of a module. The core business of Haddock
+-- lies in creating this structure. Note that the record contains some fields
+-- that are only used to create the final record, and that are not used by the
+-- backends.
+data Interface = Interface
+ {
+ -- | The module behind this interface.
+ ifaceMod :: !Module
+
+ -- | Original file name of the module.
+ , ifaceOrigFilename :: !FilePath
+
+ -- | Textual information about the module.
+ , ifaceInfo :: !(HaddockModInfo Name)
+
+ -- | Documentation header.
+ , ifaceDoc :: !(Documentation Name)
+
+ -- | Documentation header with cross-reference information.
+ , ifaceRnDoc :: !(Documentation DocName)
+
+ -- | Haddock options for this module (prune, ignore-exports, etc).
+ , ifaceOptions :: ![DocOption]
+
+ -- | Declarations originating from the module. Excludes declarations without
+ -- names (instances and stand-alone documentation comments). Includes
+ -- names of subordinate declarations mapped to their parent declarations.
+ , ifaceDeclMap :: !(Map Name [LHsDecl Name])
+
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
+ , ifaceDocMap :: !(DocMap Name)
+ , ifaceArgMap :: !(ArgMap Name)
+
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
+ , ifaceRnDocMap :: !(DocMap DocName)
+ , ifaceRnArgMap :: !(ArgMap DocName)
+
+ , ifaceSubMap :: !(Map Name [Name])
+ , ifaceFixMap :: !(Map Name Fixity)
+
+ , ifaceExportItems :: ![ExportItem Name]
+ , ifaceRnExportItems :: ![ExportItem DocName]
+
+ -- | All names exported by the module.
+ , ifaceExports :: ![Name]
+
+ -- | All \"visible\" names exported by the module.
+ -- A visible name is a name that will show up in the documentation of the
+ -- module.
+ , ifaceVisibleExports :: ![Name]
+
+ -- | Aliases of module imports as in @import A.B.C as C@.
+ , ifaceModuleAliases :: !AliasMap
+
+ -- | Instances exported by the module.
+ , ifaceInstances :: ![ClsInst]
+ , ifaceFamInstances :: ![FamInst]
+
+ -- | The number of haddockable and haddocked items in the module, as a
+ -- tuple. Haddockable items are the exports and the module itself.
+ , ifaceHaddockCoverage :: !(Int, Int)
+
+ -- | Warnings for things defined in this module.
+ , ifaceWarningMap :: !WarningMap
+ }
+
+type WarningMap = DocMap Name
+
+
+-- | A subset of the fields of 'Interface' that we store in the interface
+-- files.
+data InstalledInterface = InstalledInterface
+ {
+ -- | The module represented by this interface.
+ instMod :: Module
+
+ -- | Textual information about the module.
+ , instInfo :: HaddockModInfo Name
+
+ -- | Documentation of declarations originating from the module (including
+ -- subordinates).
+ , instDocMap :: DocMap Name
+
+ , instArgMap :: ArgMap Name
+
+ -- | All names exported by this module.
+ , instExports :: [Name]
+
+ -- | All \"visible\" names exported by the module.
+ -- A visible name is a name that will show up in the documentation of the
+ -- module.
+ , instVisibleExports :: [Name]
+
+ -- | Haddock options for this module (prune, ignore-exports, etc).
+ , instOptions :: [DocOption]
+
+ , instSubMap :: Map Name [Name]
+ , instFixMap :: Map Name Fixity
+ }
+
+
+-- | Convert an 'Interface' to an 'InstalledInterface'
+toInstalledIface :: Interface -> InstalledInterface
+toInstalledIface interface = InstalledInterface
+ { instMod = ifaceMod interface
+ , instInfo = ifaceInfo interface
+ , instDocMap = ifaceDocMap interface
+ , instArgMap = ifaceArgMap interface
+ , instExports = ifaceExports interface
+ , instVisibleExports = ifaceVisibleExports interface
+ , instOptions = ifaceOptions interface
+ , instSubMap = ifaceSubMap interface
+ , instFixMap = ifaceFixMap interface
+ }
+
+
+-----------------------------------------------------------------------------
+-- * Export items & declarations
+-----------------------------------------------------------------------------
+
+
+data ExportItem name
+
+ -- | An exported declaration.
+ = ExportDecl
+ {
+ -- | A declaration.
+ expItemDecl :: !(LHsDecl name)
+
+ -- | Maybe a doc comment, and possibly docs for arguments (if this
+ -- decl is a function or type-synonym).
+ , expItemMbDoc :: !(DocForDecl name)
+
+ -- | Subordinate names, possibly with documentation.
+ , expItemSubDocs :: ![(name, DocForDecl name)]
+
+ -- | Instances relevant to this declaration, possibly with
+ -- documentation.
+ , expItemInstances :: ![DocInstance name]
+
+ -- | Fixity decls relevant to this declaration (including subordinates).
+ , expItemFixities :: ![(name, Fixity)]
+
+ -- | Whether the ExportItem is from a TH splice or not, for generating
+ -- the appropriate type of Source link.
+ , expItemSpliced :: !Bool
+ }
+
+ -- | An exported entity for which we have no documentation (perhaps because it
+ -- resides in another package).
+ | ExportNoDecl
+ { expItemName :: !name
+
+ -- | Subordinate names.
+ , expItemSubs :: ![name]
+ }
+
+ -- | A section heading.
+ | ExportGroup
+ {
+ -- | Section level (1, 2, 3, ...).
+ expItemSectionLevel :: !Int
+
+ -- | Section id (for hyperlinks).
+ , expItemSectionId :: !String
+
+ -- | Section heading text.
+ , expItemSectionText :: !(Doc name)
+ }
+
+ -- | Some documentation.
+ | ExportDoc !(Doc name)
+
+ -- | A cross-reference to another module.
+ | ExportModule !Module
+
+data Documentation name = Documentation
+ { documentationDoc :: Maybe (Doc name)
+ , documentationWarning :: !(Maybe (Doc name))
+ } deriving Functor
+
+
+-- | Arguments and result are indexed by Int, zero-based from the left,
+-- because that's the easiest to use when recursing over types.
+type FnArgsDoc name = Map Int (Doc name)
+type DocForDecl name = (Documentation name, FnArgsDoc name)
+
+
+noDocForDecl :: DocForDecl name
+noDocForDecl = (Documentation Nothing Nothing, Map.empty)
+
+
+unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
+unrenameDocForDecl (doc, fnArgsDoc) =
+ (fmap getName doc, (fmap . fmap) getName fnArgsDoc)
+
+
+-----------------------------------------------------------------------------
+-- * Cross-referencing
+-----------------------------------------------------------------------------
+
+
+-- | Type of environment used to cross-reference identifiers in the syntax.
+type LinkEnv = Map Name Module
+
+
+-- | Extends 'Name' with cross-reference information.
+data DocName
+ = Documented Name Module
+ -- ^ This thing is part of the (existing or resulting)
+ -- documentation. The 'Module' is the preferred place
+ -- in the documentation to refer to.
+ | Undocumented Name
+ -- ^ This thing is not part of the (existing or resulting)
+ -- documentation, as far as Haddock knows.
+ deriving Eq
+
+
+instance NamedThing DocName where
+ getName (Documented name _) = name
+ getName (Undocumented name) = name
+
+
+-----------------------------------------------------------------------------
+-- * Instances
+-----------------------------------------------------------------------------
+
+-- | The three types of instances
+data InstType name
+ = ClassInst [HsType name] -- ^ Context
+ | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
+ | DataInst (TyClDecl name) -- ^ Data constructors
+
+instance OutputableBndr a => Outputable (InstType a) where
+ ppr (ClassInst a) = text "ClassInst" <+> ppr a
+ ppr (TypeInst a) = text "TypeInst" <+> ppr a
+ ppr (DataInst a) = text "DataInst" <+> ppr a
+
+-- | An instance head that may have documentation.
+type DocInstance name = (InstHead name, Maybe (Doc name))
+
+-- | The head of an instance. Consists of a class name, a list of kind
+-- parameters, a list of type parameters and an instance type
+type InstHead name = (name, [HsType name], [HsType name], InstType name)
+
+-----------------------------------------------------------------------------
+-- * Documentation comments
+-----------------------------------------------------------------------------
+
+
+type LDoc id = Located (Doc id)
+
+type Doc id = DocH (ModuleName, OccName) id
+
+instance (NFData a, NFData mod)
+ => NFData (DocH mod a) where
+ rnf doc = case doc of
+ DocEmpty -> ()
+ DocAppend a b -> a `deepseq` b `deepseq` ()
+ DocString a -> a `deepseq` ()
+ DocParagraph a -> a `deepseq` ()
+ DocIdentifier a -> a `deepseq` ()
+ DocIdentifierUnchecked a -> a `deepseq` ()
+ DocModule a -> a `deepseq` ()
+ DocWarning a -> a `deepseq` ()
+ DocEmphasis a -> a `deepseq` ()
+ DocBold a -> a `deepseq` ()
+ DocMonospaced a -> a `deepseq` ()
+ DocUnorderedList a -> a `deepseq` ()
+ DocOrderedList a -> a `deepseq` ()
+ DocDefList a -> a `deepseq` ()
+ DocCodeBlock a -> a `deepseq` ()
+ DocHyperlink a -> a `deepseq` ()
+ DocPic a -> a `deepseq` ()
+ DocAName a -> a `deepseq` ()
+ DocProperty a -> a `deepseq` ()
+ DocExamples a -> a `deepseq` ()
+ DocHeader a -> a `deepseq` ()
+
+
+instance NFData Name
+instance NFData OccName
+instance NFData ModuleName
+
+instance NFData id => NFData (Header id) where
+ rnf (Header a b) = a `deepseq` b `deepseq` ()
+
+instance NFData Hyperlink where
+ rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
+
+instance NFData Picture where
+ rnf (Picture a b) = a `deepseq` b `deepseq` ()
+
+instance NFData Example where
+ rnf (Example a b) = a `deepseq` b `deepseq` ()
+
+
+exampleToString :: Example -> String
+exampleToString (Example expression result) =
+ ">>> " ++ expression ++ "\n" ++ unlines result
+
+
+data DocMarkup id a = Markup
+ { markupEmpty :: a
+ , markupString :: String -> a
+ , markupParagraph :: a -> a
+ , markupAppend :: a -> a -> a
+ , markupIdentifier :: id -> a
+ , markupIdentifierUnchecked :: (ModuleName, OccName) -> a
+ , markupModule :: String -> a
+ , markupWarning :: a -> a
+ , markupEmphasis :: a -> a
+ , markupBold :: a -> a
+ , markupMonospaced :: a -> a
+ , markupUnorderedList :: [a] -> a
+ , markupOrderedList :: [a] -> a
+ , markupDefList :: [(a,a)] -> a
+ , markupCodeBlock :: a -> a
+ , markupHyperlink :: Hyperlink -> a
+ , markupAName :: String -> a
+ , markupPic :: Picture -> a
+ , markupProperty :: String -> a
+ , markupExample :: [Example] -> a
+ , markupHeader :: Header a -> a
+ }
+
+
+data HaddockModInfo name = HaddockModInfo
+ { hmi_description :: Maybe (Doc name)
+ , hmi_copyright :: Maybe String
+ , hmi_license :: Maybe String
+ , hmi_maintainer :: Maybe String
+ , hmi_stability :: Maybe String
+ , hmi_portability :: Maybe String
+ , hmi_safety :: Maybe String
+ , hmi_language :: Maybe Language
+ , hmi_extensions :: [ExtensionFlag]
+ }
+
+
+emptyHaddockModInfo :: HaddockModInfo a
+emptyHaddockModInfo = HaddockModInfo
+ { hmi_description = Nothing
+ , hmi_copyright = Nothing
+ , hmi_license = Nothing
+ , hmi_maintainer = Nothing
+ , hmi_stability = Nothing
+ , hmi_portability = Nothing
+ , hmi_safety = Nothing
+ , hmi_language = Nothing
+ , hmi_extensions = []
+ }
+
+
+-----------------------------------------------------------------------------
+-- * Options
+-----------------------------------------------------------------------------
+
+
+{-! for DocOption derive: Binary !-}
+-- | Source-level options for controlling the documentation.
+data DocOption
+ = OptHide -- ^ This module should not appear in the docs.
+ | OptPrune
+ | OptIgnoreExports -- ^ Pretend everything is exported.
+ | OptNotHome -- ^ Not the best place to get docs for things
+ -- exported by this module.
+ | OptShowExtensions -- ^ Render enabled extensions for this module.
+ deriving (Eq, Show)
+
+
+-- | Option controlling how to qualify names
+data QualOption
+ = OptNoQual -- ^ Never qualify any names.
+ | OptFullQual -- ^ Qualify all names fully.
+ | OptLocalQual -- ^ Qualify all imported names fully.
+ | OptRelativeQual -- ^ Like local, but strip module prefix
+ -- from modules in the same hierarchy.
+ | OptAliasedQual -- ^ Uses aliases of module names
+ -- as suggested by module import renamings.
+ -- However, we are unfortunately not able
+ -- to maintain the original qualifications.
+ -- Image a re-export of a whole module,
+ -- how could the re-exported identifiers be qualified?
+
+type AliasMap = Map Module ModuleName
+
+data Qualification
+ = NoQual
+ | FullQual
+ | LocalQual Module
+ | RelativeQual Module
+ | AliasedQual AliasMap Module
+ -- ^ @Module@ contains the current module.
+ -- This way we can distinguish imported and local identifiers.
+
+makeContentsQual :: QualOption -> Qualification
+makeContentsQual qual =
+ case qual of
+ OptNoQual -> NoQual
+ _ -> FullQual
+
+makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
+makeModuleQual qual aliases mdl =
+ case qual of
+ OptLocalQual -> LocalQual mdl
+ OptRelativeQual -> RelativeQual mdl
+ OptAliasedQual -> AliasedQual aliases mdl
+ OptFullQual -> FullQual
+ OptNoQual -> NoQual
+
+
+-----------------------------------------------------------------------------
+-- * Error handling
+-----------------------------------------------------------------------------
+
+
+-- A monad which collects error messages, locally defined to avoid a dep on mtl
+
+
+type ErrMsg = String
+newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
+
+
+instance Functor ErrMsgM where
+ fmap f (Writer (a, msgs)) = Writer (f a, msgs)
+
+instance Applicative ErrMsgM where
+ pure = return
+ (<*>) = ap
+
+instance Monad ErrMsgM where
+ return a = Writer (a, [])
+ m >>= k = Writer $ let
+ (a, w) = runWriter m
+ (b, w') = runWriter (k a)
+ in (b, w ++ w')
+
+
+tell :: [ErrMsg] -> ErrMsgM ()
+tell w = Writer ((), w)
+
+
+-- Exceptions
+
+
+-- | Haddock's own exception type.
+data HaddockException = HaddockException String deriving Typeable
+
+
+instance Show HaddockException where
+ show (HaddockException str) = str
+
+
+throwE :: String -> a
+instance Exception HaddockException
+throwE str = throw (HaddockException str)
+
+
+-- In "Haddock.Interface.Create", we need to gather
+-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
+-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
+-- transformed monad to be MonadIO.
+newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
+--instance MonadIO ErrMsgGhc where
+-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
+--er, implementing GhcMonad involves annoying ExceptionMonad and
+--WarnLogMonad classes, so don't bother.
+liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
+liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
+liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
+liftErrMsg = WriterGhc . return . runWriter
+-- for now, use (liftErrMsg . tell) for this
+--tell :: [ErrMsg] -> ErrMsgGhc ()
+--tell msgs = WriterGhc $ return ( (), msgs )
+
+
+instance Functor ErrMsgGhc where
+ fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
+
+instance Applicative ErrMsgGhc where
+ pure = return
+ (<*>) = ap
+
+instance Monad ErrMsgGhc where
+ return a = WriterGhc (return (a, []))
+ m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
+ fmap (second (msgs1 ++)) (runWriterGhc (k a))
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
new file mode 100644
index 00000000..ee7bfd0a
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -0,0 +1,480 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Utils
+-- Copyright : (c) The University of Glasgow 2001-2002,
+-- Simon Marlow 2003-2006,
+-- David Waern 2006-2009
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Utils (
+
+ -- * Misc utilities
+ restrictTo, emptyHsQTvs,
+ toDescription, toInstalledDescription,
+
+ -- * Filename utilities
+ moduleHtmlFile, moduleHtmlFile',
+ contentsHtmlFile, indexHtmlFile,
+ frameIndexHtmlFile,
+ moduleIndexFrameName, mainFrameName, synopsisFrameName,
+ subIndexHtmlFile,
+ jsFile, framesFile,
+
+ -- * Anchor and URL utilities
+ moduleNameUrl, moduleNameUrl', moduleUrl,
+ nameAnchorId,
+ makeAnchorId,
+
+ -- * Miscellaneous utilities
+ getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
+
+ -- * HTML cross reference mapping
+ html_xrefs_ref, html_xrefs_ref',
+
+ -- * Doc markup
+ markup,
+ idMarkup,
+
+ -- * List utilities
+ replace,
+ spanWith,
+
+ -- * MTL stuff
+ MonadIO(..),
+
+ -- * Logging
+ parseVerbosity,
+ out,
+
+ -- * System tools
+ getProcessID
+ ) where
+
+
+import Haddock.Types
+import Haddock.GhcUtils
+
+import GHC
+import Name
+
+import Control.Monad ( liftM )
+import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
+import Numeric ( showIntAtBase )
+import Data.Map ( Map )
+import qualified Data.Map as Map hiding ( Map )
+import Data.IORef ( IORef, newIORef, readIORef )
+import Data.List ( isSuffixOf )
+import Data.Maybe ( mapMaybe )
+import System.Environment ( getProgName )
+import System.Exit
+import System.IO ( hPutStr, stderr )
+import System.IO.Unsafe ( unsafePerformIO )
+import qualified System.FilePath.Posix as HtmlPath
+import Distribution.Verbosity
+import Distribution.ReadE
+
+#ifndef mingw32_HOST_OS
+import qualified System.Posix.Internals
+#endif
+
+import MonadUtils ( MonadIO(..) )
+
+
+--------------------------------------------------------------------------------
+-- * Logging
+--------------------------------------------------------------------------------
+
+
+parseVerbosity :: String -> Either String Verbosity
+parseVerbosity = runReadE flagToVerbosity
+
+
+-- | Print a message to stdout, if it is not too verbose
+out :: MonadIO m
+ => Verbosity -- ^ program verbosity
+ -> Verbosity -- ^ message verbosity
+ -> String -> m ()
+out progVerbosity msgVerbosity msg
+ | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg
+ | otherwise = return ()
+
+
+--------------------------------------------------------------------------------
+-- * Some Utilities
+--------------------------------------------------------------------------------
+
+
+-- | Extract a module's short description.
+toDescription :: Interface -> Maybe (Doc Name)
+toDescription = hmi_description . ifaceInfo
+
+
+-- | Extract a module's short description.
+toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)
+toInstalledDescription = hmi_description . instInfo
+
+
+--------------------------------------------------------------------------------
+-- * Making abstract declarations
+--------------------------------------------------------------------------------
+
+
+restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
+restrictTo names (L loc decl) = L loc $ case decl of
+ TyClD d | isDataDecl d ->
+ TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
+ TyClD d | isClassDecl d ->
+ TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
+ tcdATs = restrictATs names (tcdATs d) })
+ _ -> decl
+
+restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name
+restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
+ | DataType <- new_or_data
+ = defn { dd_cons = restrictCons names cons }
+ | otherwise -- Newtype
+ = case restrictCons names cons of
+ [] -> defn { dd_ND = DataType, dd_cons = [] }
+ [con] -> defn { dd_cons = [con] }
+ _ -> error "Should not happen"
+
+restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
+restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
+ where
+ keep d | unLoc (con_name d) `elem` names =
+ case con_details d of
+ PrefixCon _ -> Just d
+ RecCon fields
+ | all field_avail fields -> Just d
+ | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })
+ -- if we have *all* the field names available, then
+ -- keep the record declaration. Otherwise degrade to
+ -- a constructor declaration. This isn't quite right, but
+ -- it's the best we can do.
+ InfixCon _ _ -> Just d
+ where
+ field_avail (ConDeclField n _ _) = unLoc n `elem` names
+ field_types flds = [ t | ConDeclField _ t _ <- flds ]
+
+ keep _ = Nothing
+
+
+restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
+restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
+
+
+restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
+restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
+
+emptyHsQTvs :: LHsTyVarBndrs Name
+-- This function is here, rather than in HsTypes, because it *renamed*, but
+-- does not necessarily have all the rigt kind variables. It is used
+-- in Haddock just for printing, so it doesn't matter
+emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
+
+
+--------------------------------------------------------------------------------
+-- * Filename mangling functions stolen from s main/DriverUtil.lhs.
+--------------------------------------------------------------------------------
+
+
+baseName :: ModuleName -> FilePath
+baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
+
+
+moduleHtmlFile :: Module -> FilePath
+moduleHtmlFile mdl =
+ case Map.lookup mdl html_xrefs of
+ Nothing -> baseName mdl' ++ ".html"
+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"]
+ where
+ mdl' = moduleName mdl
+
+
+moduleHtmlFile' :: ModuleName -> FilePath
+moduleHtmlFile' mdl =
+ case Map.lookup mdl html_xrefs' of
+ Nothing -> baseName mdl ++ ".html"
+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]
+
+
+contentsHtmlFile, indexHtmlFile :: String
+contentsHtmlFile = "index.html"
+indexHtmlFile = "doc-index.html"
+
+
+-- | The name of the module index file to be displayed inside a frame.
+-- Modules are display in full, but without indentation. Clicking opens in
+-- the main window.
+frameIndexHtmlFile :: String
+frameIndexHtmlFile = "index-frames.html"
+
+
+moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
+moduleIndexFrameName = "modules"
+mainFrameName = "main"
+synopsisFrameName = "synopsis"
+
+
+subIndexHtmlFile :: String -> String
+subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
+ where b | all isAlpha ls = ls
+ | otherwise = concatMap (show . ord) ls
+
+
+-------------------------------------------------------------------------------
+-- * Anchor and URL utilities
+--
+-- NB: Anchor IDs, used as the destination of a link within a document must
+-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's
+-- various needs and compatibility constraints, means these IDs have to match:
+-- [A-Za-z][A-Za-z0-9:_.-]*
+-- Such IDs do not need to be escaped in any way when used as the fragment part
+-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it
+-- isn't clear if such fragment identifiers should, or should not be unescaped
+-- before being matched with IDs in the target document.
+-------------------------------------------------------------------------------
+
+
+moduleUrl :: Module -> String
+moduleUrl = moduleHtmlFile
+
+
+moduleNameUrl :: Module -> OccName -> String
+moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n
+
+
+moduleNameUrl' :: ModuleName -> OccName -> String
+moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n
+
+
+nameAnchorId :: OccName -> String
+nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)
+ where prefix | isValOcc name = 'v'
+ | otherwise = 't'
+
+
+-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
+-- identity preserving.
+makeAnchorId :: String -> String
+makeAnchorId [] = []
+makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
+ where
+ escape p c | p c = [c]
+ | otherwise = '-' : show (ord c) ++ "-"
+ isLegal ':' = True
+ isLegal '_' = True
+ isLegal '.' = True
+ isLegal c = isAscii c && isAlphaNum c
+ -- NB: '-' is legal in IDs, but we use it as the escape char
+
+
+-------------------------------------------------------------------------------
+-- * Files we need to copy from our $libdir
+-------------------------------------------------------------------------------
+
+
+jsFile, framesFile :: String
+jsFile = "haddock-util.js"
+framesFile = "frames.html"
+
+
+-------------------------------------------------------------------------------
+-- * Misc.
+-------------------------------------------------------------------------------
+
+
+getProgramName :: IO String
+getProgramName = liftM (`withoutSuffix` ".bin") getProgName
+ where str `withoutSuffix` suff
+ | suff `isSuffixOf` str = take (length str - length suff) str
+ | otherwise = str
+
+
+bye :: String -> IO a
+bye s = putStr s >> exitSuccess
+
+
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
+
+
+dieMsg :: String -> IO a
+dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
+
+
+noDieMsg :: String -> IO ()
+noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
+
+
+mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
+mapSnd _ [] = []
+mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
+
+
+mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
+mapMaybeM _ Nothing = return Nothing
+mapMaybeM f (Just a) = liftM Just (f a)
+
+
+escapeStr :: String -> String
+escapeStr = escapeURIString isUnreserved
+
+
+-- Following few functions are copy'n'pasted from Network.URI module
+-- to avoid depending on the network lib, since doing so gives a
+-- circular build dependency between haddock and network
+-- (at least if you want to build network with haddock docs)
+escapeURIChar :: (Char -> Bool) -> Char -> String
+escapeURIChar p c
+ | p c = [c]
+ | otherwise = '%' : myShowHex (ord c) ""
+ where
+ myShowHex :: Int -> ShowS
+ myShowHex n r = case showIntAtBase 16 toChrHex n r of
+ [] -> "00"
+ [a] -> ['0',a]
+ cs -> cs
+ toChrHex d
+ | d < 10 = chr (ord '0' + fromIntegral d)
+ | otherwise = chr (ord 'A' + fromIntegral (d - 10))
+
+
+escapeURIString :: (Char -> Bool) -> String -> String
+escapeURIString = concatMap . escapeURIChar
+
+
+isUnreserved :: Char -> Bool
+isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")
+
+
+isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool
+isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
+isDigitChar c = c >= '0' && c <= '9'
+isAlphaNumChar c = isAlphaChar c || isDigitChar c
+
+
+-----------------------------------------------------------------------------
+-- * HTML cross references
+--
+-- For each module, we need to know where its HTML documentation lives
+-- so that we can point hyperlinks to it. It is extremely
+-- inconvenient to plumb this information to all the places that need
+-- it (basically every function in HaddockHtml), and furthermore the
+-- mapping is constant for any single run of Haddock. So for the time
+-- being I'm going to use a write-once global variable.
+-----------------------------------------------------------------------------
+
+
+{-# NOINLINE html_xrefs_ref #-}
+html_xrefs_ref :: IORef (Map Module FilePath)
+html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
+
+
+{-# NOINLINE html_xrefs_ref' #-}
+html_xrefs_ref' :: IORef (Map ModuleName FilePath)
+html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map"))
+
+
+{-# NOINLINE html_xrefs #-}
+html_xrefs :: Map Module FilePath
+html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
+
+
+{-# NOINLINE html_xrefs' #-}
+html_xrefs' :: Map ModuleName FilePath
+html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref')
+
+
+-----------------------------------------------------------------------------
+-- * List utils
+-----------------------------------------------------------------------------
+
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace a b = map (\x -> if x == a then b else x)
+
+
+spanWith :: (a -> Maybe b) -> [a] -> ([b],[a])
+spanWith _ [] = ([],[])
+spanWith p xs@(a:as)
+ | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)
+ | otherwise = ([],xs)
+
+
+-----------------------------------------------------------------------------
+-- * Put here temporarily
+-----------------------------------------------------------------------------
+
+
+markup :: DocMarkup id a -> Doc id -> a
+markup m DocEmpty = markupEmpty m
+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s) = markupString m s
+markup m (DocParagraph d) = markupParagraph m (markup m d)
+markup m (DocIdentifier x) = markupIdentifier m x
+markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
+markup m (DocModule mod0) = markupModule m mod0
+markup m (DocWarning d) = markupWarning m (markup m d)
+markup m (DocEmphasis d) = markupEmphasis m (markup m d)
+markup m (DocBold d) = markupBold m (markup m d)
+markup m (DocMonospaced d) = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (DocHyperlink l) = markupHyperlink m l
+markup m (DocAName ref) = markupAName m ref
+markup m (DocPic img) = markupPic m img
+markup m (DocProperty p) = markupProperty m p
+markup m (DocExamples e) = markupExample m e
+markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))
+
+
+markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
+markupPair m (a,b) = (markup m a, markup m b)
+
+
+-- | The identity markup
+idMarkup :: DocMarkup a (Doc a)
+idMarkup = Markup {
+ markupEmpty = DocEmpty,
+ markupString = DocString,
+ markupParagraph = DocParagraph,
+ markupAppend = DocAppend,
+ markupIdentifier = DocIdentifier,
+ markupIdentifierUnchecked = DocIdentifierUnchecked,
+ markupModule = DocModule,
+ markupWarning = DocWarning,
+ markupEmphasis = DocEmphasis,
+ markupBold = DocBold,
+ markupMonospaced = DocMonospaced,
+ markupUnorderedList = DocUnorderedList,
+ markupOrderedList = DocOrderedList,
+ markupDefList = DocDefList,
+ markupCodeBlock = DocCodeBlock,
+ markupHyperlink = DocHyperlink,
+ markupAName = DocAName,
+ markupPic = DocPic,
+ markupProperty = DocProperty,
+ markupExample = DocExamples,
+ markupHeader = DocHeader
+ }
+
+
+-----------------------------------------------------------------------------
+-- * System tools
+-----------------------------------------------------------------------------
+
+
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
+#else
+getProcessID :: IO Int
+getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid
+#endif
diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs
new file mode 100644
index 00000000..2ef3a257
--- /dev/null
+++ b/haddock-api/src/Haddock/Version.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Version
+-- Copyright : (c) Simon Marlow 2003
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Version (
+ projectName, projectVersion, projectUrl
+) where
+
+#ifdef IN_GHC_TREE
+import Paths_haddock ( version )
+#else
+import Paths_haddock_api ( version )
+#endif
+import Data.Version ( showVersion )
+
+projectName :: String
+projectName = "Haddock"
+
+projectUrl :: String
+projectUrl = "http://www.haskell.org/haddock/"
+
+projectVersion :: String
+projectVersion = showVersion version
diff --git a/haddock-api/src/haddock.sh b/haddock-api/src/haddock.sh
new file mode 100644
index 00000000..f1ad0191
--- /dev/null
+++ b/haddock-api/src/haddock.sh
@@ -0,0 +1,7 @@
+# Mini-driver for Haddock
+
+# needs the following variables:
+# HADDOCKLIB
+# HADDOCKBIN
+
+$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}
diff --git a/haddock.cabal b/haddock.cabal
index 5932b122..a31deb3a 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -28,7 +28,7 @@ extra-source-files:
doc/haddock.xml
haddock.spec
haskell.vim
- src/haddock.sh
+ haddock-api/src/haddock.sh
html-test/src/*.hs
html-test/ref/*.html
latex-test/src/Simple/*.hs
diff --git a/src/Documentation/Haddock.hs b/src/Documentation/Haddock.hs
deleted file mode 100644
index 1ff5cf75..00000000
--- a/src/Documentation/Haddock.hs
+++ /dev/null
@@ -1,89 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Documentation.Haddock
--- Copyright : (c) David Waern 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskellorg
--- Stability : experimental
--- Portability : portable
---
--- The Haddock API: A rudimentory, highly experimental API exposing some of
--- the internals of Haddock. Don't expect it to be stable.
------------------------------------------------------------------------------
-module Documentation.Haddock (
-
- -- * Interface
- Interface(..),
- InstalledInterface(..),
- createInterfaces,
- processModules,
-
- -- * Export items & declarations
- ExportItem(..),
- DocForDecl,
- FnArgsDoc,
-
- -- * Cross-referencing
- LinkEnv,
- DocName(..),
-
- -- * Instances
- DocInstance,
- InstHead,
-
- -- * Documentation comments
- Doc,
- DocH(..),
- Example(..),
- Hyperlink(..),
- DocMarkup(..),
- Documentation(..),
- ArgMap,
- AliasMap,
- WarningMap,
- DocMap,
- HaddockModInfo(..),
- markup,
-
- -- * Interface files
- InterfaceFile(..),
- readInterfaceFile,
- nameCacheFromGhc,
- freshNameCache,
- NameCacheAccessor,
-
- -- * Flags and options
- Flag(..),
- DocOption(..),
-
- -- * Error handling
- HaddockException(..),
-
- -- * Program entry point
- haddock,
- haddockWithGhc,
- getGhcDirs,
- withGhc
-) where
-
-
-import Haddock.InterfaceFile
-import Haddock.Interface
-import Haddock.Types
-import Haddock.Options
-import Haddock.Utils
-import Haddock
-
-
--- | Create 'Interface' structures from a given list of Haddock command-line
--- flags and file or module names (as accepted by 'haddock' executable). Flags
--- that control documentation generation or show help or version information
--- are ignored.
-createInterfaces
- :: [Flag] -- ^ A list of command-line flags
- -> [String] -- ^ File or module names
- -> IO [Interface] -- ^ Resulting list of interfaces
-createInterfaces flags modules = do
- (_, ifaces, _) <- withGhc flags (readPackagesAndProcessModules flags modules)
- return ifaces
diff --git a/src/Haddock.hs b/src/Haddock.hs
deleted file mode 100644
index 0cff5bd3..00000000
--- a/src/Haddock.hs
+++ /dev/null
@@ -1,488 +0,0 @@
-{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
-{-# LANGUAGE LambdaCase #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2010,
--- Mateusz Kowalczyk 2014
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Haddock - A Haskell Documentation Tool
---
--- Program entry point and top-level code.
------------------------------------------------------------------------------
-module Haddock (
- haddock,
- haddockWithGhc,
- getGhcDirs,
- readPackagesAndProcessModules,
- withGhc
-) where
-
-import Haddock.Backends.Xhtml
-import Haddock.Backends.Xhtml.Themes (getThemes)
-import Haddock.Backends.LaTeX
-import Haddock.Backends.Hoogle
-import Haddock.Interface
-import Haddock.Parser
-import Haddock.Types
-import Haddock.Version
-import Haddock.InterfaceFile
-import Haddock.Options
-import Haddock.Utils
-import Haddock.GhcUtils hiding (pretty)
-
-import Control.Monad hiding (forM_)
-import Data.Foldable (forM_)
-import Data.List (isPrefixOf)
-import Control.Exception
-import Data.Maybe
-import Data.IORef
-import qualified Data.Map as Map
-import System.IO
-import System.Exit
-import System.Directory
-
-#if defined(mingw32_HOST_OS)
-import Foreign
-import Foreign.C
-import Data.Int
-#endif
-
-#ifdef IN_GHC_TREE
-import System.FilePath
-#else
-import qualified GHC.Paths as GhcPaths
-import Paths_haddock_api (getDataDir)
-#endif
-
-import GHC hiding (verbosity)
-import Config
-import DynFlags hiding (verbosity)
-import StaticFlags (discardStaticFlags)
-import Panic (handleGhcException)
-import Module
-
---------------------------------------------------------------------------------
--- * Exception handling
---------------------------------------------------------------------------------
-
-
-handleTopExceptions :: IO a -> IO a
-handleTopExceptions =
- handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions
-
-
--- | Either returns normally or throws an ExitCode exception;
--- all other exceptions are turned into exit exceptions.
-handleNormalExceptions :: IO a -> IO a
-handleNormalExceptions inner =
- (inner `onException` hFlush stdout)
- `catches`
- [ Handler (\(code :: ExitCode) -> exitWith code)
-
- , Handler (\(ex :: AsyncException) ->
- case ex of
- StackOverflow -> do
- putStrLn "stack overflow: use -g +RTS -K<size> to increase it"
- exitFailure
- _ -> do
- putStrLn ("haddock: " ++ show ex)
- exitFailure)
-
- , Handler (\(ex :: SomeException) -> do
- putStrLn ("haddock: internal error: " ++ show ex)
- exitFailure)
- ]
-
-
-handleHaddockExceptions :: IO a -> IO a
-handleHaddockExceptions inner =
- catches inner [Handler handler]
- where
- handler (e::HaddockException) = do
- putStrLn $ "haddock: " ++ show e
- exitFailure
-
-
-handleGhcExceptions :: IO a -> IO a
-handleGhcExceptions =
- -- error messages propagated as exceptions
- handleGhcException $ \e -> do
- hFlush stdout
- case e of
- PhaseFailed _ code -> exitWith code
- _ -> do
- print (e :: GhcException)
- exitFailure
-
-
--------------------------------------------------------------------------------
--- * Top level
--------------------------------------------------------------------------------
-
-
--- | Run Haddock with given list of arguments.
---
--- Haddock's own main function is defined in terms of this:
---
--- > main = getArgs >>= haddock
-haddock :: [String] -> IO ()
-haddock args = haddockWithGhc withGhc args
-
-haddockWithGhc :: (forall a. [Flag] -> Ghc a -> IO a) -> [String] -> IO ()
-haddockWithGhc ghc args = handleTopExceptions $ do
-
- -- Parse command-line flags and handle some of them initially.
- -- TODO: unify all of this (and some of what's in the 'render' function),
- -- into one function that returns a record with a field for each option,
- -- or which exits with an error or help message.
- (flags, files) <- parseHaddockOpts args
- shortcutFlags flags
- qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q}
-
- -- inject dynamic-too into flags before we proceed
- flags' <- ghc flags $ do
- df <- getDynFlags
- case lookup "GHC Dynamic" (compilerInfo df) of
- Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags
- _ -> return flags
-
- unless (Flag_NoWarnings `elem` flags) $ do
- forM_ (warnings args) $ \warning -> do
- hPutStrLn stderr warning
-
- ghc flags' $ do
-
- dflags <- getDynFlags
-
- if not (null files) then do
- (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
-
- -- Dump an "interface file" (.haddock file), if requested.
- forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do
- writeInterfaceFile path InterfaceFile {
- ifInstalledIfaces = map toInstalledIface ifaces
- , ifLinkEnv = homeLinks
- }
-
- -- Render the interfaces.
- liftIO $ renderStep dflags flags qual packages ifaces
-
- else do
- when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
- throwE "No input file(s)."
-
- -- Get packages supplied with --read-interface.
- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
-
- -- Render even though there are no input files (usually contents/index).
- liftIO $ renderStep dflags flags qual packages []
-
--- | Create warnings about potential misuse of -optghc
-warnings :: [String] -> [String]
-warnings = map format . filter (isPrefixOf "-optghc")
- where
- format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"]
-
-
-withGhc :: [Flag] -> Ghc a -> IO a
-withGhc flags action = do
- libDir <- fmap snd (getGhcDirs flags)
-
- -- Catches all GHC source errors, then prints and re-throws them.
- let handleSrcErrors action' = flip handleSourceError action' $ \err -> do
- printException err
- liftIO exitFailure
-
- withGhc' libDir (ghcFlags flags) (\_ -> handleSrcErrors action)
-
-
-readPackagesAndProcessModules :: [Flag] -> [String]
- -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
-readPackagesAndProcessModules flags files = do
- -- Get packages supplied with --read-interface.
- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
-
- -- Create the interfaces -- this is the core part of Haddock.
- let ifaceFiles = map snd packages
- (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
-
- return (packages, ifaces, homeLinks)
-
-
-renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep dflags flags qual pkgs interfaces = do
- updateHTMLXRefs pkgs
- let
- ifaceFiles = map snd pkgs
- installedIfaces = concatMap ifInstalledIfaces ifaceFiles
- srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
- render dflags flags qual interfaces installedIfaces srcMap
-
-
--- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render dflags flags qual ifaces installedIfaces srcMap = do
-
- let
- title = fromMaybe "" (optTitle flags)
- unicode = Flag_UseUnicode `elem` flags
- pretty = Flag_PrettyHtml `elem` flags
- opt_wiki_urls = wikiUrls flags
- opt_contents_url = optContentsUrl flags
- opt_index_url = optIndexUrl flags
- odir = outputDir flags
- opt_latex_style = optLaTeXStyle flags
-
- visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
-
- -- /All/ visible interfaces including external package modules.
- allIfaces = map toInstalledIface ifaces ++ installedIfaces
- allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
-
- pkgMod = ifaceMod (head ifaces)
- pkgId = modulePackageId pkgMod
- pkgStr = Just (packageIdString pkgId)
- (pkgName,pkgVer) = modulePackageInfo pkgMod
-
- (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
- srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity
- -- TODO: Get these from the interface files as with srcMap
- srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity
- sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
-
- libDir <- getHaddockLibDir flags
- prologue <- getPrologue dflags flags
- themes <- getThemes libDir flags >>= either bye return
-
- when (Flag_GenIndex `elem` flags) $ do
- ppHtmlIndex odir title pkgStr
- themes opt_contents_url sourceUrls' opt_wiki_urls
- allVisibleIfaces pretty
- copyHtmlBits odir libDir themes
-
- when (Flag_GenContents `elem` flags) $ do
- ppHtmlContents odir title pkgStr
- themes opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty
- (makeContentsQual qual)
- copyHtmlBits odir libDir themes
-
- when (Flag_Html `elem` flags) $ do
- ppHtml title pkgStr visibleIfaces odir
- prologue
- themes sourceUrls' opt_wiki_urls
- opt_contents_url opt_index_url unicode qual
- pretty
- copyHtmlBits odir libDir themes
-
- when (Flag_Hoogle `elem` flags) $ do
- let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
- ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
-
- when (Flag_LaTeX `elem` flags) $ do
- ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
- libDir
-
-
--------------------------------------------------------------------------------
--- * Reading and dumping interface files
--------------------------------------------------------------------------------
-
-
-readInterfaceFiles :: MonadIO m
- => NameCacheAccessor m
- -> [(DocPaths, FilePath)]
- -> m [(DocPaths, InterfaceFile)]
-readInterfaceFiles name_cache_accessor pairs = do
- catMaybes `liftM` mapM tryReadIface pairs
- where
- -- try to read an interface, warn if we can't
- tryReadIface (paths, file) =
- readInterfaceFile name_cache_accessor file >>= \case
- Left err -> liftIO $ do
- putStrLn ("Warning: Cannot read " ++ file ++ ":")
- putStrLn (" " ++ err)
- putStrLn "Skipping this interface."
- return Nothing
- Right f -> return $ Just (paths, f)
-
-
--------------------------------------------------------------------------------
--- * Creating a GHC session
--------------------------------------------------------------------------------
-
-
--- | Start a GHC session with the -haddock flag set. Also turn off
--- compilation and linking. Then run the given 'Ghc' action.
-withGhc' :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
-withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do
- dynflags <- getSessionDynFlags
- dynflags' <- parseGhcFlags (gopt_set dynflags Opt_Haddock) {
- hscTarget = HscNothing,
- ghcMode = CompManager,
- ghcLink = NoLink
- }
- let dynflags'' = gopt_unset dynflags' Opt_SplitObjs
- defaultCleanupHandler dynflags'' $ do
- -- ignore the following return-value, which is a list of packages
- -- that may need to be re-linked: Haddock doesn't do any
- -- dynamic or static linking at all!
- _ <- setSessionDynFlags dynflags''
- ghcActs dynflags''
- where
- parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
- parseGhcFlags dynflags = do
- -- TODO: handle warnings?
-
- -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot
- -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if
- -- we pass any, Haddock will fail. Since StaticFlags are global to the
- -- GHC invocation, there's also no way to reparse/save them to set them
- -- again properly.
- --
- -- This is a bit of a hack until we get rid of the rest of the remaining
- -- StaticFlags. See GHC issue #8276.
- let flags' = discardStaticFlags flags
- (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
- if not (null rest)
- then throwE ("Couldn't parse GHC options: " ++ unwords flags')
- else return dynflags'
-
--------------------------------------------------------------------------------
--- * Misc
--------------------------------------------------------------------------------
-
-
-getHaddockLibDir :: [Flag] -> IO String
-getHaddockLibDir flags =
- case [str | Flag_Lib str <- flags] of
- [] -> do
-#ifdef IN_GHC_TREE
- getInTreeDir
-#else
- d <- getDataDir -- provided by Cabal
- doesDirectoryExist d >>= \exists -> case exists of
- True -> return d
- False -> do
- -- If directory does not exist then we are probably invoking from
- -- ./dist/build/haddock/haddock so we use ./resources as a fallback.
- doesDirectoryExist "resources" >>= \exists_ -> case exists_ of
- True -> return "resources"
- False -> die ("Haddock's resource directory (" ++ d ++ ") does not exist!\n")
-#endif
- fs -> return (last fs)
-
-
-getGhcDirs :: [Flag] -> IO (String, String)
-getGhcDirs flags = do
- case [ dir | Flag_GhcLibDir dir <- flags ] of
- [] -> do
-#ifdef IN_GHC_TREE
- libDir <- getInTreeDir
- return (ghcPath, libDir)
-#else
- return (ghcPath, GhcPaths.libdir)
-#endif
- xs -> return (ghcPath, last xs)
- where
-#ifdef IN_GHC_TREE
- ghcPath = "not available"
-#else
- ghcPath = GhcPaths.ghc
-#endif
-
-
-shortcutFlags :: [Flag] -> IO ()
-shortcutFlags flags = do
- usage <- getUsage
-
- when (Flag_Help `elem` flags) (bye usage)
- when (Flag_Version `elem` flags) byeVersion
- when (Flag_InterfaceVersion `elem` flags) (bye (show binaryInterfaceVersion ++ "\n"))
- when (Flag_CompatibleInterfaceVersions `elem` flags)
- (bye (unwords (map show binaryInterfaceVersionCompatibility) ++ "\n"))
- when (Flag_GhcVersion `elem` flags) (bye (cProjectVersion ++ "\n"))
-
- when (Flag_PrintGhcPath `elem` flags) $ do
- dir <- fmap fst (getGhcDirs flags)
- bye $ dir ++ "\n"
-
- when (Flag_PrintGhcLibDir `elem` flags) $ do
- dir <- fmap snd (getGhcDirs flags)
- bye $ dir ++ "\n"
-
- when (Flag_UseUnicode `elem` flags && Flag_Html `notElem` flags) $
- throwE "Unicode can only be enabled for HTML output."
-
- when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
- && Flag_Html `elem` flags) $
- throwE "-h cannot be used with --gen-index or --gen-contents"
-
- when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
- && Flag_Hoogle `elem` flags) $
- throwE "--hoogle cannot be used with --gen-index or --gen-contents"
-
- when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
- && Flag_LaTeX `elem` flags) $
- throwE "--latex cannot be used with --gen-index or --gen-contents"
- where
- byeVersion = bye $
- "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"
- ++ "Ported to use the GHC API by David Waern 2006-2008\n"
-
-
-updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
-updateHTMLXRefs packages = do
- writeIORef html_xrefs_ref (Map.fromList mapping)
- writeIORef html_xrefs_ref' (Map.fromList mapping')
- where
- mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
- , iface <- ifInstalledIfaces ifaces ]
- mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
-
-
-getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))
-getPrologue dflags flags =
- case [filename | Flag_Prologue filename <- flags ] of
- [] -> return Nothing
- [filename] -> withFile filename ReadMode $ \h -> do
- hSetEncoding h utf8
- str <- hGetContents h
- return . Just $ parseParas dflags str
- _ -> throwE "multiple -p/--prologue options"
-
-
-#ifdef IN_GHC_TREE
-
-getInTreeDir :: IO String
-getInTreeDir = getExecDir >>= \case
- Nothing -> error "No GhcDir found"
- Just d -> return (d </> ".." </> "lib")
-
-
-getExecDir :: IO (Maybe String)
-#if defined(mingw32_HOST_OS)
-getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
- where
- try_size size = allocaArray (fromIntegral size) $ \buf -> do
- ret <- c_GetModuleFileName nullPtr buf size
- case ret of
- 0 -> return Nothing
- _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf
- | otherwise -> try_size (size * 2)
-
-foreign import stdcall unsafe "windows.h GetModuleFileNameW"
- c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
-#else
-getExecDir = return Nothing
-#endif
-
-#endif
diff --git a/src/Haddock/Backends/HaddockDB.hs b/src/Haddock/Backends/HaddockDB.hs
deleted file mode 100644
index 1c248bfb..00000000
--- a/src/Haddock/Backends/HaddockDB.hs
+++ /dev/null
@@ -1,170 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.HaddockDB
--- Copyright : (c) Simon Marlow 2003
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.HaddockDB (ppDocBook) where
-
-{-
-import HaddockTypes
-import HaddockUtil
-import HsSyn2
-
-import Text.PrettyPrint
--}
-
------------------------------------------------------------------------------
--- Printing the results in DocBook format
-
-ppDocBook :: a
-ppDocBook = error "not working"
-{-
-ppDocBook :: FilePath -> [(Module, Interface)] -> String
-ppDocBook odir mods = render (ppIfaces mods)
-
-ppIfaces mods
- = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
- $$ text "]>"
- $$ text "<book>"
- $$ text "<bookinfo>"
- $$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
- $$ text "</bookinfo>"
- $$ text "<article>"
- $$ vcat (map do_mod mods)
- $$ text "</article></book>"
- where
- do_mod (Module mod, iface)
- = text "<sect1 id=\"sec-" <> text mod <> text "\">"
- $$ text "<title><literal>"
- <> text mod
- <> text "</literal></title>"
- $$ text "<indexterm><primary><literal>"
- <> text mod
- <> text "</literal></primary></indexterm>"
- $$ text "<variablelist>"
- $$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
- $$ text "</variablelist>"
- $$ text "</sect1>"
-
- do_export mod decl | (nm:_) <- declBinders decl
- = text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
- $$ text "<term><literal>"
- <> do_decl decl
- <> text "</literal></term>"
- $$ text "<listitem>"
- $$ text "<para>"
- $$ text "</para>"
- $$ text "</listitem>"
- $$ text "</varlistentry>"
- do_export _ _ = empty
-
- do_decl (HsTypeSig _ [nm] ty _)
- = ppHsName nm <> text " :: " <> ppHsType ty
- do_decl (HsTypeDecl _ nm args ty _)
- = hsep ([text "type", ppHsName nm ]
- ++ map ppHsName args
- ++ [equals, ppHsType ty])
- do_decl (HsNewTypeDecl loc ctx nm args con drv _)
- = hsep ([text "data", ppHsName nm] -- data, not newtype
- ++ map ppHsName args
- ) <+> equals <+> ppHsConstr con -- ToDo: derivings
- do_decl (HsDataDecl loc ctx nm args cons drv _)
- = hsep ([text "data", {-ToDo: context-}ppHsName nm]
- ++ map ppHsName args)
- <+> vcat (zipWith (<+>) (equals : repeat (char '|'))
- (map ppHsConstr cons))
- do_decl (HsClassDecl loc ty fds decl _)
- = hsep [text "class", ppHsType ty]
- do_decl decl
- = empty
-
-ppHsConstr :: HsConDecl -> Doc
-ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
- ppHsName name
- <> (braces . hsep . punctuate comma . map ppField $ fieldList)
-ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
- hsep (ppHsName name : map ppHsBangType typeList)
-
-ppField (HsFieldDecl ns ty doc)
- = hsep (punctuate comma (map ppHsName ns) ++
- [text "::", ppHsBangType ty])
-
-ppHsBangType :: HsBangType -> Doc
-ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty
-ppHsBangType (HsUnBangedTy ty) = ppHsType ty
-
-ppHsContext :: HsContext -> Doc
-ppHsContext [] = empty
-ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
- hsep (map ppHsAType b)) context)
-
-ppHsType :: HsType -> Doc
-ppHsType (HsForAllType Nothing context htype) =
- hsep [ ppHsContext context, text "=>", ppHsType htype]
-ppHsType (HsForAllType (Just tvs) [] htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
-ppHsType (HsForAllType (Just tvs) context htype) =
- hsep (text "forall" : map ppHsName tvs ++ text "." :
- ppHsContext context : text "=>" : [ppHsType htype])
-ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]
-ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t]
-ppHsType t = ppHsBType t
-
-ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
- = brackets $ ppHsType b
-ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
-ppHsBType t = ppHsAType t
-
-ppHsAType :: HsType -> Doc
-ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l
-ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
--- special case
-ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
- = brackets $ ppHsType b
-ppHsAType (HsTyVar name) = ppHsName name
-ppHsAType (HsTyCon name) = ppHsQName name
-ppHsAType t = parens $ ppHsType t
-
-ppHsQName :: HsQName -> Doc
-ppHsQName (UnQual str) = ppHsName str
-ppHsQName n@(Qual (Module mod) str)
- | n == unit_con_name = ppHsName str
- | isSpecial str = ppHsName str
- | otherwise
- = text "<link linkend=" <> ppLinkId mod str <> char '>'
- <> ppHsName str
- <> text "</link>"
-
-isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
-isSpecial (HsVarName id) | HsSpecial _ <- id = True
-isSpecial _ = False
-
-ppHsName :: HsName -> Doc
-ppHsName (HsTyClsName id) = ppHsIdentifier id
-ppHsName (HsVarName id) = ppHsIdentifier id
-
-ppHsIdentifier :: HsIdentifier -> Doc
-ppHsIdentifier (HsIdent str) = text str
-ppHsIdentifier (HsSymbol str) = text str
-ppHsIdentifier (HsSpecial str) = text str
-
-ppLinkId :: String -> HsName -> Doc
-ppLinkId mod str
- = hcat [char '\"', text mod, char '.', ppHsName str, char '\"']
-
--- -----------------------------------------------------------------------------
--- * Misc
-
-parenList :: [Doc] -> Doc
-parenList = parens . fsep . punctuate comma
-
-ubxParenList :: [Doc] -> Doc
-ubxParenList = ubxparens . fsep . punctuate comma
-
-ubxparens p = text "(#" <> p <> text "#)"
--}
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
deleted file mode 100644
index 628e1cd0..00000000
--- a/src/Haddock/Backends/Hoogle.hs
+++ /dev/null
@@ -1,331 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Hoogle
--- Copyright : (c) Neil Mitchell 2006-2008
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Write out Hoogle compatible documentation
--- http://www.haskell.org/hoogle/
------------------------------------------------------------------------------
-module Haddock.Backends.Hoogle (
- ppHoogle
- ) where
-
-
-import Haddock.GhcUtils
-import Haddock.Types
-import Haddock.Utils hiding (out)
-import GHC
-import Outputable
-
-import Data.Char
-import Data.List
-import Data.Maybe
-import System.FilePath
-import System.IO
-
-prefix :: [String]
-prefix = ["-- Hoogle documentation, generated by Haddock"
- ,"-- See Hoogle, http://www.haskell.org/hoogle/"
- ,""]
-
-
-ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle dflags package version synopsis prologue ifaces odir = do
- let filename = package ++ ".txt"
- contents = prefix ++
- docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
- ["@package " ++ package] ++
- ["@version " ++ version | version /= ""] ++
- concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
- h <- openFile (odir </> filename) WriteMode
- hSetEncoding h utf8
- hPutStr h (unlines contents)
- hClose h
-
-ppModule :: DynFlags -> Interface -> [String]
-ppModule dflags iface =
- "" : ppDocumentation dflags (ifaceDoc iface) ++
- ["module " ++ moduleString (ifaceMod iface)] ++
- concatMap (ppExport dflags) (ifaceExportItems iface) ++
- concatMap (ppInstance dflags) (ifaceInstances iface)
-
-
----------------------------------------------------------------------
--- Utility functions
-
-dropHsDocTy :: HsType a -> HsType a
-dropHsDocTy = f
- where
- g (L src x) = L src (f x)
- f (HsForAllTy a b c d) = HsForAllTy a b c (g d)
- f (HsBangTy a b) = HsBangTy a (g b)
- f (HsAppTy a b) = HsAppTy (g a) (g b)
- f (HsFunTy a b) = HsFunTy (g a) (g b)
- f (HsListTy a) = HsListTy (g a)
- f (HsPArrTy a) = HsPArrTy (g a)
- f (HsTupleTy a b) = HsTupleTy a (map g b)
- f (HsOpTy a b c) = HsOpTy (g a) b (g c)
- f (HsParTy a) = HsParTy (g a)
- f (HsKindSig a b) = HsKindSig (g a) b
- f (HsDocTy a _) = f $ unL a
- f x = x
-
-outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
-outHsType dflags = out dflags . dropHsDocTy
-
-
-makeExplicit :: HsType a -> HsType a
-makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c
-makeExplicit x = x
-
-makeExplicitL :: LHsType a -> LHsType a
-makeExplicitL (L src x) = L src (makeExplicit x)
-
-
-dropComment :: String -> String
-dropComment (' ':'-':'-':' ':_) = []
-dropComment (x:xs) = x : dropComment xs
-dropComment [] = []
-
-
-out :: Outputable a => DynFlags -> a -> String
-out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
- where
- f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
- f (x:xs) = x : f xs
- f [] = []
-
-
-operator :: String -> String
-operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")"
-operator x = x
-
-
----------------------------------------------------------------------
--- How to print each export
-
-ppExport :: DynFlags -> ExportItem Name -> [String]
-ppExport dflags ExportDecl { expItemDecl = L _ decl
- , expItemMbDoc = (dc, _)
- , expItemSubDocs = subdocs
- } = ppDocumentation dflags dc ++ f decl
- where
- f (TyClD d@DataDecl{}) = ppData dflags d subdocs
- f (TyClD d@SynDecl{}) = ppSynonym dflags d
- f (TyClD d@ClassDecl{}) = ppClass dflags d
- f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
- f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
- f (SigD sig) = ppSig dflags sig
- f _ = []
-ppExport _ _ = []
-
-
-ppSig :: DynFlags -> Sig Name -> [String]
-ppSig dflags (TypeSig names sig)
- = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
- where
- prettyNames = intercalate ", " $ map (out dflags) names
- typ = case unL sig of
- HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
- x -> x
-ppSig _ _ = []
-
-
--- note: does not yet output documentation for class methods
-ppClass :: DynFlags -> TyClDecl Name -> [String]
-ppClass dflags x = out dflags x{tcdSigs=[]} :
- concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
- where
- addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
- addContext (MinimalSig sig) = MinimalSig sig
- addContext _ = error "expected TypeSig"
-
- f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d
- f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)
-
- context = nlHsTyConApp (tcdName x)
- (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))
-
-
-ppInstance :: DynFlags -> ClsInst -> [String]
-ppInstance dflags x = [dropComment $ out dflags x]
-
-
-ppSynonym :: DynFlags -> TyClDecl Name -> [String]
-ppSynonym dflags x = [out dflags x]
-
-ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
- = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} :
- concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
- where
-
- -- GHC gives out "data Bar =", we want to delete the equals
- -- also writes data : a b, when we want data (:) a b
- showData d = unwords $ map f $ if last xs == "=" then init xs else xs
- where
- xs = words $ out dflags d
- nam = out dflags $ tyClDeclLName d
- f w = if w == nam then operator nam else w
-ppData _ _ _ = panic "ppData"
-
--- | for constructors, and named-fields...
-lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]
-lookupCon dflags subdocs (L _ name) = case lookup name subdocs of
- Just (d, _) -> ppDocumentation dflags d
- _ -> []
-
-ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con)
- ++ f (con_details con)
- where
- f (PrefixCon args) = [typeSig name $ args ++ [resType]]
- f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
- f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
- [lookupCon dflags subdocs (cd_fld_name r) ++
- [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
- | r <- recs]
-
- funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
- apps = foldl1 (\x y -> reL $ HsAppTy x y)
-
- typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
- name = out dflags $ unL $ con_name con
-
- resType = case con_res con of
- ResTyH98 -> apps $ map (reL . HsTyVar) $
- (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]
- ResTyGADT x -> x
-
-
----------------------------------------------------------------------
--- DOCUMENTATION
-
-ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]
-ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w
-
-
-doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
-doc dflags = docWith dflags ""
-
-
-docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]
-docWith _ [] Nothing = []
-docWith dflags header d
- = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $
- [header | header /= ""] ++ ["" | header /= "" && isJust d] ++
- maybe [] (showTags . markup (markupTag dflags)) d
-
-
-data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
- deriving Show
-
-type Tags = [Tag]
-
-box :: (a -> b) -> a -> [b]
-box f x = [f x]
-
-str :: String -> [Tag]
-str a = [Str a]
-
--- want things like paragraph, pre etc to be handled by blank lines in the source document
--- and things like \n and \t converted away
--- much like blogger in HTML mode
--- everything else wants to be included as tags, neatly nested for some (ul,li,ol)
--- or inlne for others (a,i,tt)
--- entities (&,>,<) should always be appropriately escaped
-
-markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]
-markupTag dflags = Markup {
- markupParagraph = box TagP,
- markupEmpty = str "",
- markupString = str,
- markupAppend = (++),
- markupIdentifier = box (TagInline "a") . str . out dflags,
- markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd,
- markupModule = box (TagInline "a") . str,
- markupWarning = box (TagInline "i"),
- markupEmphasis = box (TagInline "i"),
- markupBold = box (TagInline "b"),
- markupMonospaced = box (TagInline "tt"),
- markupPic = const $ str " ",
- markupUnorderedList = box (TagL 'u'),
- markupOrderedList = box (TagL 'o'),
- markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
- markupCodeBlock = box TagPre,
- markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel),
- markupAName = const $ str "",
- markupProperty = box TagPre . str,
- markupExample = box TagPre . str . unlines . map exampleToString,
- markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h
- }
-
-
-showTags :: [Tag] -> [String]
-showTags = intercalate [""] . map showBlock
-
-
-showBlock :: Tag -> [String]
-showBlock (TagP xs) = showInline xs
-showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"]
- where mid = concatMap (showInline . box (TagInline "li")) xs
-showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"]
-showBlock x = showInline [x]
-
-
-asInline :: Tag -> Tags
-asInline (TagP xs) = xs
-asInline (TagPre xs) = [TagInline "pre" xs]
-asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs]
-asInline x = [x]
-
-
-showInline :: [Tag] -> [String]
-showInline = unwordsWrap 70 . words . concatMap f
- where
- fs = concatMap f
- f (Str x) = escape x
- f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">"
- f x = fs $ asInline x
-
- trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
-
-
-showPre :: [Tag] -> [String]
-showPre = trimFront . trimLines . lines . concatMap f
- where
- trimLines = dropWhile null . reverse . dropWhile null . reverse
- trimFront xs = map (drop i) xs
- where
- ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""]
- i = if null ns then 0 else minimum ns
-
- fs = concatMap f
- f (Str x) = escape x
- f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">"
- f x = fs $ asInline x
-
-
-unwordsWrap :: Int -> [String] -> [String]
-unwordsWrap n = f n []
- where
- f _ s [] = [g s | s /= []]
- f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs
- | otherwise = f (i - nx - 1) (x:s) xs
- where nx = length x
-
- g = unwords . reverse
-
-
-escape :: String -> String
-escape = concatMap f
- where
- f '<' = "<"
- f '>' = ">"
- f '&' = "&"
- f x = [x]
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
deleted file mode 100644
index 7b72c030..00000000
--- a/src/Haddock/Backends/LaTeX.hs
+++ /dev/null
@@ -1,1221 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.LaTeX
--- Copyright : (c) Simon Marlow 2010,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.LaTeX (
- ppLaTeX
-) where
-
-
-import Haddock.Types
-import Haddock.Utils
-import Haddock.GhcUtils
-import Pretty hiding (Doc, quote)
-import qualified Pretty
-
-import GHC
-import OccName
-import Name ( nameOccName )
-import RdrName ( rdrNameOcc )
-import FastString ( unpackFS, unpackLitString, zString )
-
-import qualified Data.Map as Map
-import System.Directory
-import System.FilePath
-import Data.Char
-import Control.Monad
-import Data.Maybe
-import Data.List
-
-import Haddock.Doc (combineDocumentation)
-
--- import Debug.Trace
-
-{- SAMPLE OUTPUT
-
-\haddockmoduleheading{\texttt{Data.List}}
-\hrulefill
-{\haddockverb\begin{verbatim}
-module Data.List (
- (++), head, last, tail, init, null, length, map, reverse,
- ) where\end{verbatim}}
-\hrulefill
-
-\section{Basic functions}
-\begin{haddockdesc}
-\item[\begin{tabular}{@{}l}
-head\ ::\ {\char 91}a{\char 93}\ ->\ a
-\end{tabular}]\haddockbegindoc
-Extract the first element of a list, which must be non-empty.
-\par
-
-\end{haddockdesc}
-\begin{haddockdesc}
-\item[\begin{tabular}{@{}l}
-last\ ::\ {\char 91}a{\char 93}\ ->\ a
-\end{tabular}]\haddockbegindoc
-Extract the last element of a list, which must be finite and non-empty.
-\par
-
-\end{haddockdesc}
--}
-
-
-{- TODO
- * don't forget fixity!!
--}
-
-ppLaTeX :: String -- Title
- -> Maybe String -- Package name
- -> [Interface]
- -> FilePath -- destination directory
- -> Maybe (Doc GHC.RdrName) -- prologue text, maybe
- -> Maybe String -- style file
- -> FilePath
- -> IO ()
-
-ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir
- = do
- createDirectoryIfMissing True odir
- when (isNothing maybe_style) $
- copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty)
- ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces
- mapM_ (ppLaTeXModule title odir) visible_ifaces
-
-
-haddockSty :: FilePath
-haddockSty = "haddock.sty"
-
-
-type LaTeX = Pretty.Doc
-
-
-ppLaTeXTop
- :: String
- -> Maybe String
- -> FilePath
- -> Maybe (Doc GHC.RdrName)
- -> Maybe String
- -> [Interface]
- -> IO ()
-
-ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do
-
- let tex = vcat [
- text "\\documentclass{book}",
- text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style),
- text "\\begin{document}",
- text "\\begin{titlepage}",
- text "\\begin{haddocktitle}",
- text doctitle,
- text "\\end{haddocktitle}",
- case prologue of
- Nothing -> empty
- Just d -> vcat [text "\\begin{haddockprologue}",
- rdrDocToLaTeX d,
- text "\\end{haddockprologue}"],
- text "\\end{titlepage}",
- text "\\tableofcontents",
- vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ],
- text "\\end{document}"
- ]
-
- mods = sort (map (moduleBasename.ifaceMod) ifaces)
-
- filename = odir </> (fromMaybe "haddock" packageStr <.> "tex")
-
- writeFile filename (show tex)
-
-
-ppLaTeXModule :: String -> FilePath -> Interface -> IO ()
-ppLaTeXModule _title odir iface = do
- createDirectoryIfMissing True odir
- let
- mdl = ifaceMod iface
- mdl_str = moduleString mdl
-
- exports = ifaceRnExportItems iface
-
- tex = vcat [
- text "\\haddockmoduleheading" <> braces (text mdl_str),
- text "\\label{module:" <> text mdl_str <> char '}',
- text "\\haddockbeginheader",
- verb $ vcat [
- text "module" <+> text mdl_str <+> lparen,
- text " " <> fsep (punctuate (text ", ") $
- map exportListItem $
- filter forSummary exports),
- text " ) where"
- ],
- text "\\haddockendheader" $$ text "",
- description,
- body
- ]
-
- description
- = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface
-
- body = processExports exports
- --
- writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex)
-
-
-string_txt :: TextDetails -> String -> String
-string_txt (Chr c) s = c:s
-string_txt (Str s1) s2 = s1 ++ s2
-string_txt (PStr s1) s2 = unpackFS s1 ++ s2
-string_txt (ZStr s1) s2 = zString s1 ++ s2
-string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2
-
-
-exportListItem :: ExportItem DocName -> LaTeX
-exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs }
- = sep (punctuate comma . map ppDocBinder $ declNames decl) <>
- case subdocs of
- [] -> empty
- _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))
-exportListItem (ExportNoDecl y [])
- = ppDocBinder y
-exportListItem (ExportNoDecl y subs)
- = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs)))
-exportListItem (ExportModule mdl)
- = text "module" <+> text (moduleString mdl)
-exportListItem _
- = error "exportListItem"
-
-
--- Deal with a group of undocumented exports together, to avoid lots
--- of blank vertical space between them.
-processExports :: [ExportItem DocName] -> LaTeX
-processExports [] = empty
-processExports (decl : es)
- | Just sig <- isSimpleSig decl
- = multiDecl [ ppTypeSig (map getName names) typ False
- | (names,typ) <- sig:sigs ] $$
- processExports es'
- where (sigs, es') = spanWith isSimpleSig es
-processExports (ExportModule mdl : es)
- = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$
- processExports es'
- where (mdls, es') = spanWith isExportModule es
-processExports (e : es) =
- processExport e $$ processExports es
-
-
-isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)
-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t)))
- , expItemMbDoc = (Documentation Nothing Nothing, argDocs) }
- | Map.null argDocs = Just (map unLoc lnames, t)
-isSimpleSig _ = Nothing
-
-
-isExportModule :: ExportItem DocName -> Maybe Module
-isExportModule (ExportModule m) = Just m
-isExportModule _ = Nothing
-
-
-processExport :: ExportItem DocName -> LaTeX
-processExport (ExportGroup lev _id0 doc)
- = ppDocGroup lev (docToLaTeX doc)
-processExport (ExportDecl decl doc subdocs insts fixities _splice)
- = ppDecl decl doc insts subdocs fixities
-processExport (ExportNoDecl y [])
- = ppDocName y
-processExport (ExportNoDecl y subs)
- = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs)))
-processExport (ExportModule mdl)
- = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing
-processExport (ExportDoc doc)
- = docToLaTeX doc
-
-
-ppDocGroup :: Int -> LaTeX -> LaTeX
-ppDocGroup lev doc = sec lev <> braces doc
- where sec 1 = text "\\section"
- sec 2 = text "\\subsection"
- sec 3 = text "\\subsubsection"
- sec _ = text "\\paragraph"
-
-
-declNames :: LHsDecl DocName -> [DocName]
-declNames (L _ decl) = case decl of
- TyClD d -> [tcdName d]
- SigD (TypeSig lnames _) -> map unLoc lnames
- SigD (PatSynSig lname _ _ _ _) -> [unLoc lname]
- ForD (ForeignImport (L _ n) _ _ _) -> [n]
- ForD (ForeignExport (L _ n) _ _ _) -> [n]
- _ -> error "declaration not supported by declNames"
-
-
-forSummary :: (ExportItem DocName) -> Bool
-forSummary (ExportGroup _ _ _) = False
-forSummary (ExportDoc _) = False
-forSummary _ = True
-
-
-moduleLaTeXFile :: Module -> FilePath
-moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex"
-
-
-moduleBasename :: Module -> FilePath
-moduleBasename mdl = map (\c -> if c == '.' then '-' else c)
- (moduleNameString (moduleName mdl))
-
-
--------------------------------------------------------------------------------
--- * Decls
--------------------------------------------------------------------------------
-
-
-ppDecl :: LHsDecl DocName
- -> DocForDecl DocName
- -> [DocInstance DocName]
- -> [(DocName, DocForDecl DocName)]
- -> [(DocName, Fixity)]
- -> LaTeX
-
-ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of
- TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode
- TyClD d@(DataDecl {})
- -> ppDataDecl instances subdocs loc (Just doc) d unicode
- TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode
--- Family instances happen via FamInst now
--- TyClD d@(TySynonym {})
--- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode
--- Family instances happen via FamInst now
- TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode
- SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode
- SigD (PatSynSig lname args ty prov req) ->
- ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode
- ForD d -> ppFor loc (doc, fnArgsDoc) d unicode
- InstD _ -> empty
- _ -> error "declaration not supported by ppDecl"
- where
- unicode = False
-
-
-ppTyFam :: Bool -> SrcSpan -> Documentation DocName ->
- TyClDecl DocName -> Bool -> LaTeX
-ppTyFam _ _ _ _ _ =
- error "type family declarations are currently not supported by --latex"
-
-
-ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX
-ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode =
- ppFunSig loc doc [name] typ unicode
-ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX"
--- error "foreign declarations are currently not supported by --latex"
-
-
--------------------------------------------------------------------------------
--- * Type Synonyms
--------------------------------------------------------------------------------
-
-
--- we skip type patterns for now
-ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX
-
-ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdRhs = ltype }) unicode
- = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode
- where
- hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)
- full = hdr <+> char '=' <+> ppLType unicode ltype
-
-ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn"
-
-
--------------------------------------------------------------------------------
--- * Function signatures
--------------------------------------------------------------------------------
-
-
-ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName
- -> Bool -> LaTeX
-ppFunSig loc doc docnames typ unicode =
- ppTypeOrFunSig loc docnames typ doc
- ( ppTypeSig names typ False
- , hsep . punctuate comma $ map ppSymName names
- , dcolon unicode)
- unicode
- where
- names = map getName docnames
-
-ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName
- -> HsPatSynDetails (LHsType DocName) -> LHsType DocName
- -> LHsContext DocName -> LHsContext DocName
- -> Bool -> LaTeX
-ppLPatSig loc doc docname args typ prov req unicode =
- ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode
-
-ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName
- -> HsPatSynDetails (HsType DocName) -> HsType DocName
- -> HsContext DocName -> HsContext DocName
- -> Bool -> LaTeX
-ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)
- where
- pref1 = hsep [ keyword "pattern"
- , pp_ctx prov
- , pp_head
- , dcolon unicode
- , pp_ctx req
- , ppType unicode typ
- ]
-
- pp_head = case args of
- PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs
- InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]
-
- pp_type = ppParendType unicode
- pp_ctx ctx = ppContext ctx unicode
-
-ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName
- -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)
- -> Bool -> LaTeX
-ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0)
- unicode
- | Map.null argDocs =
- declWithDoc pref1 (documentationToLaTeX doc)
- | otherwise =
- declWithDoc pref2 $ Just $
- text "\\haddockbeginargs" $$
- do_args 0 sep0 typ $$
- text "\\end{tabulary}\\par" $$
- fromMaybe empty (documentationToLaTeX doc)
- where
- do_largs n leader (L _ t) = do_args n leader t
-
- arg_doc n = rDoc (Map.lookup n argDocs)
-
- do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX
- do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
- = decltt leader <->
- decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
- ppLContextNoArrow lctxt unicode) <+> nl $$
- do_largs n (darrow unicode) ltype
-
- do_args n leader (HsForAllTy Implicit _ lctxt ltype)
- | not (null (unLoc lctxt))
- = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$
- do_largs n (darrow unicode) ltype
- -- if we're not showing any 'forall' or class constraints or
- -- anything, skip having an empty line for the context.
- | otherwise
- = do_largs n leader ltype
- do_args n leader (HsFunTy lt r)
- = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$
- do_largs (n+1) (arrow unicode) r
- do_args n leader t
- = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl
-
-
-ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX
-ppTypeSig nms ty unicode =
- hsep (punctuate comma $ map ppSymName nms)
- <+> dcolon unicode
- <+> ppType unicode ty
-
-
-ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX]
-ppTyVars tvs = map ppSymName (tyvarNames tvs)
-
-
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
-
-
-declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX
-declWithDoc decl doc =
- text "\\begin{haddockdesc}" $$
- text "\\item[\\begin{tabular}{@{}l}" $$
- text (latexMonoFilter (show decl)) $$
- text "\\end{tabular}]" <>
- (if isNothing doc then empty else text "\\haddockbegindoc") $$
- maybe empty id doc $$
- text "\\end{haddockdesc}"
-
-
--- in a group of decls, we don't put them all in the same tabular,
--- because that would prevent the group being broken over a page
--- boundary (breaks Foreign.C.Error for example).
-multiDecl :: [LaTeX] -> LaTeX
-multiDecl decls =
- text "\\begin{haddockdesc}" $$
- vcat [
- text "\\item[" $$
- text (latexMonoFilter (show decl)) $$
- text "]"
- | decl <- decls ] $$
- text "\\end{haddockdesc}"
-
-
--------------------------------------------------------------------------------
--- * Rendering Doc
--------------------------------------------------------------------------------
-
-
-maybeDoc :: Maybe (Doc DocName) -> LaTeX
-maybeDoc = maybe empty docToLaTeX
-
-
--- for table cells, we strip paragraphs out to avoid extra vertical space
--- and don't add a quote environment.
-rDoc :: Maybe (Doc DocName) -> LaTeX
-rDoc = maybeDoc . fmap latexStripTrailingWhitespace
-
-
--------------------------------------------------------------------------------
--- * Class declarations
--------------------------------------------------------------------------------
-
-
-ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
- -> Bool -> LaTeX
-ppClassHdr summ lctxt n tvs fds unicode =
- keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
- <+> ppAppDocNameNames summ n (tyvarNames $ tvs)
- <+> ppFds fds unicode
-
-
-ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX
-ppFds fds unicode =
- if null fds then empty else
- char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
- where
- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>
- hsep (map ppDocName vars2)
-
-
-ppClassDecl :: [DocInstance DocName] -> SrcSpan
- -> Documentation DocName -> [(DocName, DocForDecl DocName)]
- -> TyClDecl DocName -> Bool -> LaTeX
-ppClassDecl instances loc doc subdocs
- (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds
- , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode
- = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$
- instancesBit
- where
- classheader
- | null lsigs = hdr unicode
- | otherwise = hdr unicode <+> keyword "where"
-
- hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds
-
- body = catMaybes [documentationToLaTeX doc, body_]
-
- body_
- | null lsigs, null ats, null at_defs = Nothing
- | null ats, null at_defs = Just methodTable
---- | otherwise = atTable $$ methodTable
- | otherwise = error "LaTeX.ppClassDecl"
-
- methodTable =
- text "\\haddockpremethods{}\\textbf{Methods}" $$
- vcat [ ppFunSig loc doc names typ unicode
- | L _ (TypeSig lnames (L _ typ)) <- lsigs
- , let doc = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames ]
- -- FIXME: is taking just the first name ok? Is it possible that
- -- there are different subdocs for different names in a single
- -- type signature?
-
- instancesBit = ppDocInstances unicode instances
-
-ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-
-ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX
-ppDocInstances _unicode [] = empty
-ppDocInstances unicode (i : rest)
- | Just ihead <- isUndocdInstance i
- = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$
- ppDocInstances unicode rest'
- | otherwise
- = ppDocInstance unicode i $$ ppDocInstances unicode rest
- where
- (is, rest') = spanWith isUndocdInstance rest
-
-isUndocdInstance :: DocInstance a -> Maybe (InstHead a)
-isUndocdInstance (i,Nothing) = Just i
-isUndocdInstance _ = Nothing
-
--- | Print a possibly commented instance. The instance header is printed inside
--- an 'argBox'. The comment is printed to the right of the box in normal comment
--- style.
-ppDocInstance :: Bool -> DocInstance DocName -> LaTeX
-ppDocInstance unicode (instHead, doc) =
- declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)
-
-
-ppInstDecl :: Bool -> InstHead DocName -> LaTeX
-ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
-
-
-ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
-ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ks ts unicode
- <+> maybe empty (\t -> equals <+> ppType unicode t) rhs
-ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
- error "data instances not supported by --latex yet"
-
-lookupAnySubdoc :: (Eq name1) =>
- name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
-lookupAnySubdoc n subdocs = case lookup n subdocs of
- Nothing -> noDocForDecl
- Just docs -> docs
-
-
--------------------------------------------------------------------------------
--- * Data & newtype declarations
--------------------------------------------------------------------------------
-
-
-ppDataDecl :: [DocInstance DocName] ->
- [(DocName, DocForDecl DocName)] -> SrcSpan ->
- Maybe (Documentation DocName) -> TyClDecl DocName -> Bool ->
- LaTeX
-ppDataDecl instances subdocs _loc doc dataDecl unicode
-
- = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit)
- (if null body then Nothing else Just (vcat body))
- $$ instancesBit
-
- where
- cons = dd_cons (tcdDataDefn dataDecl)
- resTy = (con_res . unLoc . head) cons
-
- body = catMaybes [constrBit, doc >>= documentationToLaTeX]
-
- (whereBit, leaders)
- | null cons = (empty,[])
- | otherwise = case resTy of
- ResTyGADT _ -> (decltt (keyword "where"), repeat empty)
- _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))
-
- constrBit
- | null cons = Nothing
- | otherwise = Just $
- text "\\haddockbeginconstrs" $$
- vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$
- text "\\end{tabulary}\\par"
-
- instancesBit = ppDocInstances unicode instances
-
-
--- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX
-ppConstrHdr forall tvs ctxt unicode
- = (if null tvs then empty else ppForall)
- <+>
- (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ")
- where
- ppForall = case forall of
- Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "
- Implicit -> empty
-
-
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX
- -> LConDecl DocName -> LaTeX
-ppSideBySideConstr subdocs unicode leader (L _ con) =
- leader <->
- case con_res con of
- ResTyH98 -> case con_details con of
-
- PrefixCon args ->
- decltt (hsep ((header_ unicode <+> ppBinder occ) :
- map (ppLParendType unicode) args))
- <-> rDoc mbDoc <+> nl
-
- RecCon fields ->
- (decltt (header_ unicode <+> ppBinder occ)
- <-> rDoc mbDoc <+> nl)
- $$
- doRecordFields fields
-
- InfixCon arg1 arg2 ->
- decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,
- ppBinder occ,
- ppLParendType unicode arg2 ])
- <-> rDoc mbDoc <+> nl
-
- ResTyGADT resTy -> case con_details con of
- -- prefix & infix could also use hsConDeclArgTys if it seemed to
- -- simplify the code.
- PrefixCon args -> doGADTCon args resTy
- cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$
- doRecordFields fields
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
-
- where
- doRecordFields fields =
- vcat (map (ppSideBySideField subdocs unicode) fields)
-
- doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [
- ppForAll forall ltvs (con_cxt con) unicode,
- ppLType unicode (foldr mkFunTy resTy args) ]
- ) <-> rDoc mbDoc
-
-
- header_ = ppConstrHdr forall tyVars context
- occ = nameOccName . getName . unLoc . con_name $ con
- ltvs = con_qvars con
- tyVars = tyvarNames (con_qvars con)
- context = unLoc (con_cxt con)
- forall = con_explicit con
- -- don't use "con_doc con", in case it's reconstructed from a .hi file,
- -- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
- mkFunTy a b = noLoc (HsFunTy a b)
-
-
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX
-ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =
- decltt (ppBinder (nameOccName . getName $ name)
- <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc
- where
- -- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = lookup name subdocs >>= combineDocumentation . fst
-
--- {-
--- ppHsFullConstr :: HsConDecl -> LaTeX
--- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) =
--- declWithDoc False doc (
--- hsep ((ppHsConstrHdr tvs ctxt +++
--- ppHsBinder False nm) : map ppHsBangType typeList)
--- )
--- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) =
--- td << vanillaTable << (
--- case doc of
--- Nothing -> aboves [hdr, fields_html]
--- Just _ -> aboves [hdr, constr_doc, fields_html]
--- )
---
--- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm)
---
--- constr_doc
--- | isJust doc = docBox (docToLaTeX (fromJust doc))
--- | otherwise = LaTeX.emptyTable
---
--- fields_html =
--- td <<
--- table ! [width "100%", cellpadding 0, cellspacing 8] << (
--- aboves (map ppFullField (concat (map expandField fields)))
--- )
--- -}
---
--- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX
--- ppShortField summary unicode (ConDeclField (L _ name) ltype _)
--- = tda [theclass "recfield"] << (
--- ppBinder summary (docNameOcc name)
--- <+> dcolon unicode <+> ppLType unicode ltype
--- )
---
--- {-
--- ppFullField :: HsFieldDecl -> LaTeX
--- ppFullField (HsFieldDecl [n] ty doc)
--- = declWithDoc False doc (
--- ppHsBinder False n <+> dcolon <+> ppHsBangType ty
--- )
--- ppFullField _ = error "ppFullField"
---
--- expandField :: HsFieldDecl -> [HsFieldDecl]
--- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ]
--- -}
-
-
--- | Print the LHS of a data\/newtype declaration.
--- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX
-ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars
- , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode
- = -- newtype or data
- (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+>
- -- context
- ppLContext ctxt unicode <+>
- -- T a b c ..., or a :+: b
- ppAppDocNameNames False name (tyvarNames tyvars)
-ppDataHeader _ _ = error "ppDataHeader: illegal argument"
-
---------------------------------------------------------------------------------
--- * Type applications
---------------------------------------------------------------------------------
-
-
--- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX
-ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)
-
-
--- | Print an application of a DocName and a list of Names
-ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
-ppAppDocNameNames _summ n ns =
- ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName
-
-
--- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
- | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
- | operator = opApp
- where
- operator = isNameSym . getName $ n
- opApp = ppT t1 <+> ppDN n <+> ppT t2
-
-ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
-
-
--------------------------------------------------------------------------------
--- * Contexts
--------------------------------------------------------------------------------
-
-
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX
-ppLContext = ppContext . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
-
-
-ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX
-ppContextNoArrow [] _ = empty
-ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode
-
-
-ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX
-ppContextNoLocs [] _ = empty
-ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode
-
-
-ppContext :: HsContext DocName -> Bool -> LaTeX
-ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode
-
-
-pp_hs_context :: [HsType DocName] -> Bool -> LaTeX
-pp_hs_context [] _ = empty
-pp_hs_context [p] unicode = ppType unicode p
-pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt)
-
-
--------------------------------------------------------------------------------
--- * Types and contexts
--------------------------------------------------------------------------------
-
-
-ppBang :: HsBang -> LaTeX
-ppBang HsNoBang = empty
-ppBang _ = char '!' -- Unpacked args is an implementation detail,
-
-
-tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX
-tupleParens HsUnboxedTuple = ubxParenList
-tupleParens _ = parenList
-
-
--------------------------------------------------------------------------------
--- * Rendering of HsType
---
--- Stolen from Html and tweaked for LaTeX generation
--------------------------------------------------------------------------------
-
-
-pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
-
-pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC
-pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC
- -- Used for LH arg of (->)
-pREC_OP = (2 :: Int) -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = (3 :: Int) -- Used for arg of type applicn:
- -- always parenthesise unless atomic
-
-maybeParen :: Int -- Precedence of context
- -> Int -- Precedence of top-level operator
- -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op)
-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
- | otherwise = p
-
-
-ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX
-ppLType unicode y = ppType unicode (unLoc y)
-ppLParendType unicode y = ppParendType unicode (unLoc y)
-ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
-
-
-ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX
-ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
-ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode
-
-ppLKind :: Bool -> LHsKind DocName -> LaTeX
-ppLKind unicode y = ppKind unicode (unLoc y)
-
-ppKind :: Bool -> HsKind DocName -> LaTeX
-ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
-
-
--- Drop top-level for-all type variables in user style
--- since they are implicit in Haskell
-
-ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Located (HsContext DocName) -> Bool -> LaTeX
-ppForAll expl tvs cxt unicode
- | show_forall = forall_part <+> ppLContext cxt unicode
- | otherwise = ppLContext cxt unicode
- where
- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
- is_explicit = case expl of {Explicit -> True; Implicit -> False}
- forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot
-
-
-ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX
-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
-
-
-ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode
- = maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]
-
-ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar name) _ = ppDocName name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
-ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
-ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy"
-ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
-ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
-ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy"
-
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode
- = maybeParen ctxt_prec pREC_OP $
- ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode
-
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode
- = maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
-
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode
- = maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
- where
- ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
- occName = nameOccName . getName . unLoc $ op
-
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode
--- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode
-
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode
- = ppr_mono_lty ctxt_prec ty unicode
-
-ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u
-
-
-ppr_tylit :: HsTyLit -> Bool -> LaTeX
-ppr_tylit (HsNumTy n) _ = integer n
-ppr_tylit (HsStrTy s) _ = text (show s)
- -- XXX: Ok in verbatim, but not otherwise
- -- XXX: Do something with Unicode parameter?
-
-
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX
-ppr_fun_ty ctxt_prec ty1 ty2 unicode
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
- p2 = ppr_mono_lty pREC_TOP ty2 unicode
- in
- maybeParen ctxt_prec pREC_FUN $
- sep [p1, arrow unicode <+> p2]
-
-
--------------------------------------------------------------------------------
--- * Names
--------------------------------------------------------------------------------
-
-
-ppBinder :: OccName -> LaTeX
-ppBinder n
- | isInfixName n = parens $ ppOccName n
- | otherwise = ppOccName n
-
-ppBinderInfix :: OccName -> LaTeX
-ppBinderInfix n
- | isInfixName n = ppOccName n
- | otherwise = quotes $ ppOccName n
-
-isInfixName :: OccName -> Bool
-isInfixName n = isVarSym n || isConSym n
-
-ppSymName :: Name -> LaTeX
-ppSymName name
- | isNameSym name = parens $ ppName name
- | otherwise = ppName name
-
-
-ppVerbOccName :: OccName -> LaTeX
-ppVerbOccName = text . latexFilter . occNameString
-
-ppIPName :: HsIPName -> LaTeX
-ppIPName ip = text $ unpackFS $ hsIPNameFS ip
-
-ppOccName :: OccName -> LaTeX
-ppOccName = text . occNameString
-
-
-ppVerbDocName :: DocName -> LaTeX
-ppVerbDocName = ppVerbOccName . nameOccName . getName
-
-
-ppVerbRdrName :: RdrName -> LaTeX
-ppVerbRdrName = ppVerbOccName . rdrNameOcc
-
-
-ppDocName :: DocName -> LaTeX
-ppDocName = ppOccName . nameOccName . getName
-
-
-ppLDocName :: Located DocName -> LaTeX
-ppLDocName (L _ d) = ppDocName d
-
-
-ppDocBinder :: DocName -> LaTeX
-ppDocBinder = ppBinder . nameOccName . getName
-
-ppDocBinderInfix :: DocName -> LaTeX
-ppDocBinderInfix = ppBinderInfix . nameOccName . getName
-
-
-ppName :: Name -> LaTeX
-ppName = ppOccName . nameOccName
-
-
-latexFilter :: String -> String
-latexFilter = foldr latexMunge ""
-
-
-latexMonoFilter :: String -> String
-latexMonoFilter = foldr latexMonoMunge ""
-
-
-latexMunge :: Char -> String -> String
-latexMunge '#' s = "{\\char '43}" ++ s
-latexMunge '$' s = "{\\char '44}" ++ s
-latexMunge '%' s = "{\\char '45}" ++ s
-latexMunge '&' s = "{\\char '46}" ++ s
-latexMunge '~' s = "{\\char '176}" ++ s
-latexMunge '_' s = "{\\char '137}" ++ s
-latexMunge '^' s = "{\\char '136}" ++ s
-latexMunge '\\' s = "{\\char '134}" ++ s
-latexMunge '{' s = "{\\char '173}" ++ s
-latexMunge '}' s = "{\\char '175}" ++ s
-latexMunge '[' s = "{\\char 91}" ++ s
-latexMunge ']' s = "{\\char 93}" ++ s
-latexMunge c s = c : s
-
-
-latexMonoMunge :: Char -> String -> String
-latexMonoMunge ' ' s = '\\' : ' ' : s
-latexMonoMunge '\n' s = '\\' : '\\' : s
-latexMonoMunge c s = latexMunge c s
-
-
--------------------------------------------------------------------------------
--- * Doc Markup
--------------------------------------------------------------------------------
-
-
-parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
-parLatexMarkup ppId = Markup {
- markupParagraph = \p v -> p v <> text "\\par" $$ text "",
- markupEmpty = \_ -> empty,
- markupString = \s v -> text (fixString v s),
- markupAppend = \l r v -> l v <> r v,
- markupIdentifier = markupId ppId,
- markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
- markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
- markupWarning = \p v -> emph (p v),
- markupEmphasis = \p v -> emph (p v),
- markupBold = \p v -> bold (p v),
- markupMonospaced = \p _ -> tt (p Mono),
- markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
- markupPic = \p _ -> markupPic p,
- markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
- markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
- markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
- markupHyperlink = \l _ -> markupLink l,
- markupAName = \_ _ -> empty,
- markupProperty = \p _ -> quote $ verb $ text p,
- markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e,
- markupHeader = \(Header l h) p -> header l (h p)
- }
- where
- header 1 d = text "\\section*" <> braces d
- header 2 d = text "\\subsection*" <> braces d
- header l d
- | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d
- header l _ = error $ "impossible header level in LaTeX generation: " ++ show l
-
- fixString Plain s = latexFilter s
- fixString Verb s = s
- fixString Mono s = latexMonoFilter s
-
- markupLink (Hyperlink url mLabel) = case mLabel of
- Just label -> text "\\href" <> braces (text url) <> braces (text label)
- Nothing -> text "\\url" <> braces (text url)
-
- -- Is there a better way of doing this? Just a space is an aribtrary choice.
- markupPic (Picture uri title) = parens (imageText title)
- where
- imageText Nothing = beg
- imageText (Just t) = beg <> text " " <> text t
-
- beg = text "image: " <> text uri
-
- markupId ppId_ id v =
- case v of
- Verb -> theid
- Mono -> theid
- Plain -> text "\\haddockid" <> braces theid
- where theid = ppId_ id
-
-
-latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
-latexMarkup = parLatexMarkup ppVerbDocName
-
-
-rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX)
-rdrLatexMarkup = parLatexMarkup ppVerbRdrName
-
-
-docToLaTeX :: Doc DocName -> LaTeX
-docToLaTeX doc = markup latexMarkup doc Plain
-
-
-documentationToLaTeX :: Documentation DocName -> Maybe LaTeX
-documentationToLaTeX = fmap docToLaTeX . combineDocumentation
-
-
-rdrDocToLaTeX :: Doc RdrName -> LaTeX
-rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain
-
-
-data StringContext = Plain | Verb | Mono
-
-
-latexStripTrailingWhitespace :: Doc a -> Doc a
-latexStripTrailingWhitespace (DocString s)
- | null s' = DocEmpty
- | otherwise = DocString s
- where s' = reverse (dropWhile isSpace (reverse s))
-latexStripTrailingWhitespace (DocAppend l r)
- | DocEmpty <- r' = latexStripTrailingWhitespace l
- | otherwise = DocAppend l r'
- where
- r' = latexStripTrailingWhitespace r
-latexStripTrailingWhitespace (DocParagraph p) =
- latexStripTrailingWhitespace p
-latexStripTrailingWhitespace other = other
-
-
--------------------------------------------------------------------------------
--- * LaTeX utils
--------------------------------------------------------------------------------
-
-
-itemizedList :: [LaTeX] -> LaTeX
-itemizedList items =
- text "\\begin{itemize}" $$
- vcat (map (text "\\item" $$) items) $$
- text "\\end{itemize}"
-
-
-enumeratedList :: [LaTeX] -> LaTeX
-enumeratedList items =
- text "\\begin{enumerate}" $$
- vcat (map (text "\\item " $$) items) $$
- text "\\end{enumerate}"
-
-
-descriptionList :: [(LaTeX,LaTeX)] -> LaTeX
-descriptionList items =
- text "\\begin{description}" $$
- vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$
- text "\\end{description}"
-
-
-tt :: LaTeX -> LaTeX
-tt ltx = text "\\haddocktt" <> braces ltx
-
-
-decltt :: LaTeX -> LaTeX
-decltt ltx = text "\\haddockdecltt" <> braces ltx
-
-
-emph :: LaTeX -> LaTeX
-emph ltx = text "\\emph" <> braces ltx
-
-bold :: LaTeX -> LaTeX
-bold ltx = text "\\textbf" <> braces ltx
-
-verb :: LaTeX -> LaTeX
-verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}"
- -- NB. swallow a trailing \n in the verbatim text by appending the
- -- \end{verbatim} directly, otherwise we get spurious blank lines at the
- -- end of code blocks.
-
-
-quote :: LaTeX -> LaTeX
-quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}"
-
-
-dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX
-dcolon unicode = text (if unicode then "∷" else "::")
-arrow unicode = text (if unicode then "→" else "->")
-darrow unicode = text (if unicode then "⇒" else "=>")
-forallSymbol unicode = text (if unicode then "∀" else "forall")
-
-
-dot :: LaTeX
-dot = char '.'
-
-
-parenList :: [LaTeX] -> LaTeX
-parenList = parens . hsep . punctuate comma
-
-
-ubxParenList :: [LaTeX] -> LaTeX
-ubxParenList = ubxparens . hsep . punctuate comma
-
-
-ubxparens :: LaTeX -> LaTeX
-ubxparens h = text "(#" <> h <> text "#)"
-
-
-pabrackets :: LaTeX -> LaTeX
-pabrackets h = text "[:" <> h <> text ":]"
-
-
-nl :: LaTeX
-nl = text "\\\\"
-
-
-keyword :: String -> LaTeX
-keyword = text
-
-
-infixr 4 <-> -- combining table cells
-(<->) :: LaTeX -> LaTeX -> LaTeX
-a <-> b = a <+> char '&' <+> b
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
deleted file mode 100644
index 9628a33d..00000000
--- a/src/Haddock/Backends/Xhtml.hs
+++ /dev/null
@@ -1,690 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
-module Haddock.Backends.Xhtml (
- ppHtml, copyHtmlBits,
- ppHtmlIndex, ppHtmlContents,
-) where
-
-
-import Prelude hiding (div)
-
-import Haddock.Backends.Xhtml.Decl
-import Haddock.Backends.Xhtml.DocMarkup
-import Haddock.Backends.Xhtml.Layout
-import Haddock.Backends.Xhtml.Names
-import Haddock.Backends.Xhtml.Themes
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
-import Haddock.ModuleTree
-import Haddock.Types
-import Haddock.Version
-import Haddock.Utils
-import Text.XHtml hiding ( name, title, p, quote )
-import Haddock.GhcUtils
-
-import Control.Monad ( when, unless )
-#if !MIN_VERSION_base(4,7,0)
-import Control.Monad.Instances ( ) -- for Functor Either a
-#endif
-import Data.Char ( toUpper )
-import Data.Functor ( (<$>) )
-import Data.List ( sortBy, groupBy, intercalate, isPrefixOf )
-import Data.Maybe
-import System.FilePath hiding ( (</>) )
-import System.Directory
-import Data.Map ( Map )
-import qualified Data.Map as Map hiding ( Map )
-import qualified Data.Set as Set hiding ( Set )
-import Data.Function
-import Data.Ord ( comparing )
-
-import DynFlags (Language(..))
-import GHC hiding ( NoLink, moduleInfo )
-import Name
-import Module
-
---------------------------------------------------------------------------------
--- * Generating HTML documentation
---------------------------------------------------------------------------------
-
-
-ppHtml :: String
- -> Maybe String -- ^ Package
- -> [Interface]
- -> FilePath -- ^ Destination directory
- -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe
- -> Themes -- ^ Themes
- -> SourceURLs -- ^ The source URL (--source)
- -> WikiURLs -- ^ The wiki URL (--wiki)
- -> Maybe String -- ^ The contents URL (--use-contents)
- -> Maybe String -- ^ The index URL (--use-index)
- -> Bool -- ^ Whether to use unicode in output (--use-unicode)
- -> QualOption -- ^ How to qualify names
- -> Bool -- ^ Output pretty html (newlines and indenting)
- -> IO ()
-
-ppHtml doctitle maybe_package ifaces odir prologue
- themes maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode
- qual debug = do
- let
- visible_ifaces = filter visible ifaces
- visible i = OptHide `notElem` ifaceOptions i
-
- when (isNothing maybe_contents_url) $
- ppHtmlContents odir doctitle maybe_package
- themes maybe_index_url maybe_source_url maybe_wiki_url
- (map toInstalledIface visible_ifaces)
- False -- we don't want to display the packages in a single-package contents
- prologue debug (makeContentsQual qual)
-
- when (isNothing maybe_index_url) $
- ppHtmlIndex odir doctitle maybe_package
- themes maybe_contents_url maybe_source_url maybe_wiki_url
- (map toInstalledIface visible_ifaces) debug
-
- mapM_ (ppHtmlModule odir doctitle themes
- maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces
-
-
-copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
-copyHtmlBits odir libdir themes = do
- let
- libhtmldir = joinPath [libdir, "html"]
- copyCssFile f = copyFile f (combine odir (takeFileName f))
- copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
- mapM_ copyCssFile (cssFiles themes)
- mapM_ copyLibFile [ jsFile, framesFile ]
-
-
-headHtml :: String -> Maybe String -> Themes -> Html
-headHtml docTitle miniPage themes =
- header << [
- meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
- thetitle << docTitle,
- styleSheet themes,
- script ! [src jsFile, thetype "text/javascript"] << noHtml,
- script ! [thetype "text/javascript"]
- -- NB: Within XHTML, the content of script tags needs to be
- -- a <![CDATA[ section. Will break if the miniPage name could
- -- have "]]>" in it!
- << primHtml (
- "//<![CDATA[\nwindow.onload = function () {pageLoad();"
- ++ setSynopsis ++ "};\n//]]>\n")
- ]
- where
- setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
-
-
-srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
-srcButton (Just src_base_url, _, _, _) Nothing =
- Just (anchor ! [href src_base_url] << "Source")
-srcButton (_, Just src_module_url, _, _) (Just iface) =
- let url = spliceURL (Just $ ifaceOrigFilename iface)
- (Just $ ifaceMod iface) Nothing Nothing src_module_url
- in Just (anchor ! [href url] << "Source")
-srcButton _ _ =
- Nothing
-
-
-wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
-wikiButton (Just wiki_base_url, _, _) Nothing =
- Just (anchor ! [href wiki_base_url] << "User Comments")
-
-wikiButton (_, Just wiki_module_url, _) (Just mdl) =
- let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
- in Just (anchor ! [href url] << "User Comments")
-
-wikiButton _ _ =
- Nothing
-
-
-contentsButton :: Maybe String -> Maybe Html
-contentsButton maybe_contents_url
- = Just (anchor ! [href url] << "Contents")
- where url = fromMaybe contentsHtmlFile maybe_contents_url
-
-
-indexButton :: Maybe String -> Maybe Html
-indexButton maybe_index_url
- = Just (anchor ! [href url] << "Index")
- where url = fromMaybe indexHtmlFile maybe_index_url
-
-
-bodyHtml :: String -> Maybe Interface
- -> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String
- -> Html -> Html
-bodyHtml doctitle iface
- maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url
- pageContent =
- body << [
- divPackageHeader << [
- unordList (catMaybes [
- srcButton maybe_source_url iface,
- wikiButton maybe_wiki_url (ifaceMod <$> iface),
- contentsButton maybe_contents_url,
- indexButton maybe_index_url])
- ! [theclass "links", identifier "page-menu"],
- nonEmptySectionName << doctitle
- ],
- divContent << pageContent,
- divFooter << paragraph << (
- "Produced by " +++
- (anchor ! [href projectUrl] << toHtml projectName) +++
- (" version " ++ projectVersion)
- )
- ]
-
-
-moduleInfo :: Interface -> Html
-moduleInfo iface =
- let
- info = ifaceInfo iface
-
- doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
- doOneEntry (fieldName, field) =
- field info >>= \a -> return (th << fieldName <-> td << a)
-
- entries :: [HtmlTable]
- entries = mapMaybe doOneEntry [
- ("Copyright",hmi_copyright),
- ("License",hmi_license),
- ("Maintainer",hmi_maintainer),
- ("Stability",hmi_stability),
- ("Portability",hmi_portability),
- ("Safe Haskell",hmi_safety),
- ("Language", lg)
- ] ++ extsForm
- where
- lg inf = case hmi_language inf of
- Nothing -> Nothing
- Just Haskell98 -> Just "Haskell98"
- Just Haskell2010 -> Just "Haskell2010"
-
- extsForm
- | OptShowExtensions `elem` ifaceOptions iface =
- let fs = map (dropOpt . show) (hmi_extensions info)
- in case map stringToHtml fs of
- [] -> []
- [x] -> extField x -- don't use a list for a single extension
- xs -> extField $ unordList xs ! [theclass "extension-list"]
- | otherwise = []
- where
- extField x = return $ th << "Extensions" <-> td << x
- dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
- in
- case entries of
- [] -> noHtml
- _ -> table ! [theclass "info"] << aboves entries
-
-
---------------------------------------------------------------------------------
--- * Generate the module contents
---------------------------------------------------------------------------------
-
-
-ppHtmlContents
- :: FilePath
- -> String
- -> Maybe String
- -> Themes
- -> Maybe String
- -> SourceURLs
- -> WikiURLs
- -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
- -> Bool
- -> Qualification -- ^ How to qualify names
- -> IO ()
-ppHtmlContents odir doctitle _maybe_package
- themes maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
- let tree = mkModuleTree showPkgs
- [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
- html =
- headHtml doctitle Nothing themes +++
- bodyHtml doctitle Nothing
- maybe_source_url maybe_wiki_url
- Nothing maybe_index_url << [
- ppPrologue qual doctitle prologue,
- ppModuleTree qual tree
- ]
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
-
- -- XXX: think of a better place for this?
- ppHtmlContentsFrame odir doctitle themes ifaces debug
-
-
-ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html
-ppPrologue _ _ Nothing = noHtml
-ppPrologue qual title (Just doc) =
- divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
-
-
-ppModuleTree :: Qualification -> [ModuleTree] -> Html
-ppModuleTree qual ts =
- divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
-
-
-mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
-mkNodeList qual ss p ts = case ts of
- [] -> noHtml
- _ -> unordList (zipWith (mkNode qual ss) ps ts)
- where
- ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
-
-
-mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
-mkNode qual ss p (Node s leaf pkg short ts) =
- htmlModule <+> shortDescr +++ htmlPkg +++ subtree
- where
- modAttrs = case (ts, leaf) of
- (_:_, False) -> collapseControl p True "module"
- (_, _ ) -> [theclass "module"]
-
- cBtn = case (ts, leaf) of
- (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml
- (_, _ ) -> noHtml
- -- We only need an explicit collapser button when the module name
- -- is also a leaf, and so is a link to a module page. Indeed, the
- -- spaceHtml is a minor hack and does upset the layout a fraction.
-
- htmlModule = thespan ! modAttrs << (cBtn +++
- if leaf
- then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
- (mkModuleName mdl))
- else toHtml s
- )
-
- mdl = intercalate "." (reverse (s:ss))
-
- shortDescr = maybe noHtml (origDocToHtml qual) short
- htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
-
- subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
-
-
--- | Turn a module tree into a flat list of full module names. E.g.,
--- @
--- A
--- +-B
--- +-C
--- @
--- becomes
--- @["A", "A.B", "A.B.C"]@
-flatModuleTree :: [InstalledInterface] -> [Html]
-flatModuleTree ifaces =
- map (uncurry ppModule' . head)
- . groupBy ((==) `on` fst)
- . sortBy (comparing fst)
- $ mods
- where
- mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
- ppModule' txt mdl =
- anchor ! [href (moduleHtmlFile mdl), target mainFrameName]
- << toHtml txt
-
-
-ppHtmlContentsFrame :: FilePath -> String -> Themes
- -> [InstalledInterface] -> Bool -> IO ()
-ppHtmlContentsFrame odir doctitle themes ifaces debug = do
- let mods = flatModuleTree ifaces
- html =
- headHtml doctitle Nothing themes +++
- miniBody << divModuleList <<
- (sectionName << "Modules" +++
- ulist << [ li ! [theclass "module"] << m | m <- mods ])
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html)
-
-
---------------------------------------------------------------------------------
--- * Generate the index
---------------------------------------------------------------------------------
-
-
-ppHtmlIndex :: FilePath
- -> String
- -> Maybe String
- -> Themes
- -> Maybe String
- -> SourceURLs
- -> WikiURLs
- -> [InstalledInterface]
- -> Bool
- -> IO ()
-ppHtmlIndex odir doctitle _maybe_package themes
- maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
- let html = indexPage split_indices Nothing
- (if split_indices then [] else index)
-
- createDirectoryIfMissing True odir
-
- when split_indices $ do
- mapM_ (do_sub_index index) initialChars
- -- Let's add a single large index as well for those who don't know exactly what they're looking for:
- let mergedhtml = indexPage False Nothing index
- writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
-
- writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html)
-
- where
- indexPage showLetters ch items =
- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++
- bodyHtml doctitle Nothing
- maybe_source_url maybe_wiki_url
- maybe_contents_url Nothing << [
- if showLetters then indexInitialLetterLinks else noHtml,
- if null items then noHtml else
- divIndex << [sectionName << indexName ch, buildIndex items]
- ]
-
- indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
- merged_name = "All"
-
- buildIndex items = table << aboves (map indexElt items)
-
- -- an arbitrary heuristic:
- -- too large, and a single-page will be slow to load
- -- too small, and we'll have lots of letter-indexes with only one
- -- or two members in them, which seems inefficient or
- -- unnecessarily hard to use.
- split_indices = length index > 150
-
- indexInitialLetterLinks =
- divAlphabet <<
- unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
- [ [c] | c <- initialChars
- , any ((==c) . toUpper . head . fst) index ] ++
- [merged_name])
-
- -- todo: what about names/operators that start with Unicode
- -- characters?
- -- Exports beginning with '_' can be listed near the end,
- -- presumably they're not as important... but would be listed
- -- with non-split index!
- initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
-
- do_sub_index this_ix c
- = unless (null index_part) $
- writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
- where
- html = indexPage True (Just c) index_part
- index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
-
-
- index :: [(String, Map GHC.Name [(Module,Bool)])]
- index = sortBy cmp (Map.toAscList full_index)
- where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2
-
- -- for each name (a plain string), we have a number of original HsNames that
- -- it can refer to, and for each of those we have a list of modules
- -- that export that entity. Each of the modules exports the entity
- -- in a visible or invisible way (hence the Bool).
- full_index :: Map String (Map GHC.Name [(Module,Bool)])
- full_index = Map.fromListWith (flip (Map.unionWith (++)))
- (concatMap getIfaceIndex ifaces)
-
- getIfaceIndex iface =
- [ (getOccString name
- , Map.fromList [(name, [(mdl, name `Set.member` visible)])])
- | name <- instExports iface ]
- where
- mdl = instMod iface
- visible = Set.fromList (instVisibleExports iface)
-
- indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
- indexElt (str, entities) =
- case Map.toAscList entities of
- [(nm,entries)] ->
- td ! [ theclass "src" ] << toHtml str <->
- indexLinks nm entries
- many_entities ->
- td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
- aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)
-
- doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
- doAnnotatedEntity (j,(nm,entries))
- = td ! [ theclass "alt" ] <<
- toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
- indexLinks nm entries
-
- ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
- | isDataOcc n = toHtml "Data Constructor"
- | otherwise = toHtml "Function"
-
- indexLinks nm entries =
- td ! [ theclass "module" ] <<
- hsep (punctuate comma
- [ if visible then
- linkId mdl (Just nm) << toHtml (moduleString mdl)
- else
- toHtml (moduleString mdl)
- | (mdl, visible) <- entries ])
-
-
---------------------------------------------------------------------------------
--- * Generate the HTML page for a module
---------------------------------------------------------------------------------
-
-
-ppHtmlModule
- :: FilePath -> String -> Themes
- -> SourceURLs -> WikiURLs
- -> Maybe String -> Maybe String -> Bool -> QualOption
- -> Bool -> Interface -> IO ()
-ppHtmlModule odir doctitle themes
- maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url unicode qual debug iface = do
- let
- mdl = ifaceMod iface
- aliases = ifaceModuleAliases iface
- mdl_str = moduleString mdl
- real_qual = makeModuleQual qual aliases mdl
- html =
- headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
- bodyHtml doctitle (Just iface)
- maybe_source_url maybe_wiki_url
- maybe_contents_url maybe_index_url << [
- divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
- ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual
- ]
-
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
- ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug
-
-ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
- -> Interface -> Bool -> Qualification -> Bool -> IO ()
-ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do
- let mdl = ifaceMod iface
- html =
- headHtml (moduleString mdl) Nothing themes +++
- miniBody <<
- (divModuleHeader << sectionName << moduleString mdl +++
- miniSynopsis mdl iface unicode qual)
- createDirectoryIfMissing True odir
- writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html)
-
-
-ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html
-ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual
- = ppModuleContents qual exports +++
- description +++
- synopsis +++
- divInterface (maybe_doc_hdr +++ bdy)
- where
- exports = numberSectionHeadings (ifaceRnExportItems iface)
-
- -- todo: if something has only sub-docs, or fn-args-docs, should
- -- it be measured here and thus prevent omitting the synopsis?
- has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
- has_doc (ExportNoDecl _ _) = False
- has_doc (ExportModule _) = False
- has_doc _ = True
-
- no_doc_at_all = not (any has_doc exports)
-
- description | isNoHtml doc = doc
- | otherwise = divDescription $ sectionName << "Description" +++ doc
- where doc = docSection qual (ifaceRnDoc iface)
-
- -- omit the synopsis if there are no documentation annotations at all
- synopsis
- | no_doc_at_all = noHtml
- | otherwise
- = divSynposis $
- paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++
- shortDeclList (
- mapMaybe (processExport True linksInfo unicode qual) exports
- ) ! (collapseSection "syn" False "" ++ collapseToggle "syn")
-
- -- if the documentation doesn't begin with a section header, then
- -- add one ("Documentation").
- maybe_doc_hdr
- = case exports of
- [] -> noHtml
- ExportGroup {} : _ -> noHtml
- _ -> h1 << "Documentation"
-
- bdy =
- foldr (+++) noHtml $
- mapMaybe (processExport False linksInfo unicode qual) exports
-
- linksInfo = (maybe_source_url, maybe_wiki_url)
-
-
-miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html
-miniSynopsis mdl iface unicode qual =
- divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports
- where
- exports = numberSectionHeadings (ifaceRnExportItems iface)
-
-
-processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName
- -> [Html]
-processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } =
- ((divTopDecl <<).(declElem <<)) <$> case decl0 of
- TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
- (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual]
- (DataDecl{}) -> [keyword "data" <+> b]
- (SynDecl{}) -> [keyword "type" <+> b]
- (ClassDecl {}) -> [keyword "class" <+> b]
- _ -> []
- SigD (TypeSig lnames (L _ _)) ->
- map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames
- _ -> []
-processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =
- [groupTag lvl << docToHtml qual txt]
-processForMiniSynopsis _ _ _ _ = []
-
-
-ppNameMini :: Notation -> Module -> OccName -> Html
-ppNameMini notation mdl nm =
- anchor ! [ href (moduleNameUrl mdl nm)
- , target mainFrameName ]
- << ppBinder' notation nm
-
-
-ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
-ppTyClBinderWithVarsMini mdl decl =
- let n = tcdName decl
- ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
- in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
-
-
-ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
-ppModuleContents qual exports
- | null sections = noHtml
- | otherwise = contentsDiv
- where
- contentsDiv = divTableOfContents << (
- sectionName << "Contents" +++
- unordList sections)
-
- (sections, _leftovers{-should be []-}) = process 0 exports
-
- process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
- process _ [] = ([], [])
- process n items@(ExportGroup lev id0 doc : rest)
- | lev <= n = ( [], items )
- | otherwise = ( html:secs, rest2 )
- where
- html = linkedAnchor (groupId id0)
- << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs
- (ssecs, rest1) = process lev rest
- (secs, rest2) = process n rest1
- process n (_ : rest) = process n rest
-
- mk_subsections [] = noHtml
- mk_subsections ss = unordList ss
-
--- we need to assign a unique id to each section heading so we can hyperlink
--- them from the contents:
-numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
-numberSectionHeadings = go 1
- where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
- go _ [] = []
- go n (ExportGroup lev _ doc : es)
- = ExportGroup lev (show n) doc : go (n+1) es
- go n (other:es)
- = other : go n es
-
-
-processExport :: Bool -> LinksInfo -> Bool -> Qualification
- -> ExportItem DocName -> Maybe Html
-processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances
-processExport summary _ _ qual (ExportGroup lev id0 doc)
- = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc
-processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice)
- = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual
-processExport summary _ _ qual (ExportNoDecl y [])
- = processDeclOneLiner summary $ ppDocName qual Prefix True y
-processExport summary _ _ qual (ExportNoDecl y subs)
- = processDeclOneLiner summary $
- ppDocName qual Prefix True y
- +++ parenList (map (ppDocName qual Prefix True) subs)
-processExport summary _ _ qual (ExportDoc doc)
- = nothingIf summary $ docSection_ qual doc
-processExport summary _ _ _ (ExportModule mdl)
- = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
-
-
-nothingIf :: Bool -> a -> Maybe a
-nothingIf True _ = Nothing
-nothingIf False a = Just a
-
-
-processDecl :: Bool -> Html -> Maybe Html
-processDecl True = Just
-processDecl False = Just . divTopDecl
-
-
-processDeclOneLiner :: Bool -> Html -> Maybe Html
-processDeclOneLiner True = Just
-processDeclOneLiner False = Just . divTopDecl . declElem
-
-groupHeading :: Int -> String -> Html -> Html
-groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)]
-
-groupTag :: Int -> Html -> Html
-groupTag lev
- | lev == 1 = h1
- | lev == 2 = h2
- | lev == 3 = h3
- | otherwise = h4
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
deleted file mode 100644
index 8884f69f..00000000
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ /dev/null
@@ -1,885 +0,0 @@
-{-# LANGUAGE TransformListComp #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.Decl
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.Decl (
- ppDecl,
-
- ppTyName, ppTyFamHeader, ppTypeApp,
- tyvarNames
-) where
-
-
-import Haddock.Backends.Xhtml.DocMarkup
-import Haddock.Backends.Xhtml.Layout
-import Haddock.Backends.Xhtml.Names
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
-import Haddock.GhcUtils
-import Haddock.Types
-import Haddock.Doc (combineDocumentation)
-
-import Data.List ( intersperse, sort )
-import qualified Data.Map as Map
-import Data.Maybe
-import Data.Monoid ( mempty )
-import Text.XHtml hiding ( name, title, p, quote )
-
-import GHC
-import GHC.Exts
-import Name
-import BooleanFormula
-
-ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
- -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
- -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html
-ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of
- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual
- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual
- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual
- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual
- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual
- SigD (PatSynSig lname args ty prov req) ->
- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual
- ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual
- InstD _ -> noHtml
- _ -> error "declaration not supported by ppDecl"
-
-
-ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppLFunSig summary links loc doc lnames lty fixities splice unicode qual =
- ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities
- splice unicode qual
-
-ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [DocName] -> HsType DocName -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppFunSig summary links loc doc docnames typ fixities splice unicode qual =
- ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ)
- splice unicode qual
- where
- pp_typ = ppType unicode qual typ
-
-ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- Located DocName ->
- HsPatSynDetails (LHsType DocName) -> LHsType DocName ->
- LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =
- ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)
- (unLoc prov) (unLoc req) fixities splice unicode qual
-
-ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- DocName ->
- HsPatSynDetails (HsType DocName) -> HsType DocName ->
- HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->
- Splice -> Unicode -> Qualification -> Html
-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities
- splice unicode qual
- | summary = pref1
- | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)
- +++ docSection qual doc
- where
- pref1 = hsep [ toHtml "pattern"
- , pp_cxt prov
- , pp_head
- , dcolon unicode
- , pp_cxt req
- , ppType unicode qual typ
- ]
- pp_head = case args of
- PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs
- InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right]
-
- pp_cxt cxt = ppContext cxt unicode qual
- pp_type = ppParendType unicode qual
-
- occname = nameOccName . getName $ docname
-
-ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName ->
- [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->
- Splice -> Unicode -> Qualification -> Html
-ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ)
- splice unicode qual =
- ppTypeOrFunSig summary links loc docnames typ doc
- ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode
- , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames
- , dcolon unicode
- )
- splice unicode qual
- where
- occnames = map (nameOccName . getName) docnames
- addFixities html
- | summary = html
- | otherwise = html <+> ppFixities fixities qual
-
-
-ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName
- -> DocForDecl DocName -> (Html, Html, Html)
- -> Splice -> Unicode -> Qualification -> Html
-ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual
- | summary = pref1
- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc
- | otherwise = topDeclElem links loc splice docnames pref2 +++
- subArguments qual (do_args 0 sep typ) +++ docSection qual doc
- where
- argDoc n = Map.lookup n argDocs
-
- do_largs n leader (L _ t) = do_args n leader t
- do_args :: Int -> Html -> HsType DocName -> [SubDecl]
- do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
- = (leader <+>
- hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>
- ppLContextNoArrow lctxt unicode qual,
- Nothing, [])
- : do_largs n (darrow unicode) ltype
- do_args n leader (HsForAllTy Implicit _ lctxt ltype)
- | not (null (unLoc lctxt))
- = (leader <+> ppLContextNoArrow lctxt unicode qual,
- Nothing, [])
- : do_largs n (darrow unicode) ltype
- -- if we're not showing any 'forall' or class constraints or
- -- anything, skip having an empty line for the context.
- | otherwise
- = do_largs n leader ltype
- do_args n leader (HsFunTy lt r)
- = (leader <+> ppLFunLhType unicode qual lt, argDoc n, [])
- : do_largs (n+1) (arrow unicode) r
- do_args n leader t
- = [(leader <+> ppType unicode qual t, argDoc n, [])]
-
-ppFixities :: [(DocName, Fixity)] -> Qualification -> Html
-ppFixities [] _ = noHtml
-ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
- where
- ppFix (ns, p, d) = thespan ! [theclass "fixity"] <<
- (toHtml d <+> toHtml (show p) <+> ppNames ns)
-
- ppDir InfixR = "infixr"
- ppDir InfixL = "infixl"
- ppDir InfixN = "infix"
-
- ppNames = case fs of
- _:[] -> const noHtml -- Don't display names for fixities on single names
- _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False)
-
- uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs
- , let d' = ppDir d
- , then group by Down (p,d') using groupWith ]
-
- rightEdge = thespan ! [theclass "rightedge"] << noHtml
-
-
-ppTyVars :: LHsTyVarBndrs DocName -> [Html]
-ppTyVars tvs = map ppTyName (tyvarNames tvs)
-
-
-tyvarNames :: LHsTyVarBndrs DocName -> [Name]
-tyvarNames = map getName . hsLTyVarNames
-
-
-ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
- -> ForeignDecl DocName -> [(DocName, Fixity)]
- -> Splice -> Unicode -> Qualification -> Html
-ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities
- splice unicode qual
- = ppFunSig summary links loc doc [name] typ fixities splice unicode qual
-ppFor _ _ _ _ _ _ _ _ _ = error "ppFor"
-
-
--- we skip type patterns for now
-ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan
- -> DocForDecl DocName -> TyClDecl DocName
- -> Splice -> Unicode -> Qualification -> Html
-ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars
- , tcdRhs = ltype })
- splice unicode qual
- = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc
- (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals)
- splice unicode qual
- where
- hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)
- full = hdr <+> equals <+> ppLType unicode qual ltype
- occ = nameOccName . getName $ name
- fixs
- | summary = noHtml
- | otherwise = ppFixities fixities qual
-ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn"
-
-
-ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html
-ppTypeSig summary nms pp_ty unicode =
- concatHtml htmlNames <+> dcolon unicode <+> pp_ty
- where
- htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms
-
-
-ppTyName :: Name -> Html
-ppTyName = ppName Prefix
-
-
---------------------------------------------------------------------------------
--- * Type families
---------------------------------------------------------------------------------
-
-
-ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
- -> Unicode -> Qualification -> Html
-ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
- , fdKindSig = mkind })
- unicode qual =
- (case info of
- OpenTypeFamily
- | associated -> keyword "type"
- | otherwise -> keyword "type family"
- DataFamily
- | associated -> keyword "data"
- | otherwise -> keyword "data family"
- ClosedTypeFamily _
- -> keyword "type family"
- ) <+>
-
- ppFamDeclBinderWithVars summary d <+>
-
- (case mkind of
- Just kind -> dcolon unicode <+> ppLKind unicode qual kind
- Nothing -> noHtml
- )
-
-ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] ->
- [(DocName, Fixity)] -> SrcSpan -> Documentation DocName ->
- FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html
-ppTyFam summary associated links instances fixities loc doc decl splice unicode qual
-
- | summary = ppTyFamHeader True associated decl unicode qual
- | otherwise = header_ +++ docSection qual doc +++ instancesBit
-
- where
- docname = unLoc $ fdLName decl
-
- header_ = topDeclElem links loc splice [docname] $
- ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual
-
- instancesBit
- | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl
- , not summary
- = subEquations qual $ map (ppTyFamEqn . unLoc) eqns
-
- | otherwise
- = ppInstances instances docname unicode qual
-
- -- Individual equation of a closed type family
- ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
- , tfie_pats = HsWB { hswb_cts = ts }}
- = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
- <+> equals <+> ppType unicode qual (unLoc rhs)
- , Nothing, [] )
-
---------------------------------------------------------------------------------
--- * Associated Types
---------------------------------------------------------------------------------
-
-
-ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName
- -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html
-ppAssocType summ links doc (L loc decl) fixities splice unicode qual =
- ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual
-
-
---------------------------------------------------------------------------------
--- * TyClDecl helpers
---------------------------------------------------------------------------------
-
--- | Print a type family and its variables
-ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html
-ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) =
- ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs)
-
--- | Print a newtype / data binder and its variables
-ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html
-ppDataBinderWithVars summ decl =
- ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl)
-
---------------------------------------------------------------------------------
--- * Type applications
---------------------------------------------------------------------------------
-
-
--- | Print an application of a DocName and two lists of HsTypes (kinds, types)
-ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName]
- -> Unicode -> Qualification -> Html
-ppAppNameTypes n ks ts unicode qual =
- ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual)
-
-
--- | Print an application of a DocName and a list of Names
-ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
-ppAppDocNameNames summ n ns =
- ppTypeApp n [] ns ppDN ppTyName
- where
- ppDN notation = ppBinderFixity notation summ . nameOccName . getName
- ppBinderFixity Infix = ppBinderInfix
- ppBinderFixity _ = ppBinder
-
--- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
-ppTypeApp n [] (t1:t2:rest) ppDN ppT
- | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
- | operator = opApp
- where
- operator = isNameSym . getName $ n
- opApp = ppT t1 <+> ppDN Infix n <+> ppT t2
-
-ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts)
-
-
--------------------------------------------------------------------------------
--- * Contexts
--------------------------------------------------------------------------------
-
-
-ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode
- -> Qualification -> Html
-ppLContext = ppContext . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
-
-
-ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContextNoArrow [] _ _ = noHtml
-ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual
-
-
-ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html
-ppContextNoLocs [] _ _ = noHtml
-ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual
- <+> darrow unicode
-
-
-ppContext :: HsContext DocName -> Unicode -> Qualification -> Html
-ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual
-
-
-ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html
-ppHsContext [] _ _ = noHtml
-ppHsContext [p] unicode qual = ppCtxType unicode qual p
-ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt)
-
-
--------------------------------------------------------------------------------
--- * Class declarations
--------------------------------------------------------------------------------
-
-
-ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName
- -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]
- -> Unicode -> Qualification -> Html
-ppClassHdr summ lctxt n tvs fds unicode qual =
- keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml)
- <+> ppAppDocNameNames summ n (tyvarNames tvs)
- <+> ppFds fds unicode qual
-
-
-ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html
-ppFds fds unicode qual =
- if null fds then noHtml else
- char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
- where
- fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
- ppVars = hsep . map (ppDocName qual Prefix True)
-
-ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan
- -> [(DocName, DocForDecl DocName)]
- -> Splice -> Unicode -> Qualification -> Html
-ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs
- , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc
- subdocs splice unicode qual =
- if not (any isVanillaLSig sigs) && null ats
- then (if summary then id else topDeclElem links loc splice [nm]) hdr
- else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where")
- +++ shortSubDecls False
- (
- [ ppAssocType summary links doc at [] splice unicode qual | at <- ats
- , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++
-
- -- ToDo: add associated type defaults
-
- [ ppFunSig summary links loc doc names typ [] splice unicode qual
- | L _ (TypeSig lnames (L _ typ)) <- sigs
- , let doc = lookupAnySubdoc (head names) subdocs
- names = map unLoc lnames ]
- -- FIXME: is taking just the first name ok? Is it possible that
- -- there are different subdocs for different names in a single
- -- type signature?
- )
- where
- hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual
- nm = unLoc lname
-ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-
-
-
-ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)]
- -> SrcSpan -> Documentation DocName
- -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName
- -> Splice -> Unicode -> Qualification -> Html
-ppClassDecl summary links instances fixities loc d subdocs
- decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars
- , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats })
- splice unicode qual
- | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual
- | otherwise = classheader +++ docSection qual d
- +++ minimalBit +++ atBit +++ methodBit +++ instancesBit
- where
- classheader
- | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs)
- | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs)
-
- -- Only the fixity relevant to the class header
- fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual
-
- nm = tcdName decl
-
- hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds
-
- -- ToDo: add assocatied typ defaults
- atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual
- | at <- ats
- , let n = unL . fdLName $ unL at
- doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs
- subfixs = [ f | f@(n',_) <- fixities, n == n' ] ]
-
- methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual
- | L _ (TypeSig lnames (L _ typ)) <- lsigs
- , let doc = lookupAnySubdoc (head names) subdocs
- subfixs = [ f | n <- names
- , f@(n',_) <- fixities
- , n == n' ]
- names = map unLoc lnames ]
- -- FIXME: is taking just the first name ok? Is it possible that
- -- there are different subdocs for different names in a single
- -- type signature?
-
- minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of
- -- Miminal complete definition = every shown method
- And xs : _ | sort [getName n | Var (L _ n) <- xs] ==
- sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]
- -> noHtml
-
- -- Minimal complete definition = the only shown method
- Var (L _ n) : _ | [getName n] ==
- [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]
- -> noHtml
-
- -- Minimal complete definition = nothing
- And [] : _ -> subMinimal $ toHtml "Nothing"
-
- m : _ -> subMinimal $ ppMinimal False m
- _ -> noHtml
-
- ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n
- ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs
- ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs
- where wrap | p = parens | otherwise = id
-
- instancesBit = ppInstances instances nm unicode qual
-
-ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
-
-
-ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html
-ppInstances instances baseName unicode qual
- = subInstances qual instName (map instDecl instances)
- where
- instName = getOccString $ getName baseName
- instDecl :: DocInstance DocName -> SubDecl
- instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
- instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
- <+> ppAppNameTypes n ks ts unicode qual
- instHead (n, ks, ts, TypeInst rhs) = keyword "type"
- <+> ppAppNameTypes n ks ts unicode qual
- <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs
- instHead (n, ks, ts, DataInst dd) = keyword "data"
- <+> ppAppNameTypes n ks ts unicode qual
- <+> ppShortDataDecl False True dd unicode qual
-
-lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
-lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n
-
-
--------------------------------------------------------------------------------
--- * Data & newtype declarations
--------------------------------------------------------------------------------
-
-
--- TODO: print contexts
-ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
-ppShortDataDecl summary dataInst dataDecl unicode qual
-
- | [] <- cons = dataHeader
-
- | [lcon] <- cons, ResTyH98 <- resTy,
- (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual
- = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot
-
- | ResTyH98 <- resTy = dataHeader
- +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons)
-
- | otherwise = (dataHeader <+> keyword "where")
- +++ shortSubDecls dataInst (map doGADTConstr cons)
-
- where
- dataHeader
- | dataInst = noHtml
- | otherwise = ppDataHeader summary dataDecl unicode qual
- doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual
- doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual
-
- cons = dd_cons (tcdDataDefn dataDecl)
- resTy = (con_res . unLoc . head) cons
-
-
-ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] ->
- [(DocName, DocForDecl DocName)] ->
- SrcSpan -> Documentation DocName -> TyClDecl DocName ->
- Splice -> Unicode -> Qualification -> Html
-ppDataDecl summary links instances fixities subdocs loc doc dataDecl
- splice unicode qual
-
- | summary = ppShortDataDecl summary False dataDecl unicode qual
- | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit
-
- where
- docname = tcdName dataDecl
- cons = dd_cons (tcdDataDefn dataDecl)
- resTy = (con_res . unLoc . head) cons
-
- header_ = topDeclElem links loc splice [docname] $
- ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix
-
- fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual
-
- whereBit
- | null cons = noHtml
- | otherwise = case resTy of
- ResTyGADT _ -> keyword "where"
- _ -> noHtml
-
- constrBit = subConstructors qual
- [ ppSideBySideConstr subdocs subfixs unicode qual c
- | c <- cons
- , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities
- ]
-
- instancesBit = ppInstances instances docname unicode qual
-
-
-
-ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html
-ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot
- where
- (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual
-
-
--- returns three pieces: header, body, footer so that header & footer can be
--- incorporated into the declaration
-ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html)
-ppShortConstrParts summary dataInst con unicode qual = case con_res con of
- ResTyH98 -> case con_details con of
- PrefixCon args ->
- (header_ unicode qual +++ hsep (ppBinder summary occ
- : map (ppLParendType unicode qual) args), noHtml, noHtml)
- RecCon fields ->
- (header_ unicode qual +++ ppBinder summary occ <+> char '{',
- doRecordFields fields,
- char '}')
- InfixCon arg1 arg2 ->
- (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,
- ppBinderInfix summary occ, ppLParendType unicode qual arg2],
- noHtml, noHtml)
-
- ResTyGADT resTy -> case con_details con of
- -- prefix & infix could use hsConDeclArgTys if it seemed to
- -- simplify the code.
- PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)
- -- display GADT records with the new syntax,
- -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b)
- -- (except each field gets its own line in docs, to match
- -- non-GADT records)
- RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>
- ppForAll forall_ ltvs lcontext unicode qual <+> char '{',
- doRecordFields fields,
- char '}' <+> arrow unicode <+> ppLType unicode qual resTy)
- InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml)
-
- where
- doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)
- doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [
- ppForAll forall_ ltvs lcontext unicode qual,
- ppLType unicode qual (foldr mkFunTy resTy args) ]
-
- header_ = ppConstrHdr forall_ tyVars context
- occ = nameOccName . getName . unLoc . con_name $ con
- ltvs = con_qvars con
- tyVars = tyvarNames ltvs
- lcontext = con_cxt con
- context = unLoc (con_cxt con)
- forall_ = con_explicit con
- mkFunTy a b = noLoc (HsFunTy a b)
-
-
--- ppConstrHdr is for (non-GADT) existentials constructors' syntax
-ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode
- -> Qualification -> Html
-ppConstrHdr forall_ tvs ctxt unicode qual
- = (if null tvs then noHtml else ppForall)
- +++
- (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual
- <+> darrow unicode +++ toHtml " ")
- where
- ppForall = case forall_ of
- Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "
- Implicit -> noHtml
-
-
-ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)]
- -> Unicode -> Qualification -> LConDecl DocName -> SubDecl
-ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart)
- where
- decl = case con_res con of
- ResTyH98 -> case con_details con of
- PrefixCon args ->
- hsep ((header_ +++ ppBinder False occ)
- : map (ppLParendType unicode qual) args)
- <+> fixity
-
- RecCon _ -> header_ +++ ppBinder False occ <+> fixity
-
- InfixCon arg1 arg2 ->
- hsep [header_ +++ ppLParendType unicode qual arg1,
- ppBinderInfix False occ,
- ppLParendType unicode qual arg2]
- <+> fixity
-
- ResTyGADT resTy -> case con_details con of
- -- prefix & infix could also use hsConDeclArgTys if it seemed to
- -- simplify the code.
- PrefixCon args -> doGADTCon args resTy
- cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
- InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
-
- fieldPart = case con_details con of
- RecCon fields -> [doRecordFields fields]
- _ -> []
-
- doRecordFields fields = subFields qual
- (map (ppSideBySideField subdocs unicode qual) fields)
- doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html
- doGADTCon args resTy = ppBinder False occ <+> dcolon unicode
- <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual,
- ppLType unicode qual (foldr mkFunTy resTy args) ]
- <+> fixity
-
- fixity = ppFixities fixities qual
- header_ = ppConstrHdr forall_ tyVars context unicode qual
- occ = nameOccName . getName . unLoc . con_name $ con
- ltvs = con_qvars con
- tyVars = tyvarNames (con_qvars con)
- context = unLoc (con_cxt con)
- forall_ = con_explicit con
- -- don't use "con_doc con", in case it's reconstructed from a .hi file,
- -- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst
- mkFunTy a b = noLoc (HsFunTy a b)
-
-
-ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification
- -> ConDeclField DocName -> SubDecl
-ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =
- (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,
- mbDoc,
- [])
- where
- -- don't use cd_fld_doc for same reason we don't use con_doc above
- mbDoc = lookup name subdocs >>= combineDocumentation . fst
-
-
-ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html
-ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)
- = ppBinder summary (nameOccName . getName $ name)
- <+> dcolon unicode <+> ppLType unicode qual ltype
-
-
--- | Print the LHS of a data\/newtype declaration.
--- Currently doesn't handle 'data instance' decls or kind signatures
-ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html
-ppDataHeader summary decl@(DataDecl { tcdDataDefn =
- HsDataDefn { dd_ND = nd
- , dd_ctxt = ctxt
- , dd_kindSig = ks } })
- unicode qual
- = -- newtype or data
- (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" })
- <+>
- -- context
- ppLContext ctxt unicode qual <+>
- -- T a b c ..., or a :+: b
- ppDataBinderWithVars summary decl
- <+> case ks of
- Nothing -> mempty
- Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x
-
-ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument"
-
---------------------------------------------------------------------------------
--- * Types and contexts
---------------------------------------------------------------------------------
-
-
-ppBang :: HsBang -> Html
-ppBang HsNoBang = noHtml
-ppBang _ = toHtml "!" -- Unpacked args is an implementation detail,
- -- so we just show the strictness annotation
-
-
-tupleParens :: HsTupleSort -> [Html] -> Html
-tupleParens HsUnboxedTuple = ubxParenList
-tupleParens _ = parenList
-
-
---------------------------------------------------------------------------------
--- * Rendering of HsType
---------------------------------------------------------------------------------
-
-
-pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int
-
-pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC
-pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type
- -- (as opposed to (ctx1, ctx2) => type)
-pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC
- -- Used for LH arg of (->)
-pREC_OP = 3 :: Int -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = 4 :: Int -- Used for arg of type applicn:
- -- always parenthesise unless atomic
-
-maybeParen :: Int -- Precedence of context
- -> Int -- Precedence of top-level operator
- -> Html -> Html -- Wrap in parens if (ctxt >= op)
-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
- | otherwise = p
-
-
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification
- -> Located (HsType DocName) -> Html
-ppLType unicode qual y = ppType unicode qual (unLoc y)
-ppLParendType unicode qual y = ppParendType unicode qual (unLoc y)
-ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y)
-
-
-ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification
- -> HsType DocName -> Html
-ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual
-ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual
-ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual
-ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual
-
-ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html
-ppLKind unicode qual y = ppKind unicode qual (unLoc y)
-
-ppKind :: Unicode -> Qualification -> HsKind DocName -> Html
-ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual
-
--- Drop top-level for-all type variables in user style
--- since they are implicit in Haskell
-
-ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName
- -> Located (HsContext DocName) -> Unicode -> Qualification -> Html
-ppForAll expl tvs cxt unicode qual
- | show_forall = forall_part <+> ppLContext cxt unicode qual
- | otherwise = ppLContext cxt unicode qual
- where
- show_forall = not (null (hsQTvBndrs tvs)) && is_explicit
- is_explicit = case expl of {Explicit -> True; Implicit -> False}
- forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot
-
-
-ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html
-ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
-
-
-ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual
- = maybeParen ctxt_prec pREC_FUN $
- hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual]
-
--- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar name) True _
- | getOccString (getName name) == "*" = toHtml "★"
- | getOccString (getName name) == "(->)" = toHtml "(→)"
-
-ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty
-ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name
-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q
-ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys)
-ppr_mono_ty _ (HsKindSig ty kind) u q =
- parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)
-ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q =
- maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q
-ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"
-ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"
-ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys
-ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy"
-
-ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual
- = maybeParen ctxt_prec pREC_CTX $
- ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual
-
-ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual
- = maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual]
-
-ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual
- = maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual
- where
- ppr_op = ppLDocName qual Infix op
-
-ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual
--- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode qual
-
-ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual
- = ppr_mono_lty ctxt_prec ty unicode qual
-
-ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n
-
-ppr_tylit :: HsTyLit -> Html
-ppr_tylit (HsNumTy n) = toHtml (show n)
-ppr_tylit (HsStrTy s) = toHtml (show s)
-
-
-ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual
- p2 = ppr_mono_lty pREC_TOP ty2 unicode qual
- in
- maybeParen ctxt_prec pREC_FUN $
- hsep [p1, arrow unicode <+> p2]
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
deleted file mode 100644
index 5e27d9b0..00000000
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ /dev/null
@@ -1,143 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.DocMarkup
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.DocMarkup (
- docToHtml,
- rdrDocToHtml,
- origDocToHtml,
- docToHtmlNoAnchors,
-
- docElement, docSection, docSection_,
-) where
-
-import Control.Applicative ((<$>))
-
-import Haddock.Backends.Xhtml.Names
-import Haddock.Backends.Xhtml.Utils
-import Haddock.Types
-import Haddock.Utils
-import Haddock.Doc (combineDocumentation)
-
-import Text.XHtml hiding ( name, p, quote )
-import Data.Maybe (fromMaybe)
-
-import GHC
-
-parHtmlMarkup :: Qualification -> Bool
- -> (Bool -> a -> Html) -> DocMarkup a Html
-parHtmlMarkup qual insertAnchors ppId = Markup {
- markupEmpty = noHtml,
- markupString = toHtml,
- markupParagraph = paragraph,
- markupAppend = (+++),
- markupIdentifier = thecode . ppId insertAnchors,
- markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
- markupModule = \m -> let (mdl,ref) = break (=='#') m
- -- Accomodate for old style
- -- foo\#bar anchors
- mdl' = case reverse mdl of
- '\\':_ -> init mdl
- _ -> mdl
- in ppModuleRef (mkModuleName mdl') ref,
- markupWarning = thediv ! [theclass "warning"],
- markupEmphasis = emphasize,
- markupBold = strong,
- markupMonospaced = thecode,
- markupUnorderedList = unordList,
- markupOrderedList = ordList,
- markupDefList = defList,
- markupCodeBlock = pre,
- markupHyperlink = \(Hyperlink url mLabel)
- -> if insertAnchors
- then anchor ! [href url]
- << fromMaybe url mLabel
- else toHtml $ fromMaybe url mLabel,
- markupAName = \aname -> namedAnchor aname << "",
- markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
- markupProperty = pre . toHtml,
- markupExample = examplesToHtml,
- markupHeader = \(Header l t) -> makeHeader l t
- }
- where
- makeHeader :: Int -> Html -> Html
- makeHeader 1 mkup = h1 mkup
- makeHeader 2 mkup = h2 mkup
- makeHeader 3 mkup = h3 mkup
- makeHeader 4 mkup = h4 mkup
- makeHeader 5 mkup = h5 mkup
- makeHeader 6 mkup = h6 mkup
- makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
-
-
- examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
-
- exampleToHtml (Example expression result) = htmlExample
- where
- htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
- htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
- htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
-
-
--- If the doc is a single paragraph, don't surround it with <P> (this causes
--- ugly extra whitespace with some browsers). FIXME: Does this still apply?
-docToHtml :: Qualification -> Doc DocName -> Html
-docToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup qual True (ppDocName qual Raw)
-
--- | Same as 'docToHtml' but it doesn't insert the 'anchor' element
--- in links. This is used to generate the Contents box elements.
-docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html
-docToHtmlNoAnchors qual = markup fmt . cleanup
- where fmt = parHtmlMarkup qual False (ppDocName qual Raw)
-
-origDocToHtml :: Qualification -> Doc Name -> Html
-origDocToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup qual True (const $ ppName Raw)
-
-
-rdrDocToHtml :: Qualification -> Doc RdrName -> Html
-rdrDocToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup qual True (const ppRdrName)
-
-
-docElement :: (Html -> Html) -> Html -> Html
-docElement el content_ =
- if isNoHtml content_
- then el ! [theclass "doc empty"] << spaceHtml
- else el ! [theclass "doc"] << content_
-
-
-docSection :: Qualification -> Documentation DocName -> Html
-docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
-
-
-docSection_ :: Qualification -> Doc DocName -> Html
-docSection_ qual = (docElement thediv <<) . docToHtml qual
-
-
-cleanup :: Doc a -> Doc a
-cleanup = markup fmtUnParagraphLists
- where
- -- If there is a single paragraph, then surrounding it with <P>..</P>
- -- can add too much whitespace in some browsers (eg. IE). However if
- -- we have multiple paragraphs, then we want the extra whitespace to
- -- separate them. So we catch the single paragraph case and transform it
- -- here. We don't do this in code blocks as it eliminates line breaks.
- unParagraph :: Doc a -> Doc a
- unParagraph (DocParagraph d) = d
- unParagraph doc = doc
-
- fmtUnParagraphLists :: DocMarkup a (Doc a)
- fmtUnParagraphLists = idMarkup {
- markupUnorderedList = DocUnorderedList . map unParagraph,
- markupOrderedList = DocOrderedList . map unParagraph
- }
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
deleted file mode 100644
index e84a57b3..00000000
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ /dev/null
@@ -1,235 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.Layout
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.Layout (
- miniBody,
-
- divPackageHeader, divContent, divModuleHeader, divFooter,
- divTableOfContents, divDescription, divSynposis, divInterface,
- divIndex, divAlphabet, divModuleList,
-
- sectionName,
- nonEmptySectionName,
-
- shortDeclList,
- shortSubDecls,
-
- divTopDecl,
-
- SubDecl,
- subArguments,
- subAssociatedTypes,
- subConstructors,
- subEquations,
- subFields,
- subInstances,
- subMethods,
- subMinimal,
-
- topDeclElem, declElem,
-) where
-
-
-import Haddock.Backends.Xhtml.DocMarkup
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
-import Haddock.Types
-import Haddock.Utils (makeAnchorId)
-
-import qualified Data.Map as Map
-import Text.XHtml hiding ( name, title, p, quote )
-
-import FastString ( unpackFS )
-import GHC
-
-
---------------------------------------------------------------------------------
--- * Sections of the document
---------------------------------------------------------------------------------
-
-
-miniBody :: Html -> Html
-miniBody = body ! [identifier "mini"]
-
-
-sectionDiv :: String -> Html -> Html
-sectionDiv i = thediv ! [identifier i]
-
-
-sectionName :: Html -> Html
-sectionName = paragraph ! [theclass "caption"]
-
-
--- | Make an element that always has at least something (a non-breaking space).
--- If it would have otherwise been empty, then give it the class ".empty".
-nonEmptySectionName :: Html -> Html
-nonEmptySectionName c
- | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
- | otherwise = paragraph ! [theclass "caption"] $ c
-
-
-divPackageHeader, divContent, divModuleHeader, divFooter,
- divTableOfContents, divDescription, divSynposis, divInterface,
- divIndex, divAlphabet, divModuleList
- :: Html -> Html
-
-divPackageHeader = sectionDiv "package-header"
-divContent = sectionDiv "content"
-divModuleHeader = sectionDiv "module-header"
-divFooter = sectionDiv "footer"
-divTableOfContents = sectionDiv "table-of-contents"
-divDescription = sectionDiv "description"
-divSynposis = sectionDiv "synopsis"
-divInterface = sectionDiv "interface"
-divIndex = sectionDiv "index"
-divAlphabet = sectionDiv "alphabet"
-divModuleList = sectionDiv "module-list"
-
-
---------------------------------------------------------------------------------
--- * Declaration containers
---------------------------------------------------------------------------------
-
-
-shortDeclList :: [Html] -> Html
-shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
-
-
-shortSubDecls :: Bool -> [Html] -> Html
-shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items
- where i | inst = li ! [theclass "inst"]
- | otherwise = li
- c | inst = "inst"
- | otherwise = "subs"
-
-
-divTopDecl :: Html -> Html
-divTopDecl = thediv ! [theclass "top"]
-
-
-type SubDecl = (Html, Maybe (Doc DocName), [Html])
-
-
-divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html
-divSubDecls cssClass captionName = maybe noHtml wrap
- where
- wrap = (subSection <<) . (subCaption +++)
- subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
- subCaption = paragraph ! [theclass "caption"] << captionName
-
-
-subDlist :: Qualification -> [SubDecl] -> Maybe Html
-subDlist _ [] = Nothing
-subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
- where
- subEntry (decl, mdoc, subs) =
- dterm ! [theclass "src"] << decl
- +++
- docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
-
- clearDiv = thediv ! [ theclass "clear" ] << noHtml
-
-
-subTable :: Qualification -> [SubDecl] -> Maybe Html
-subTable _ [] = Nothing
-subTable qual decls = Just $ table << aboves (concatMap subRow decls)
- where
- subRow (decl, mdoc, subs) =
- (td ! [theclass "src"] << decl
- <->
- docElement td << fmap (docToHtml qual) mdoc)
- : map (cell . (td <<)) subs
-
-
-subBlock :: [Html] -> Maybe Html
-subBlock [] = Nothing
-subBlock hs = Just $ toHtml hs
-
-
-subArguments :: Qualification -> [SubDecl] -> Html
-subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
-
-
-subAssociatedTypes :: [Html] -> Html
-subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
-
-
-subConstructors :: Qualification -> [SubDecl] -> Html
-subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
-
-
-subFields :: Qualification -> [SubDecl] -> Html
-subFields qual = divSubDecls "fields" "Fields" . subDlist qual
-
-
-subEquations :: Qualification -> [SubDecl] -> Html
-subEquations qual = divSubDecls "equations" "Equations" . subTable qual
-
-
-subInstances :: Qualification -> String -> [SubDecl] -> Html
-subInstances qual nm = maybe noHtml wrap . instTable
- where
- wrap = (subSection <<) . (subCaption +++)
- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
- subSection = thediv ! [theclass "subs instances"]
- subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
- id_ = makeAnchorId $ "i:" ++ nm
-
-subMethods :: [Html] -> Html
-subMethods = divSubDecls "methods" "Methods" . subBlock
-
-subMinimal :: Html -> Html
-subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
-
-
--- a box for displaying code
-declElem :: Html -> Html
-declElem = paragraph ! [theclass "src"]
-
-
--- a box for top level documented names
--- it adds a source and wiki link at the right hand side of the box
-topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
-topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
- declElem << (html <+> srcLink <+> wikiLink)
- where srcLink = let nameUrl = Map.lookup origPkg sourceMap
- lineUrl = Map.lookup origPkg lineMap
- mUrl | splice = lineUrl
- -- Use the lineUrl as a backup
- | otherwise = maybe lineUrl Just nameUrl in
- case mUrl of
- Nothing -> noHtml
- Just url -> let url' = spliceURL (Just fname) (Just origMod)
- (Just n) (Just loc) url
- in anchor ! [href url', theclass "link"] << "Source"
-
- wikiLink =
- case maybe_wiki_url of
- Nothing -> noHtml
- Just url -> let url' = spliceURL (Just fname) (Just mdl)
- (Just n) (Just loc) url
- in anchor ! [href url', theclass "link"] << "Comments"
-
- -- For source links, we want to point to the original module,
- -- because only that will have the source.
- -- TODO: do something about type instances. They will point to
- -- the module defining the type family, which is wrong.
- origMod = nameModule n
- origPkg = modulePackageId origMod
-
- -- Name must be documented, otherwise we wouldn't get here
- Documented n mdl = head names
- -- FIXME: is it ok to simply take the first name?
-
- fname = case loc of
- RealSrcSpan l -> unpackFS (srcSpanFile l)
- UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
deleted file mode 100644
index cf12da40..00000000
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ /dev/null
@@ -1,171 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.Names
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.Names (
- ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
- ppBinder, ppBinderInfix, ppBinder',
- ppModule, ppModuleRef, ppIPName, linkId, Notation(..)
-) where
-
-
-import Haddock.Backends.Xhtml.Utils
-import Haddock.GhcUtils
-import Haddock.Types
-import Haddock.Utils
-
-import Text.XHtml hiding ( name, title, p, quote )
-import qualified Data.Map as M
-import qualified Data.List as List
-
-import GHC
-import Name
-import RdrName
-import FastString (unpackFS)
-
-
--- | Indicator of how to render a 'DocName' into 'Html'
-data Notation = Raw -- ^ Render as-is.
- | Infix -- ^ Render using infix notation.
- | Prefix -- ^ Render using prefix notation.
- deriving (Eq, Show)
-
-ppOccName :: OccName -> Html
-ppOccName = toHtml . occNameString
-
-
-ppRdrName :: RdrName -> Html
-ppRdrName = ppOccName . rdrNameOcc
-
-ppIPName :: HsIPName -> Html
-ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS
-
-
-ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
-ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
-
-
--- The Bool indicates if it is to be rendered in infix notation
-ppLDocName :: Qualification -> Notation -> Located DocName -> Html
-ppLDocName qual notation (L _ d) = ppDocName qual notation True d
-
-ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
-ppDocName qual notation insertAnchors docName =
- case docName of
- Documented name mdl ->
- linkIdOcc mdl (Just (nameOccName name)) insertAnchors
- << ppQualifyName qual notation name mdl
- Undocumented name
- | isExternalName name || isWiredInName name ->
- ppQualifyName qual notation name (nameModule name)
- | otherwise -> ppName notation name
-
--- | Render a name depending on the selected qualification mode
-ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html
-ppQualifyName qual notation name mdl =
- case qual of
- NoQual -> ppName notation name
- FullQual -> ppFullQualName notation mdl name
- LocalQual localmdl ->
- if moduleString mdl == moduleString localmdl
- then ppName notation name
- else ppFullQualName notation mdl name
- RelativeQual localmdl ->
- case List.stripPrefix (moduleString localmdl) (moduleString mdl) of
- -- local, A.x -> x
- Just [] -> ppName notation name
- -- sub-module, A.B.x -> B.x
- Just ('.':m) -> toHtml $ m ++ '.' : getOccString name
- -- some module with same prefix, ABC.x -> ABC.x
- Just _ -> ppFullQualName notation mdl name
- -- some other module, D.x -> D.x
- Nothing -> ppFullQualName notation mdl name
- AliasedQual aliases localmdl ->
- case (moduleString mdl == moduleString localmdl,
- M.lookup mdl aliases) of
- (False, Just alias) -> ppQualName notation alias name
- _ -> ppName notation name
-
-
-ppFullQualName :: Notation -> Module -> Name -> Html
-ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname
- where
- qname = toHtml $ moduleString mdl ++ '.' : getOccString name
-
-ppQualName :: Notation -> ModuleName -> Name -> Html
-ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname
- where
- qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name
-
-ppName :: Notation -> Name -> Html
-ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name)
-
-
-ppBinder :: Bool -> OccName -> Html
--- The Bool indicates whether we are generating the summary, in which case
--- the binder will be a link to the full definition.
-ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n
-ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
- << ppBinder' Prefix n
-
-ppBinderInfix :: Bool -> OccName -> Html
-ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n
-ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"]
- << ppBinder' Infix n
-
-ppBinder' :: Notation -> OccName -> Html
-ppBinder' notation n = wrapInfix notation n $ ppOccName n
-
-wrapInfix :: Notation -> OccName -> Html -> Html
-wrapInfix notation n = case notation of
- Infix | is_star_kind -> id
- | not is_sym -> quote
- Prefix | is_star_kind -> id
- | is_sym -> parens
- _ -> id
- where
- is_sym = isSymOcc n
- is_star_kind = isTcOcc n && occNameString n == "*"
-
-linkId :: Module -> Maybe Name -> Html -> Html
-linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True
-
-
-linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html
-linkIdOcc mdl mbName insertAnchors =
- if insertAnchors
- then anchor ! [href url]
- else id
- where
- url = case mbName of
- Nothing -> moduleUrl mdl
- Just name -> moduleNameUrl mdl name
-
-
-linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
-linkIdOcc' mdl mbName = anchor ! [href url]
- where
- url = case mbName of
- Nothing -> moduleHtmlFile' mdl
- Just name -> moduleNameUrl' mdl name
-
-
-ppModule :: Module -> Html
-ppModule mdl = anchor ! [href (moduleUrl mdl)]
- << toHtml (moduleString mdl)
-
-
-ppModuleRef :: ModuleName -> String -> Html
-ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)]
- << toHtml (moduleNameString mdl)
- -- NB: The ref parameter already includes the '#'.
- -- This function is only called from markupModule expanding a
- -- DocModule, which doesn't seem to be ever be used.
diff --git a/src/Haddock/Backends/Xhtml/Themes.hs b/src/Haddock/Backends/Xhtml/Themes.hs
deleted file mode 100644
index 79b093ec..00000000
--- a/src/Haddock/Backends/Xhtml/Themes.hs
+++ /dev/null
@@ -1,209 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.Themes
--- Copyright : (c) Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.Themes (
- Themes,
- getThemes,
-
- cssFiles, styleSheet
- )
- where
-
-import Haddock.Options
-
-import Control.Applicative
-import Control.Monad (liftM)
-import Data.Char (toLower)
-import Data.Either (lefts, rights)
-import Data.List (nub)
-import Data.Maybe (isJust, listToMaybe)
-
-import System.Directory
-import System.FilePath
-import Text.XHtml hiding ( name, title, p, quote, (</>) )
-import qualified Text.XHtml as XHtml
-
-
---------------------------------------------------------------------------------
--- * CSS Themes
---------------------------------------------------------------------------------
-
-data Theme = Theme {
- themeName :: String,
- themeHref :: String,
- themeFiles :: [FilePath]
- }
-
-type Themes = [Theme]
-
-type PossibleTheme = Either String Theme
-type PossibleThemes = Either String Themes
-
-
--- | Find a theme by name (case insensitive match)
-findTheme :: String -> Themes -> Maybe Theme
-findTheme s = listToMaybe . filter ((== ls).lower.themeName)
- where lower = map toLower
- ls = lower s
-
-
--- | Standard theme used by default
-standardTheme :: FilePath -> IO PossibleThemes
-standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir)
-
-
--- | Default themes that are part of Haddock; added with --default-themes
--- The first theme in this list is considered the standard theme.
--- Themes are "discovered" by scanning the html sub-dir of the libDir,
--- and looking for directories with the extension .theme or .std-theme.
--- The later is, obviously, the standard theme.
-defaultThemes :: FilePath -> IO PossibleThemes
-defaultThemes libDir = do
- themeDirs <- getDirectoryItems (libDir </> "html")
- themes <- mapM directoryTheme $ discoverThemes themeDirs
- return $ sequenceEither themes
- where
- discoverThemes paths =
- filterExt ".std-theme" paths ++ filterExt ".theme" paths
- filterExt ext = filter ((== ext).takeExtension)
-
-
--- | Build a theme from a single .css file
-singleFileTheme :: FilePath -> IO PossibleTheme
-singleFileTheme path =
- if isCssFilePath path
- then retRight $ Theme name file [path]
- else errMessage "File extension isn't .css" path
- where
- name = takeBaseName path
- file = takeFileName path
-
-
--- | Build a theme from a directory
-directoryTheme :: FilePath -> IO PossibleTheme
-directoryTheme path = do
- items <- getDirectoryItems path
- case filter isCssFilePath items of
- [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items
- [] -> errMessage "No .css file in theme directory" path
- _ -> errMessage "More than one .css file in theme directory" path
-
-
--- | Check if we have a built in theme
-doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool
-doesBuiltInExist pts s = fmap (either (const False) test) pts
- where test = isJust . findTheme s
-
-
--- | Find a built in theme
-builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme
-builtInTheme pts s = either Left fetch <$> pts
- where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s
-
-
---------------------------------------------------------------------------------
--- * CSS Theme Arguments
---------------------------------------------------------------------------------
-
--- | Process input flags for CSS Theme arguments
-getThemes :: FilePath -> [Flag] -> IO PossibleThemes
-getThemes libDir flags =
- liftM concatEither (mapM themeFlag flags) >>= someTheme
- where
- themeFlag :: Flag -> IO (Either String Themes)
- themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path)
- themeFlag (Flag_BuiltInThemes) = builtIns
- themeFlag _ = retRight []
-
- theme :: FilePath -> IO PossibleTheme
- theme path = pick path
- [(doesFileExist, singleFileTheme),
- (doesDirectoryExist, directoryTheme),
- (doesBuiltInExist builtIns, builtInTheme builtIns)]
- "Theme not found"
-
- pick :: FilePath
- -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String
- -> IO PossibleTheme
- pick path [] msg = errMessage msg path
- pick path ((test,build):opts) msg = do
- pass <- test path
- if pass then build path else pick path opts msg
-
-
- someTheme :: Either String Themes -> IO (Either String Themes)
- someTheme (Right []) = standardTheme libDir
- someTheme est = return est
-
- builtIns = defaultThemes libDir
-
-
-errMessage :: String -> FilePath -> IO (Either String a)
-errMessage msg path = return (Left msg')
- where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n"
-
-
-retRight :: a -> IO (Either String a)
-retRight = return . Right
-
-
---------------------------------------------------------------------------------
--- * File Utilities
---------------------------------------------------------------------------------
-
-
-getDirectoryItems :: FilePath -> IO [FilePath]
-getDirectoryItems path =
- map (combine path) . filter notDot <$> getDirectoryContents path
- where notDot s = s /= "." && s /= ".."
-
-
-isCssFilePath :: FilePath -> Bool
-isCssFilePath path = takeExtension path == ".css"
-
-
---------------------------------------------------------------------------------
--- * Style Sheet Utilities
---------------------------------------------------------------------------------
-
-cssFiles :: Themes -> [String]
-cssFiles ts = nub $ concatMap themeFiles ts
-
-
-styleSheet :: Themes -> Html
-styleSheet ts = toHtml $ zipWith mkLink rels ts
- where
- rels = "stylesheet" : repeat "alternate stylesheet"
- mkLink aRel t =
- thelink
- ! [ href (themeHref t), rel aRel, thetype "text/css",
- XHtml.title (themeName t)
- ]
- << noHtml
-
---------------------------------------------------------------------------------
--- * Either Utilities
---------------------------------------------------------------------------------
-
--- These three routines are here because Haddock does not have access to the
--- Control.Monad.Error module which supplies the Functor and Monad instances
--- for Either String.
-
-sequenceEither :: [Either a b] -> Either a [b]
-sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es))
-
-
-liftEither :: (b -> c) -> Either a b -> Either a c
-liftEither f = either Left (Right . f)
-
-
-concatEither :: [Either a [b]] -> Either a [b]
-concatEither = liftEither concat . sequenceEither
-
diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs
deleted file mode 100644
index 122861c3..00000000
--- a/src/Haddock/Backends/Xhtml/Types.hs
+++ /dev/null
@@ -1,37 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.Types
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.Types (
- SourceURLs, WikiURLs,
- LinksInfo,
- Splice,
- Unicode,
-) where
-
-
-import Data.Map
-import GHC
-
-
--- the base, module and entity URLs for the source code and wiki links.
-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)
-type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
-
-
--- The URL for source and wiki links
-type LinksInfo = (SourceURLs, WikiURLs)
-
--- Whether something is a splice or not
-type Splice = Bool
-
--- Whether unicode syntax is to be used
-type Unicode = Bool
diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs
deleted file mode 100644
index cbcbbd6d..00000000
--- a/src/Haddock/Backends/Xhtml/Utils.hs
+++ /dev/null
@@ -1,218 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Backends.Html.Util
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mark Lentczner 2010
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Backends.Xhtml.Utils (
- renderToString,
-
- namedAnchor, linkedAnchor,
- spliceURL,
- groupId,
-
- (<+>), (<=>), char,
- keyword, punctuate,
-
- braces, brackets, pabrackets, parens, parenList, ubxParenList,
- arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote,
-
- hsep, vcat,
-
- collapseSection, collapseToggle, collapseControl,
-) where
-
-
-import Haddock.GhcUtils
-import Haddock.Utils
-
-import Data.Maybe
-
-import Text.XHtml hiding ( name, title, p, quote )
-import qualified Text.XHtml as XHtml
-
-import GHC ( SrcSpan(..), srcSpanStartLine, Name )
-import Module ( Module )
-import Name ( getOccString, nameOccName, isValOcc )
-
-
-spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
- Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
- where
- file = fromMaybe "" maybe_file
- mdl = case maybe_mod of
- Nothing -> ""
- Just m -> moduleString m
-
- (name, kind) =
- case maybe_name of
- Nothing -> ("","")
- Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v")
- | otherwise -> (escapeStr (getOccString n), "t")
-
- line = case maybe_loc of
- Nothing -> ""
- Just span_ ->
- case span_ of
- RealSrcSpan span__ ->
- show $ srcSpanStartLine span__
- UnhelpfulSpan _ ->
- error "spliceURL UnhelpfulSpan"
-
- run "" = ""
- run ('%':'M':rest) = mdl ++ run rest
- run ('%':'F':rest) = file ++ run rest
- run ('%':'N':rest) = name ++ run rest
- run ('%':'K':rest) = kind ++ run rest
- run ('%':'L':rest) = line ++ run rest
- run ('%':'%':rest) = '%' : run rest
-
- run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest
- run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest
- run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest
- run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest
-
- run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) =
- map (\x -> if x == '.' then c else x) mdl ++ run rest
-
- run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) =
- map (\x -> if x == '/' then c else x) file ++ run rest
-
- run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest
-
- run (c:rest) = c : run rest
-
-
-renderToString :: Bool -> Html -> String
-renderToString debug html
- | debug = renderHtml html
- | otherwise = showHtml html
-
-
-hsep :: [Html] -> Html
-hsep [] = noHtml
-hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls
-
--- | Concatenate a series of 'Html' values vertically, with linebreaks in between.
-vcat :: [Html] -> Html
-vcat [] = noHtml
-vcat htmls = foldr1 (\a b -> a+++br+++b) htmls
-
-
-infixr 8 <+>
-(<+>) :: Html -> Html -> Html
-a <+> b = a +++ sep +++ b
- where
- sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " "
-
--- | Join two 'Html' values together with a linebreak in between.
--- Has 'noHtml' as left identity.
-infixr 8 <=>
-(<=>) :: Html -> Html -> Html
-a <=> b = a +++ sep +++ b
- where
- sep = if isNoHtml a then noHtml else br
-
-
-keyword :: String -> Html
-keyword s = thespan ! [theclass "keyword"] << toHtml s
-
-
-equals, comma :: Html
-equals = char '='
-comma = char ','
-
-
-char :: Char -> Html
-char c = toHtml [c]
-
-
-quote :: Html -> Html
-quote h = char '`' +++ h +++ '`'
-
-
-parens, brackets, pabrackets, braces :: Html -> Html
-parens h = char '(' +++ h +++ char ')'
-brackets h = char '[' +++ h +++ char ']'
-pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"
-braces h = char '{' +++ h +++ char '}'
-
-
-punctuate :: Html -> [Html] -> [Html]
-punctuate _ [] = []
-punctuate h (d0:ds) = go d0 ds
- where
- go d [] = [d]
- go d (e:es) = (d +++ h) : go e es
-
-
-parenList :: [Html] -> Html
-parenList = parens . hsep . punctuate comma
-
-
-ubxParenList :: [Html] -> Html
-ubxParenList = ubxparens . hsep . punctuate comma
-
-
-ubxparens :: Html -> Html
-ubxparens h = toHtml "(#" +++ h +++ toHtml "#)"
-
-
-dcolon, arrow, darrow, forallSymbol :: Bool -> Html
-dcolon unicode = toHtml (if unicode then "∷" else "::")
-arrow unicode = toHtml (if unicode then "→" else "->")
-darrow unicode = toHtml (if unicode then "⇒" else "=>")
-forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
-
-
-dot :: Html
-dot = toHtml "."
-
-
--- | Generate a named anchor
-namedAnchor :: String -> Html -> Html
-namedAnchor n = anchor ! [XHtml.name n]
-
-
-linkedAnchor :: String -> Html -> Html
-linkedAnchor n = anchor ! [href ('#':n)]
-
-
--- | generate an anchor identifier for a group
-groupId :: String -> String
-groupId g = makeAnchorId ("g:" ++ g)
-
---
--- A section of HTML which is collapsible.
---
-
--- | Attributes for an area that can be collapsed
-collapseSection :: String -> Bool -> String -> [HtmlAttr]
-collapseSection id_ state classes = [ identifier sid, theclass cs ]
- where cs = unwords (words classes ++ [pick state "show" "hide"])
- sid = "section." ++ id_
-
--- | Attributes for an area that toggles a collapsed area
-collapseToggle :: String -> [HtmlAttr]
-collapseToggle id_ = [ strAttr "onclick" js ]
- where js = "toggleSection('" ++ id_ ++ "')";
-
--- | Attributes for an area that toggles a collapsed area,
--- and displays a control.
-collapseControl :: String -> Bool -> String -> [HtmlAttr]
-collapseControl id_ state classes =
- [ identifier cid, theclass cs ] ++ collapseToggle id_
- where cs = unwords (words classes ++ [pick state "collapser" "expander"])
- cid = "control." ++ id_
-
-
-pick :: Bool -> a -> a -> a
-pick True t _ = t
-pick False _ f = f
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
deleted file mode 100644
index 73ff3f1a..00000000
--- a/src/Haddock/Convert.hs
+++ /dev/null
@@ -1,403 +0,0 @@
-{-# LANGUAGE CPP, PatternGuards #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Convert
--- Copyright : (c) Isaac Dupree 2009,
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Conversion between TyThing and HsDecl. This functionality may be moved into
--- GHC at some point.
------------------------------------------------------------------------------
-module Haddock.Convert where
--- Some other functions turned out to be useful for converting
--- instance heads, which aren't TyThings, so just export everything.
-
-
-import HsSyn
-import TcType ( tcSplitSigmaTy )
-import TypeRep
-import Type(isStrLitTy)
-import Kind ( splitKindFunTys, synTyConResKind, isKind )
-import Name
-import Var
-import Class
-import TyCon
-import CoAxiom
-import ConLike
-import DataCon
-import PatSyn
-import FamInstEnv
-import BasicTypes ( TupleSort(..) )
-import TysPrim ( alphaTyVars )
-import TysWiredIn ( listTyConName, eqTyCon )
-import PrelNames (ipClassName)
-import Bag ( emptyBag )
-import Unique ( getUnique )
-import SrcLoc ( Located, noLoc, unLoc )
-import Data.List( partition )
-import Haddock.Types
-
-
--- the main function here! yay!
-tyThingToLHsDecl :: TyThing -> LHsDecl Name
-tyThingToLHsDecl t = noLoc $ case t of
- -- ids (functions and zero-argument a.k.a. CAFs) get a type signature.
- -- Including built-in functions like seq.
- -- foreign-imported functions could be represented with ForD
- -- instead of SigD if we wanted...
- --
- -- in a future code version we could turn idVarDetails = foreign-call
- -- into a ForD instead of a SigD if we wanted. Haddock doesn't
- -- need to care.
- AnId i -> SigD (synifyIdSig ImplicitizeForAll i)
-
- -- type-constructors (e.g. Maybe) are complicated, put the definition
- -- later in the file (also it's used for class associated-types too.)
- ATyCon tc
- | Just cl <- tyConClass_maybe tc -- classes are just a little tedious
- -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a
- extractFamilyDecl (FamDecl d) = noLoc d
- extractFamilyDecl _ =
- error "tyThingToLHsDecl: impossible associated tycon"
-
- atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]
- atFamDecls = map extractFamilyDecl atTyClDecls in
- TyClD $ ClassDecl
- { tcdCtxt = synifyCtx (classSCTheta cl)
- , tcdLName = synifyName cl
- , tcdTyVars = synifyTyVars (classTyVars cl)
- , tcdFDs = map (\ (l,r) -> noLoc
- (map getName l, map getName r) ) $
- snd $ classTvsFds cl
- , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :
- map (noLoc . synifyIdSig DeleteTopLevelQuantification)
- (classMethods cl)
- , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature
- -- class associated-types are a subset of TyCon:
- , tcdATs = atFamDecls
- , tcdATDefs = [] --ignore associated type defaults
- , tcdDocs = [] --we don't have any docs at this point
- , tcdFVs = placeHolderNames }
- | otherwise
- -> TyClD (synifyTyCon Nothing tc)
-
- -- type-constructors (e.g. Maybe) are complicated, put the definition
- -- later in the file (also it's used for class associated-types too.)
- ACoAxiom ax -> synifyAxiom ax
-
- -- a data-constructor alone just gets rendered as a function:
- AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]
- (synifyType ImplicitizeForAll (dataConUserType dc)))
-
- AConLike (PatSynCon ps) ->
-#if MIN_VERSION_ghc(7,8,3)
- let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps
-#else
- let (_, _, (req_theta, prov_theta)) = patSynSig ps
-#endif
- in SigD $ PatSynSig (synifyName ps)
-#if MIN_VERSION_ghc(7,8,3)
- (fmap (synifyType WithinType) (patSynTyDetails ps))
- (synifyType WithinType res_ty)
-#else
- (fmap (synifyType WithinType) (patSynTyDetails ps))
- (synifyType WithinType (patSynType ps))
-#endif
- (synifyCtx req_theta)
- (synifyCtx prov_theta)
-
-synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name
-synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
- = let name = synifyName tc
- typats = map (synifyType WithinType) args
- hs_rhs = synifyType WithinType rhs
- (kvs, tvs) = partition isKindVar tkvs
- in TyFamInstEqn { tfie_tycon = name
- , tfie_pats = HsWB { hswb_cts = typats
- , hswb_kvs = map tyVarName kvs
- , hswb_tvs = map tyVarName tvs }
- , tfie_rhs = hs_rhs }
-
-synifyAxiom :: CoAxiom br -> HsDecl Name
-synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
- | isOpenSynFamilyTyCon tc
- , Just branch <- coAxiomSingleBranch_maybe ax
- = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch
- , tfid_fvs = placeHolderNames }))
-
- | Just ax' <- isClosedSynFamilyTyCon_maybe tc
- , getUnique ax' == getUnique ax -- without the getUniques, type error
- = TyClD (synifyTyCon (Just ax) tc)
-
- | otherwise
- = error "synifyAxiom: closed/open family confusion"
-
-synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name
-synifyTyCon coax tc
- | isFunTyCon tc || isPrimTyCon tc
- = DataDecl { tcdLName = synifyName tc
- , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:
- let mk_hs_tv realKind fakeTyVar
- = noLoc $ KindedTyVar (getName fakeTyVar)
- (synifyKindSig realKind)
- in HsQTvs { hsq_kvs = [] -- No kind polymorphism
- , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))
- alphaTyVars --a, b, c... which are unfortunately all kind *
- }
-
- , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither
- -- algebraic data nor newtype:
- , dd_ctxt = noLoc []
- , dd_cType = Nothing
- , dd_kindSig = Just (synifyKindSig (tyConKind tc))
- -- we have their kind accurately:
- , dd_cons = [] -- No constructors
- , dd_derivs = Nothing }
- , tcdFVs = placeHolderNames }
-
- | isSynFamilyTyCon tc
- = case synTyConRhs_maybe tc of
- Just rhs ->
- let info = case rhs of
- OpenSynFamilyTyCon -> OpenTypeFamily
- ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
- ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)
- _ -> error "synifyTyCon: type/data family confusion"
- in FamDecl (FamilyDecl { fdInfo = info
- , fdLName = synifyName tc
- , fdTyVars = synifyTyVars (tyConTyVars tc)
- , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })
- Nothing -> error "synifyTyCon: impossible open type synonym?"
-
- | isDataFamilyTyCon tc
- = --(why no "isOpenAlgTyCon"?)
- case algTyConRhs tc of
- DataFamilyTyCon ->
- FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))
- Nothing) --always kind '*'
- _ -> error "synifyTyCon: impossible open data type?"
- | isSynTyCon tc
- = case synTyConRhs_maybe tc of
- Just (SynonymTyCon ty) ->
- SynDecl { tcdLName = synifyName tc
- , tcdTyVars = synifyTyVars (tyConTyVars tc)
- , tcdRhs = synifyType WithinType ty
- , tcdFVs = placeHolderNames }
- _ -> error "synifyTyCon: impossible synTyCon"
- | otherwise =
- -- (closed) newtype and data
- let
- alg_nd = if isNewTyCon tc then NewType else DataType
- alg_ctx = synifyCtx (tyConStupidTheta tc)
- name = case coax of
- Just a -> synifyName a -- Data families are named according to their
- -- CoAxioms, not their TyCons
- _ -> synifyName tc
- tyvars = synifyTyVars (tyConTyVars tc)
- kindSig = Just (tyConKind tc)
- -- The data constructors.
- --
- -- Any data-constructors not exported from the module that *defines* the
- -- type will not (cannot) be included.
- --
- -- Very simple constructors, Haskell98 with no existentials or anything,
- -- probably look nicer in non-GADT syntax. In source code, all constructors
- -- must be declared with the same (GADT vs. not) syntax, and it probably
- -- is less confusing to follow that principle for the documentation as well.
- --
- -- There is no sensible infix-representation for GADT-syntax constructor
- -- declarations. They cannot be made in source code, but we could end up
- -- with some here in the case where some constructors use existentials.
- -- That seems like an acceptable compromise (they'll just be documented
- -- in prefix position), since, otherwise, the logic (at best) gets much more
- -- complicated. (would use dataConIsInfix.)
- use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)
- cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)
- -- "deriving" doesn't affect the signature, no need to specify any.
- alg_deriv = Nothing
- defn = HsDataDefn { dd_ND = alg_nd
- , dd_ctxt = alg_ctx
- , dd_cType = Nothing
- , dd_kindSig = fmap synifyKindSig kindSig
- , dd_cons = cons
- , dd_derivs = alg_deriv }
- in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn
- , tcdFVs = placeHolderNames }
-
--- User beware: it is your responsibility to pass True (use_gadt_syntax)
--- for any constructor that would be misrepresented by omitting its
--- result-type.
--- But you might want pass False in simple enough cases,
--- if you think it looks better.
-synifyDataCon :: Bool -> DataCon -> LConDecl Name
-synifyDataCon use_gadt_syntax dc = noLoc $
- let
- -- dataConIsInfix allegedly tells us whether it was declared with
- -- infix *syntax*.
- use_infix_syntax = dataConIsInfix dc
- use_named_field_syntax = not (null field_tys)
- name = synifyName dc
- -- con_qvars means a different thing depending on gadt-syntax
- (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc
-
- qvars = if use_gadt_syntax
- then synifyTyVars (univ_tvs ++ ex_tvs)
- else synifyTyVars ex_tvs
-
- -- skip any EqTheta, use 'orig'inal syntax
- ctx = synifyCtx theta
-
- linear_tys = zipWith (\ty bang ->
- let tySyn = synifyType WithinType ty
- src_bang = case bang of
- HsUnpack {} -> HsUserBang (Just True) True
- HsStrict -> HsUserBang (Just False) True
- _ -> bang
- in case src_bang of
- HsNoBang -> tySyn
- _ -> noLoc $ HsBangTy bang tySyn
- -- HsNoBang never appears, it's implied instead.
- )
- arg_tys (dataConStrictMarks dc)
- field_tys = zipWith (\field synTy -> ConDeclField
- (synifyName field) synTy Nothing)
- (dataConFieldLabels dc) linear_tys
- hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of
- (True,True) -> error "synifyDataCon: contradiction!"
- (True,False) -> RecCon field_tys
- (False,False) -> PrefixCon linear_tys
- (False,True) -> case linear_tys of
- [a,b] -> InfixCon a b
- _ -> error "synifyDataCon: infix with non-2 args?"
- hs_res_ty = if use_gadt_syntax
- then ResTyGADT (synifyType WithinType res_ty)
- else ResTyH98
- -- finally we get synifyDataCon's result!
- in ConDecl name Implicit{-we don't know nor care-}
- qvars ctx hs_arg_tys hs_res_ty Nothing
- False --we don't want any "deprecated GADT syntax" warnings!
-
-
-synifyName :: NamedThing n => n -> Located Name
-synifyName = noLoc . getName
-
-
-synifyIdSig :: SynifyTypeState -> Id -> Sig Name
-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))
-
-
-synifyCtx :: [PredType] -> LHsContext Name
-synifyCtx = noLoc . map (synifyType WithinType)
-
-
-synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name
-synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs
- , hsq_tvs = map synifyTyVar tvs }
- where
- (kvs, tvs) = partition isKindVar ktvs
- synifyTyVar tv
- | isLiftedTypeKind kind = noLoc (UserTyVar name)
- | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))
- where
- kind = tyVarKind tv
- name = getName tv
-
---states of what to do with foralls:
-data SynifyTypeState
- = WithinType
- -- ^ normal situation. This is the safe one to use if you don't
- -- quite understand what's going on.
- | ImplicitizeForAll
- -- ^ beginning of a function definition, in which, to make it look
- -- less ugly, those rank-1 foralls are made implicit.
- | DeleteTopLevelQuantification
- -- ^ because in class methods the context is added to the type
- -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@)
- -- which is rather sensible,
- -- but we want to restore things to the source-syntax situation where
- -- the defining class gets to quantify all its functions for free!
-
-
-synifyType :: SynifyTypeState -> Type -> LHsType Name
-synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv)
-synifyType _ (TyConApp tc tys)
- -- Use non-prefix tuple syntax where possible, because it looks nicer.
- | isTupleTyCon tc, tyConArity tc == length tys =
- noLoc $ HsTupleTy (case tupleTyConSort tc of
- BoxedTuple -> HsBoxedTuple
- ConstraintTuple -> HsConstraintTuple
- UnboxedTuple -> HsUnboxedTuple)
- (map (synifyType WithinType) tys)
- -- ditto for lists
- | getName tc == listTyConName, [ty] <- tys =
- noLoc $ HsListTy (synifyType WithinType ty)
- -- ditto for implicit parameter tycons
- | tyConName tc == ipClassName
- , [name, ty] <- tys
- , Just x <- isStrLitTy name
- = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty)
- -- and equalities
- | tc == eqTyCon
- , [ty1, ty2] <- tys
- = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2)
- -- Most TyCons:
- | otherwise =
- foldl (\t1 t2 -> noLoc (HsAppTy t1 t2))
- (noLoc $ HsTyVar (getName tc))
- (map (synifyType WithinType) tys)
-synifyType _ (AppTy t1 t2) = let
- s1 = synifyType WithinType t1
- s2 = synifyType WithinType t2
- in noLoc $ HsAppTy s1 s2
-synifyType _ (FunTy t1 t2) = let
- s1 = synifyType WithinType t1
- s2 = synifyType WithinType t2
- in noLoc $ HsFunTy s1 s2
-synifyType s forallty@(ForAllTy _tv _ty) =
- let (tvs, ctx, tau) = tcSplitSigmaTy forallty
- in case s of
- DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau
- _ -> let
- forallPlicitness = case s of
- WithinType -> Explicit
- ImplicitizeForAll -> Implicit
- _ -> error "synifyType: impossible case!!!"
- sTvs = synifyTyVars tvs
- sCtx = synifyCtx ctx
- sTau = synifyType WithinType tau
- in noLoc $
- HsForAllTy forallPlicitness sTvs sCtx sTau
-synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t
-
-synifyTyLit :: TyLit -> HsTyLit
-synifyTyLit (NumTyLit n) = HsNumTy n
-synifyTyLit (StrTyLit s) = HsStrTy s
-
-synifyKindSig :: Kind -> LHsKind Name
-synifyKindSig k = synifyType WithinType k
-
-synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, types) =
- ( getName cls
- , map (unLoc . synifyType WithinType) ks
- , map (unLoc . synifyType WithinType) ts
- , ClassInst $ map (unLoc . synifyType WithinType) preds
- )
- where (ks,ts) = break (not . isKind) types
-
--- Convert a family instance, this could be a type family or data family
-synifyFamInst :: FamInst -> Bool -> InstHead Name
-synifyFamInst fi opaque =
- ( fi_fam fi
- , map (unLoc . synifyType WithinType) ks
- , map (unLoc . synifyType WithinType) ts
- , case fi_flavor fi of
- SynFamilyInst | opaque -> TypeInst Nothing
- SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
- DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
- )
- where (ks,ts) = break (not . isKind) $ fi_tys fi
diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs
deleted file mode 100644
index 91ad709f..00000000
--- a/src/Haddock/Doc.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Haddock.Doc ( module Documentation.Haddock.Doc
- , docCodeBlock
- , combineDocumentation
- ) where
-
-import Data.Maybe
-import Documentation.Haddock.Doc
-import Haddock.Types
-
-combineDocumentation :: Documentation name -> Maybe (Doc name)
-combineDocumentation (Documentation Nothing Nothing) = Nothing
-combineDocumentation (Documentation mDoc mWarning) =
- Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc)
-
--- Drop trailing whitespace from @..@ code blocks. Otherwise this:
---
--- -- @
--- -- foo
--- -- @
---
--- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
--- gives an extra vertical space after the code block. The single space
--- on the final line seems to trigger the extra vertical space.
---
-docCodeBlock :: DocH mod id -> DocH mod id
-docCodeBlock (DocString s)
- = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
-docCodeBlock (DocAppend l r)
- = DocAppend l (docCodeBlock r)
-docCodeBlock d = d
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
deleted file mode 100644
index c06b34a6..00000000
--- a/src/Haddock/GhcUtils.hs
+++ /dev/null
@@ -1,304 +0,0 @@
-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.GhcUtils
--- Copyright : (c) David Waern 2006-2009
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Utils for dealing with types from the GHC API
------------------------------------------------------------------------------
-module Haddock.GhcUtils where
-
-
-import Data.Version
-import Control.Applicative ( (<$>) )
-import Control.Arrow
-import Data.Foldable hiding (concatMap)
-import Data.Function
-import Data.Traversable
-import Distribution.Compat.ReadP
-import Distribution.Text
-
-import Exception
-import Outputable
-import Name
-import Packages
-import Module
-import RdrName (GlobalRdrEnv)
-import GhcMonad (withSession)
-import HscTypes
-import UniqFM
-import GHC
-import Class
-
-
-moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-
--- return the (name,version) of the package
-modulePackageInfo :: Module -> (String, [Char])
-modulePackageInfo modu = case unpackPackageId pkg of
- Nothing -> (packageIdString pkg, "")
- Just x -> (display $ pkgName x, showVersion (pkgVersion x))
- where pkg = modulePackageId modu
-
-
--- This was removed from GHC 6.11
--- XXX we shouldn't be using it, probably
-
--- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
--- we could not parse it as such an object.
-unpackPackageId :: PackageId -> Maybe PackageIdentifier
-unpackPackageId p
- = case [ pid | (pid,"") <- readP_to_S parse str ] of
- [] -> Nothing
- (pid:_) -> Just pid
- where str = packageIdString p
-
-
-lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
-lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
- case lookupUFM (hsc_HPT hsc_env) mod_name of
- Just mod_info -> return (mi_globals (hm_iface mod_info))
- _not_a_home_module -> return Nothing
-
-
-isNameSym :: Name -> Bool
-isNameSym = isSymOcc . nameOccName
-
-
-isVarSym :: OccName -> Bool
-isVarSym = isLexVarSym . occNameFS
-
-isConSym :: OccName -> Bool
-isConSym = isLexConSym . occNameFS
-
-
-getMainDeclBinder :: HsDecl name -> [name]
-getMainDeclBinder (TyClD d) = [tcdName d]
-getMainDeclBinder (ValD d) =
- case collectHsBindBinders d of
- [] -> []
- (name:_) -> [name]
-getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
-getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
-getMainDeclBinder _ = []
-
--- Extract the source location where an instance is defined. This is used
--- to correlate InstDecls with their Instance/CoAxiom Names, via the
--- instanceMap.
-getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
-getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
-getInstLoc (TyFamInstD (TyFamInstDecl
- -- Since CoAxioms' Names refer to the whole line for type family instances
- -- in particular, we need to dig a bit deeper to pull out the entire
- -- equation. This does not happen for data family instances, for some reason.
- { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l
-
--- Useful when there is a signature with multiple names, e.g.
--- foo, bar :: Types..
--- but only one of the names is exported and we have to change the
--- type signature to only include the exported names.
-filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)
-filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
-
-filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)
-filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
-filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
-filterSigNames _ orig@(MinimalSig _) = Just orig
-filterSigNames p (TypeSig ns ty) =
- case filter (p . unLoc) ns of
- [] -> Nothing
- filtered -> Just (TypeSig filtered ty)
-filterSigNames _ _ = Nothing
-
-ifTrueJust :: Bool -> name -> Maybe name
-ifTrueJust True = Just
-ifTrueJust False = const Nothing
-
-sigName :: LSig name -> [name]
-sigName (L _ sig) = sigNameNoLoc sig
-
-sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
-sigNameNoLoc (SpecSig n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig n _) = [unLoc n]
-sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
-sigNameNoLoc _ = []
-
-
-isTyClD :: HsDecl a -> Bool
-isTyClD (TyClD _) = True
-isTyClD _ = False
-
-
-isClassD :: HsDecl a -> Bool
-isClassD (TyClD d) = isClassDecl d
-isClassD _ = False
-
-
-isDocD :: HsDecl a -> Bool
-isDocD (DocD _) = True
-isDocD _ = False
-
-
-isInstD :: HsDecl a -> Bool
-isInstD (InstD _) = True
-isInstD _ = False
-
-
-isValD :: HsDecl a -> Bool
-isValD (ValD _) = True
-isValD _ = False
-
-
-declATs :: HsDecl a -> [a]
-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
-declATs _ = []
-
-
-pretty :: Outputable a => DynFlags -> a -> String
-pretty = showPpr
-
-
-trace_ppr :: Outputable a => DynFlags -> a -> b -> b
-trace_ppr dflags x y = trace (pretty dflags x) y
-
-
--------------------------------------------------------------------------------
--- * Located
--------------------------------------------------------------------------------
-
-
-unL :: Located a -> a
-unL (L _ x) = x
-
-
-reL :: a -> Located a
-reL = L undefined
-
-
-before :: Located a -> Located a -> Bool
-before = (<) `on` getLoc
-
-
-instance Foldable (GenLocated l) where
- foldMap f (L _ x) = f x
-
-
-instance Traversable (GenLocated l) where
- mapM f (L l x) = (return . L l) =<< f x
- traverse f (L l x) = L l <$> f x
-
--------------------------------------------------------------------------------
--- * NamedThing instances
--------------------------------------------------------------------------------
-
-
-instance NamedThing (TyClDecl Name) where
- getName = tcdName
-
-
-instance NamedThing (ConDecl Name) where
- getName = unL . con_name
-
-
--------------------------------------------------------------------------------
--- * Subordinates
--------------------------------------------------------------------------------
-
-
-class Parent a where
- children :: a -> [Name]
-
-
-instance Parent (ConDecl Name) where
- children con =
- case con_details con of
- RecCon fields -> map (unL . cd_fld_name) fields
- _ -> []
-
-
-instance Parent (TyClDecl Name) where
- children d
- | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d
- | isClassDecl d =
- map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
- | otherwise = []
-
-
--- | A parent and its children
-family :: (NamedThing a, Parent a) => a -> (Name, [Name])
-family = getName &&& children
-
-
--- | A mapping from the parent (main-binder) to its children and from each
--- child to its grand-children, recursively.
-families :: TyClDecl Name -> [(Name, [Name])]
-families d
- | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))
- | isClassDecl d = [family d]
- | otherwise = []
-
-
--- | A mapping from child to parent
-parentMap :: TyClDecl Name -> [(Name, Name)]
-parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
-
-
--- | The parents of a subordinate in a declaration
-parents :: Name -> HsDecl Name -> [Name]
-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
-parents _ _ = []
-
-
--------------------------------------------------------------------------------
--- * Utils that work in monads defined by GHC
--------------------------------------------------------------------------------
-
-
-modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
-modifySessionDynFlags f = do
- dflags <- getSessionDynFlags
- _ <- setSessionDynFlags (f dflags)
- return ()
-
-
--- | A variant of 'gbracket' where the return value from the first computation
--- is not required.
-gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
-gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
-
--- Extract the minimal complete definition of a Name, if one exists
-minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
-minimalDef n = do
- mty <- lookupGlobalName n
- case mty of
- Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
- _ -> return Nothing
-
--------------------------------------------------------------------------------
--- * DynFlags
--------------------------------------------------------------------------------
-
-
-setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
-setObjectDir f d = d{ objectDir = Just f}
-setHiDir f d = d{ hiDir = Just f}
-setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
- -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
- -- \#included from the .hc file when compiling with -fvia-C.
-setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
-
diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs
deleted file mode 100644
index 60a20fe5..00000000
--- a/src/Haddock/Interface.hs
+++ /dev/null
@@ -1,244 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2010,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- This module typechecks Haskell modules using the GHC API and processes
--- the result to create 'Interface's. The typechecking and the 'Interface'
--- creation is interleaved, so that when a module is processed, the
--- 'Interface's of all previously processed modules are available. The
--- creation of an 'Interface' from a typechecked module is delegated to
--- "Haddock.Interface.Create".
---
--- When all modules have been typechecked and processed, information about
--- instances are attached to each 'Interface'. This task is delegated to
--- "Haddock.Interface.AttachInstances". Note that this is done as a separate
--- step because GHC can't know about all instances until all modules have been
--- typechecked.
---
--- As a last step a link environment is built which maps names to the \"best\"
--- places to link to in the documentation, and all 'Interface's are \"renamed\"
--- using this environment.
------------------------------------------------------------------------------
-module Haddock.Interface (
- processModules
-) where
-
-
-import Haddock.GhcUtils
-import Haddock.InterfaceFile
-import Haddock.Interface.Create
-import Haddock.Interface.AttachInstances
-import Haddock.Interface.Rename
-import Haddock.Options hiding (verbosity)
-import Haddock.Types
-import Haddock.Utils
-
-import Control.Monad
-import Data.List
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Distribution.Verbosity
-import System.Directory
-import System.FilePath
-import Text.Printf
-
-import Digraph
-import DynFlags hiding (verbosity)
-import Exception
-import GHC hiding (verbosity)
-import HscTypes
-import FastString (unpackFS)
-
--- | Create 'Interface's and a link environment by typechecking the list of
--- modules using the GHC API and processing the resulting syntax trees.
-processModules
- :: Verbosity -- ^ Verbosity of logging to 'stdout'
- -> [String] -- ^ A list of file or module names sorted by
- -- module topology
- -> [Flag] -- ^ Command-line flags
- -> [InterfaceFile] -- ^ Interface files of package dependencies
- -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming
- -- environment
-processModules verbosity modules flags extIfaces = do
-
- out verbosity verbose "Creating interfaces..."
- let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
- , iface <- ifInstalledIfaces ext ]
- interfaces <- createIfaces0 verbosity modules flags instIfaceMap
-
- let exportedNames =
- Set.unions $ map (Set.fromList . ifaceExports) $
- filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
- mods = Set.fromList $ map ifaceMod interfaces
- out verbosity verbose "Attaching instances..."
- interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap
-
- out verbosity verbose "Building cross-linking environment..."
- -- Combine the link envs of the external packages into one
- let extLinks = Map.unions (map ifLinkEnv extIfaces)
- homeLinks = buildHomeLinks interfaces -- Build the environment for the home
- -- package
- links = homeLinks `Map.union` extLinks
-
- out verbosity verbose "Renaming interfaces..."
- let warnings = Flag_NoWarnings `notElem` flags
- dflags <- getDynFlags
- let (interfaces'', msgs) =
- runWriter $ mapM (renameInterface dflags links warnings) interfaces'
- liftIO $ mapM_ putStrLn msgs
-
- return (interfaces'', homeLinks)
-
-
---------------------------------------------------------------------------------
--- * Module typechecking and Interface creation
---------------------------------------------------------------------------------
-
-
-createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
-createIfaces0 verbosity modules flags instIfaceMap =
- -- Output dir needs to be set before calling depanal since depanal uses it to
- -- compute output file names that are stored in the DynFlags of the
- -- resulting ModSummaries.
- (if useTempDir then withTempOutputDir else id) $ do
- modGraph <- depAnalysis
- if needsTemplateHaskell modGraph then do
- modGraph' <- enableCompilation modGraph
- createIfaces verbosity flags instIfaceMap modGraph'
- else
- createIfaces verbosity flags instIfaceMap modGraph
-
- where
- useTempDir :: Bool
- useTempDir = Flag_NoTmpCompDir `notElem` flags
-
-
- withTempOutputDir :: Ghc a -> Ghc a
- withTempOutputDir action = do
- tmp <- liftIO getTemporaryDirectory
- x <- liftIO getProcessID
- let dir = tmp </> ".haddock-" ++ show x
- modifySessionDynFlags (setOutputDir dir)
- withTempDir dir action
-
-
- depAnalysis :: Ghc ModuleGraph
- depAnalysis = do
- targets <- mapM (\f -> guessTarget f Nothing) modules
- setTargets targets
- depanal [] False
-
-
- enableCompilation :: ModuleGraph -> Ghc ModuleGraph
- enableCompilation modGraph = do
- let enableComp d = let platform = targetPlatform d
- in d { hscTarget = defaultObjectTarget platform }
- modifySessionDynFlags enableComp
- -- We need to update the DynFlags of the ModSummaries as well.
- let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
- let modGraph' = map upd modGraph
- return modGraph'
-
-
-createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
-createIfaces verbosity flags instIfaceMap mods = do
- let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
- out verbosity normal "Haddock coverage:"
- (ifaces, _) <- foldM f ([], Map.empty) sortedMods
- return (reverse ifaces)
- where
- f (ifaces, ifaceMap) modSummary = do
- x <- processModule verbosity modSummary flags ifaceMap instIfaceMap
- return $ case x of
- Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
- Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
-
-
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
-processModule verbosity modsum flags modMap instIfaceMap = do
- out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
- tm <- loadModule =<< typecheckModule =<< parseModule modsum
- if not $ isBootSummary modsum then do
- out verbosity verbose "Creating interface..."
- (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
- liftIO $ mapM_ putStrLn msg
- dflags <- getDynFlags
- let (haddockable, haddocked) = ifaceHaddockCoverage interface
- percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int
- modString = moduleString (ifaceMod interface)
- coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString
- header = case ifaceDoc interface of
- Documentation Nothing _ -> False
- _ -> True
- undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n
- , expItemMbDoc = (Documentation Nothing _, _)
- } <- ifaceExportItems interface ]
- where
- formatName :: SrcSpan -> HsDecl Name -> String
- formatName loc n = p (getMainDeclBinder n) ++ case loc of
- RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")"
- _ -> ""
-
- p [] = ""
- p (x:_) = let n = pretty dflags x
- ms = modString ++ "."
- in if ms `isPrefixOf` n
- then drop (length ms) n
- else n
-
- out verbosity normal coverageMsg
- when (Flag_PrintMissingDocs `elem` flags
- && not (null undocumentedExports && header)) $ do
- out verbosity normal " Missing documentation for:"
- unless header $ out verbosity normal " Module header"
- mapM_ (out verbosity normal . (" " ++)) undocumentedExports
- interface' <- liftIO $ evaluate interface
- return (Just interface')
- else
- return Nothing
-
-
---------------------------------------------------------------------------------
--- * Building of cross-linking environment
---------------------------------------------------------------------------------
-
-
--- | Build a mapping which for each original name, points to the "best"
--- place to link to in the documentation. For the definition of
--- "best", we use "the module nearest the bottom of the dependency
--- graph which exports this name", not including hidden modules. When
--- there are multiple choices, we pick a random one.
---
--- The interfaces are passed in in topologically sorted order, but we start
--- by reversing the list so we can do a foldl.
-buildHomeLinks :: [Interface] -> LinkEnv
-buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces)
- where
- upd old_env iface
- | OptHide `elem` ifaceOptions iface = old_env
- | OptNotHome `elem` ifaceOptions iface =
- foldl' keep_old old_env exported_names
- | otherwise = foldl' keep_new old_env exported_names
- where
- exported_names = ifaceVisibleExports iface
- mdl = ifaceMod iface
- keep_old env n = Map.insertWith (\_ old -> old) n mdl env
- keep_new env n = Map.insert n mdl env
-
-
---------------------------------------------------------------------------------
--- * Utils
---------------------------------------------------------------------------------
-
-
-withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a
-withTempDir dir = gbracket_ (liftIO $ createDirectory dir)
- (liftIO $ removeDirectoryRecursive dir)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
deleted file mode 100644
index a0bac8fc..00000000
--- a/src/Haddock/Interface/AttachInstances.hs
+++ /dev/null
@@ -1,221 +0,0 @@
-{-# LANGUAGE CPP, MagicHash #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface.AttachInstances
--- Copyright : (c) Simon Marlow 2006,
--- David Waern 2006-2009,
--- Isaac Dupree 2009
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Interface.AttachInstances (attachInstances) where
-
-
-import Haddock.Types
-import Haddock.Convert
-import Haddock.GhcUtils
-
-import Control.Arrow
-import Data.List
-import Data.Ord (comparing)
-import Data.Function (on)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import Class
-import FamInstEnv
-import FastString
-import GHC
-import GhcMonad (withSession)
-import Id
-import InstEnv
-import MonadUtils (liftIO)
-import Name
-import PrelNames
-import TcRnDriver (tcRnGetInfo)
-import TcType (tcSplitSigmaTy)
-import TyCon
-import TypeRep
-import TysPrim( funTyCon )
-import Var hiding (varName)
-#define FSLIT(x) (mkFastString# (x#))
-
-type ExportedNames = Set.Set Name
-type Modules = Set.Set Module
-type ExportInfo = (ExportedNames, Modules)
-
--- Also attaches fixities
-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
- where
- -- TODO: take an IfaceMap as input
- ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]
-
- attach iface = do
- newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap)
- (ifaceExportItems iface)
- return $ iface { ifaceExportItems = newItems }
-
-
-attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
-attachToExportItem expInfo iface ifaceMap instIfaceMap export =
- case attachFixities export of
- e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
- mb_info <- getAllInfo (tcdName d)
- let export' =
- e {
- expItemInstances =
- case mb_info of
- Just (_, _, cls_instances, fam_instances) ->
- let fam_insts = [ (synifyFamInst i opaque, n)
- | i <- sortBy (comparing instFam) fam_instances
- , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
- , not $ isNameHidden expInfo (fi_fam i)
- , not $ any (isTypeHidden expInfo) (fi_tys i)
- , let opaque = isTypeHidden expInfo (fi_rhs i)
- ]
- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
- | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
- , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
- , not $ isInstanceHidden expInfo cls tys
- ]
- in cls_insts ++ fam_insts
- Nothing -> []
- }
- return export'
- e -> return e
- where
- attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
- nubBy ((==) `on` fst) $ expItemFixities e ++
- [ (n',f) | n <- getMainDeclBinder d
- , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
- , n' <- n : subs
- , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
- ] }
-
- attachFixities e = e
-
-
-instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
- -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
-instLookup f name iface ifaceMap instIfaceMap =
- case Map.lookup name (f $ toInstalledIface iface) of
- res@(Just _) -> res
- Nothing -> do
- let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
- iface' <- Map.lookup (nameModule name) ifaceMaps
- Map.lookup name (f iface')
-
--- | Like GHC's 'instanceHead' but drops "silent" arguments.
-instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
-instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys)
- where
- dfun = is_dfun ispec
- (tvs, cls, tys) = instanceHead ispec
- (_, theta, _) = tcSplitSigmaTy (idType dfun)
-
--- | Drop "silent" arguments. See GHC Note [Silent superclass
--- arguments].
-dropSilentArgs :: DFunId -> ThetaType -> ThetaType
-dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta
-
-
--- | Like GHC's getInfo but doesn't cut things out depending on the
--- interative context, which we don't set sufficiently anyway.
-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))
-getAllInfo name = withSession $ \hsc_env -> do
- (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name
- return r
-
-
---------------------------------------------------------------------------------
--- Collecting and sorting instances
---------------------------------------------------------------------------------
-
-
--- | Simplified type for sorting types, ignoring qualification (not visible
--- in Haddock output) and unifying special tycons with normal ones.
--- For the benefit of the user (looks nice and predictable) and the
--- tests (which prefer output to be deterministic).
-data SimpleType = SimpleType Name [SimpleType]
- | SimpleTyLit TyLit
- deriving (Eq,Ord)
-
-
-instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
-instHead (_, _, cls, args)
- = (map argCount args, className cls, map simplify args)
-
-argCount :: Type -> Int
-argCount (AppTy t _) = argCount t + 1
-argCount (TyConApp _ ts) = length ts
-argCount (FunTy _ _ ) = 2
-argCount (ForAllTy _ t) = argCount t
-argCount _ = 0
-
-simplify :: Type -> SimpleType
-simplify (ForAllTy _ t) = simplify t
-simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]
-simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
- where (SimpleType s ts) = simplify t1
-simplify (TyVarTy v) = SimpleType (tyVarName v) []
-simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
-simplify (LitTy l) = SimpleTyLit l
-
--- Used for sorting
-instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType)
-instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t }
- = (map argCount ts, n, map simplify ts, argCount t, simplify t)
-
-
-funTyConName :: Name
-funTyConName = mkWiredInName gHC_PRIM
- (mkOccNameFS tcName FSLIT("(->)"))
- funTyConKey
- (ATyCon funTyCon) -- Relevant TyCon
- BuiltInSyntax
-
---------------------------------------------------------------------------------
--- Filtering hidden instances
---------------------------------------------------------------------------------
-
--- | A class or data type is hidden iff
---
--- * it is defined in one of the modules that are being processed
---
--- * and it is not exported by any non-hidden module
-isNameHidden :: ExportInfo -> Name -> Bool
-isNameHidden (names, modules) name =
- nameModule name `Set.member` modules &&
- not (name `Set.member` names)
-
--- | We say that an instance is «hidden» iff its class or any (part)
--- of its type(s) is hidden.
-isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool
-isInstanceHidden expInfo cls tys =
- instClassHidden || instTypeHidden
- where
- instClassHidden :: Bool
- instClassHidden = isNameHidden expInfo $ getName cls
-
- instTypeHidden :: Bool
- instTypeHidden = any (isTypeHidden expInfo) tys
-
-isTypeHidden :: ExportInfo -> Type -> Bool
-isTypeHidden expInfo = typeHidden
- where
- typeHidden :: Type -> Bool
- typeHidden t =
- case t of
- TyVarTy {} -> False
- AppTy t1 t2 -> typeHidden t1 || typeHidden t2
- TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args
- FunTy t1 t2 -> typeHidden t1 || typeHidden t2
- ForAllTy _ ty -> typeHidden ty
- LitTy _ -> False
-
- nameHidden :: Name -> Bool
- nameHidden = isNameHidden expInfo
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
deleted file mode 100644
index b66773ae..00000000
--- a/src/Haddock/Interface/Create.hs
+++ /dev/null
@@ -1,867 +0,0 @@
-{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-}
-{-# OPTIONS_GHC -Wwarn #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface.Create
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Interface.Create (createInterface) where
-
-import Documentation.Haddock.Doc (docAppend)
-import Haddock.Types
-import Haddock.Options
-import Haddock.GhcUtils
-import Haddock.Utils
-import Haddock.Convert
-import Haddock.Interface.LexParseRn
-
-import qualified Data.Map as M
-import Data.Map (Map)
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.Ord
-import Control.Applicative
-import Control.Arrow (second)
-import Control.DeepSeq
-import Control.Monad
-import Data.Function (on)
-import qualified Data.Foldable as F
-
-import qualified Packages
-import qualified Module
-import qualified SrcLoc
-import GHC
-import HscTypes
-import Name
-import Bag
-import RdrName
-import TcRnTypes
-import FastString (concatFS)
-
-
--- | Use a 'TypecheckedModule' to produce an 'Interface'.
--- To do this, we need access to already processed modules in the topological
--- sort. That's what's in the 'IfaceMap'.
-createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface
-createInterface tm flags modMap instIfaceMap = do
-
- let ms = pm_mod_summary . tm_parsed_module $ tm
- mi = moduleInfo tm
- L _ hsm = parsedSource tm
- !safety = modInfoSafe mi
- mdl = ms_mod ms
- dflags = ms_hspp_opts ms
- !instances = modInfoInstances mi
- !fam_instances = md_fam_insts md
- !exportedNames = modInfoExports mi
-
- (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm
-
- -- The renamed source should always be available to us, but it's best
- -- to be on the safe side.
- (group_, mayExports, mayDocHeader) <-
- case renamedSource tm of
- Nothing -> do
- liftErrMsg $ tell [ "Warning: Renamed source is not available." ]
- return (emptyRnGroup, Nothing, Nothing)
- Just (x, _, y, z) -> return (x, y, z)
-
- opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl
- let opts
- | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0
- | otherwise = opts0
-
- (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader
-
- let declsWithDocs = topDecls group_
- fixMap = mkFixMap group_
- (decls, _) = unzip declsWithDocs
- localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances
- ++ map getName fam_instances
- -- Locations of all TH splices
- splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ]
-
- maps@(!docMap, !argMap, !subMap, !declMap, _) =
- mkMaps dflags gre localInsts declsWithDocs
-
- let exports0 = fmap (reverse . map unLoc) mayExports
- exports
- | OptIgnoreExports `elem` opts = Nothing
- | otherwise = exports0
- warningMap = mkWarningMap dflags warnings gre exportedNames
-
- let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap))
-
- exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls
- maps fixMap splices exports instIfaceMap dflags
-
- let !visibleNames = mkVisibleNames maps exportItems opts
-
- -- Measure haddock documentation coverage.
- let prunedExportItems0 = pruneExportItems exportItems
- !haddockable = 1 + length exportItems -- module + exports
- !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0
- !coverage = (haddockable, haddocked)
-
- -- Prune the export list to just those declarations that have
- -- documentation, if the 'prune' option is on.
- let prunedExportItems'
- | OptPrune `elem` opts = prunedExportItems0
- | otherwise = exportItems
- !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems'
-
- let !aliases =
- mkAliasMap dflags $ tm_renamed_source tm
- modWarn = moduleWarning dflags gre warnings
-
- return $! Interface {
- ifaceMod = mdl
- , ifaceOrigFilename = msHsFilePath ms
- , ifaceInfo = info
- , ifaceDoc = Documentation mbDoc modWarn
- , ifaceRnDoc = Documentation Nothing Nothing
- , ifaceOptions = opts
- , ifaceDocMap = docMap
- , ifaceArgMap = argMap
- , ifaceRnDocMap = M.empty
- , ifaceRnArgMap = M.empty
- , ifaceExportItems = prunedExportItems
- , ifaceRnExportItems = []
- , ifaceExports = exportedNames
- , ifaceVisibleExports = visibleNames
- , ifaceDeclMap = declMap
- , ifaceSubMap = subMap
- , ifaceFixMap = fixMap
- , ifaceModuleAliases = aliases
- , ifaceInstances = instances
- , ifaceFamInstances = fam_instances
- , ifaceHaddockCoverage = coverage
- , ifaceWarningMap = warningMap
- }
-
-mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName
-mkAliasMap dflags mRenamedSource =
- case mRenamedSource of
- Nothing -> M.empty
- Just (_,impDecls,_,_) ->
- M.fromList $
- mapMaybe (\(SrcLoc.L _ impDecl) -> do
- alias <- ideclAs impDecl
- return $
- (lookupModuleDyn dflags
- (fmap Module.fsToPackageId $
- ideclPkgQual impDecl)
- (case ideclName impDecl of SrcLoc.L _ name -> name),
- alias))
- impDecls
-
--- similar to GHC.lookupModule
-lookupModuleDyn ::
- DynFlags -> Maybe PackageId -> ModuleName -> Module
-lookupModuleDyn _ (Just pkgId) mdlName =
- Module.mkModule pkgId mdlName
-lookupModuleDyn dflags Nothing mdlName =
- flip Module.mkModule mdlName $
- case filter snd $
- Packages.lookupModuleInAllPackages dflags mdlName of
- (pkgId,_):_ -> Packages.packageConfigId pkgId
- [] -> Module.mainPackageId
-
-
--------------------------------------------------------------------------------
--- Warnings
--------------------------------------------------------------------------------
-
-mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap
-mkWarningMap dflags warnings gre exps = case warnings of
- NoWarnings -> M.empty
- WarnAll _ -> M.empty
- WarnSome ws ->
- let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ
- , let n = gre_name elt, n `elem` exps ]
- in M.fromList $ map (second $ parseWarning dflags gre) ws'
-
-moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name)
-moduleWarning _ _ NoWarnings = Nothing
-moduleWarning _ _ (WarnSome _) = Nothing
-moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w
-
-parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name
-parseWarning dflags gre w = force $ case w of
- DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)
- WarningTxt msg -> format "Warning: " (concatFS msg)
- where
- format x xs = DocWarning . DocParagraph . DocAppend (DocString x)
- . processDocString dflags gre $ HsDocString xs
-
-
--------------------------------------------------------------------------------
--- Doc options
---
--- Haddock options that are embedded in the source file
--------------------------------------------------------------------------------
-
-
-mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]
-mkDocOpts mbOpts flags mdl = do
- opts <- case mbOpts of
- Just opts -> case words $ replace ',' ' ' opts of
- [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return []
- xs -> liftM catMaybes (mapM parseOption xs)
- Nothing -> return []
- hm <- if Flag_HideModule (moduleString mdl) `elem` flags
- then return $ OptHide : opts
- else return opts
- if Flag_ShowExtensions (moduleString mdl) `elem` flags
- then return $ OptShowExtensions : hm
- else return hm
-
-
-parseOption :: String -> ErrMsgM (Maybe DocOption)
-parseOption "hide" = return (Just OptHide)
-parseOption "prune" = return (Just OptPrune)
-parseOption "ignore-exports" = return (Just OptIgnoreExports)
-parseOption "not-home" = return (Just OptNotHome)
-parseOption "show-extensions" = return (Just OptShowExtensions)
-parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing
-
-
---------------------------------------------------------------------------------
--- Maps
---------------------------------------------------------------------------------
-
-
-type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap)
-
--- | Create 'Maps' by looping through the declarations. For each declaration,
--- find its names, its subordinates, and its doc strings. Process doc strings
--- into 'Doc's.
-mkMaps :: DynFlags
- -> GlobalRdrEnv
- -> [Name]
- -> [(LHsDecl Name, [HsDocString])]
- -> Maps
-mkMaps dflags gre instances decls =
- let (a, b, c, d) = unzip4 $ map mappings decls
- in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap)
- where
- f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b
- f = M.fromListWith (<>) . concat
-
- f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)
- f' = M.fromListWith docAppend . concat
-
- mappings :: (LHsDecl Name, [HsDocString])
- -> ( [(Name, Doc Name)]
- , [(Name, Map Int (Doc Name))]
- , [(Name, [Name])]
- , [(Name, [LHsDecl Name])]
- )
- mappings (ldecl, docStrs) =
- let L l decl = ldecl
- declDoc :: [HsDocString] -> Map Int HsDocString
- -> (Maybe (Doc Name), Map Int (Doc Name))
- declDoc strs m =
- let doc' = processDocStrings dflags gre strs
- m' = M.map (processDocStringParas dflags gre) m
- in (doc', m')
- (doc, args) = declDoc docStrs (typeDocs decl)
- subs :: [(Name, [HsDocString], Map Int HsDocString)]
- subs = subordinates instanceMap decl
- (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs
- ns = names l decl
- subNs = [ n | (n, _, _) <- subs ]
- dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ]
- am = [ (n, args) | n <- ns ] ++ zip subNs subArgs
- sm = [ (n, subNs) | n <- ns ]
- cm = [ (n, [ldecl]) | n <- ns ++ subNs ]
- in seqList ns `seq`
- seqList subNs `seq`
- doc `seq`
- seqList subDocs `seq`
- seqList subArgs `seq`
- (dm, am, sm, cm)
-
- instanceMap :: Map SrcSpan Name
- instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ]
-
- names :: SrcSpan -> HsDecl Name -> [Name]
- names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2].
- where loc = case d of
- TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs
- _ -> getInstLoc d
- names _ decl = getMainDeclBinder decl
-
--- Note [2]:
-------------
--- We relate ClsInsts to InstDecls using the SrcSpans buried inside them.
--- That should work for normal user-written instances (from looking at GHC
--- sources). We can assume that commented instances are user-written.
--- This lets us relate Names (from ClsInsts) to comments (associated
--- with InstDecls).
-
-
---------------------------------------------------------------------------------
--- Declarations
---------------------------------------------------------------------------------
-
-
--- | Get all subordinate declarations inside a declaration, and their docs.
-subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)]
-subordinates instMap decl = case decl of
- InstD (ClsInstD d) -> do
- DataFamInstDecl { dfid_tycon = L l _
- , dfid_defn = def } <- unLoc <$> cid_datafam_insts d
- [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def
-
- InstD (DataFamInstD d) -> dataSubs (dfid_defn d)
- TyClD d | isClassDecl d -> classSubs d
- | isDataDecl d -> dataSubs (tcdDataDefn d)
- _ -> []
- where
- classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd
- , name <- getMainDeclBinder d, not (isValD d)
- ]
- dataSubs dd = constrs ++ fields
- where
- cons = map unL $ (dd_cons dd)
- constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)
- | c <- cons ]
- fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)
- | RecCon flds <- map con_details cons
- , ConDeclField n _ doc <- flds ]
-
--- | Extract function argument docs from inside types.
-typeDocs :: HsDecl Name -> Map Int HsDocString
-typeDocs d =
- let docs = go 0 in
- case d of
- SigD (TypeSig _ ty) -> docs (unLoc ty)
- SigD (PatSynSig _ arg_tys ty req prov) ->
- let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]
- in F.foldMap (docs . unLoc) allTys
- ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)
- TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty)
- _ -> M.empty
- where
- go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)
- go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
- go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
- go n (HsDocTy _ (L _ doc)) = M.singleton n doc
- go _ _ = M.empty
-
-
--- | All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
-classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
-classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
- where
- decls = docs ++ defs ++ sigs ++ ats
- docs = mkDecls tcdDocs DocD class_
-#if MIN_VERSION_ghc(7,8,3)
- defs = mkDecls (bagToList . tcdMeths) ValD class_
-#else
- defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_
-#endif
- sigs = mkDecls tcdSigs SigD class_
- ats = mkDecls tcdATs (TyClD . FamDecl) class_
-
-
--- | The top-level declarations of a module that we care about,
--- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])]
-topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
-
--- | Extract a map of fixity declarations only
-mkFixMap :: HsGroup Name -> FixMap
-mkFixMap group_ = M.fromList [ (n,f)
- | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]
-
-
--- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup Name -> [LHsDecl Name]
-ungroup group_ =
- mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
- mkDecls hs_derivds DerivD group_ ++
- mkDecls hs_defds DefD group_ ++
- mkDecls hs_fords ForD group_ ++
- mkDecls hs_docs DocD group_ ++
- mkDecls hs_instds InstD group_ ++
- mkDecls (typesigs . hs_valds) SigD group_ ++
-#if MIN_VERSION_ghc(7,8,3)
- mkDecls (valbinds . hs_valds) ValD group_
-#else
- mkDecls (map snd . valbinds . hs_valds) ValD group_
-#endif
- where
- typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs
- typesigs _ = error "expected ValBindsOut"
-
- valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
- valbinds _ = error "expected ValBindsOut"
-
-
--- | Take a field of declarations from a data structure and create HsDecls
--- using the given constructor
-mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
-mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ]
-
-
--- | Sort by source location
-sortByLoc :: [Located a] -> [Located a]
-sortByLoc = sortBy (comparing getLoc)
-
-
---------------------------------------------------------------------------------
--- Filtering of declarations
---
--- We filter out declarations that we don't intend to handle later.
---------------------------------------------------------------------------------
-
-
--- | Filter out declarations that we don't handle in Haddock
-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unL . fst)
- where
- isHandled (ForD (ForeignImport {})) = True
- isHandled (TyClD {}) = True
- isHandled (InstD {}) = True
- isHandled (SigD d) = isVanillaLSig (reL d)
- isHandled (ValD _) = True
- -- we keep doc declarations to be able to get at named docs
- isHandled (DocD _) = True
- isHandled _ = False
-
-
--- | Go through all class declarations and filter their sub-declarations
-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x
- | x@(L loc d, doc) <- decls ]
- where
- filterClass (TyClD c) =
- TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c }
- filterClass _ = error "expected TyClD"
-
-
---------------------------------------------------------------------------------
--- Collect docs
---
--- To be able to attach the right Haddock comment to the right declaration,
--- we sort the declarations by their SrcLoc and "collect" the docs for each
--- declaration.
---------------------------------------------------------------------------------
-
-
--- | Collect docs and attach them to the right declarations.
-collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])]
-collectDocs = go Nothing []
- where
- go Nothing _ [] = []
- go (Just prev) docs [] = finished prev docs []
- go prev docs (L _ (DocD (DocCommentNext str)) : ds)
- | Nothing <- prev = go Nothing (str:docs) ds
- | Just decl <- prev = finished decl docs (go Nothing [str] ds)
- go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds
- go Nothing docs (d:ds) = go (Just d) docs ds
- go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
-
- finished decl docs rest = (decl, reverse docs) : rest
-
-
--- | Build the list of items that will become the documentation, from the
--- export list. At this point, the list of ExportItems is in terms of
--- original names.
---
--- We create the export items even if the module is hidden, since they
--- might be useful when creating the export items for other modules.
-mkExportItems
- :: IfaceMap
- -> Module -- this module
- -> WarningMap
- -> GlobalRdrEnv
- -> [Name] -- exported names (orig)
- -> [LHsDecl Name]
- -> Maps
- -> FixMap
- -> [SrcSpan] -- splice locations
- -> Maybe [IE Name]
- -> InstIfaceMap
- -> DynFlags
- -> ErrMsgGhc [ExportItem Name]
-mkExportItems
- modMap thisMod warnings gre exportedNames decls
- maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags =
- case optExports of
- Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls
- Just exports -> liftM concat $ mapM lookupExport exports
- where
- lookupExport (IEVar x) = declWith x
- lookupExport (IEThingAbs t) = declWith t
- lookupExport (IEThingAll t) = declWith t
- lookupExport (IEThingWith t _) = declWith t
- lookupExport (IEModuleContents m) =
- moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices
- lookupExport (IEGroup lev docStr) = return $
- return . ExportGroup lev "" $ processDocString dflags gre docStr
-
- lookupExport (IEDoc docStr) = return $
- return . ExportDoc $ processDocStringParas dflags gre docStr
-
- lookupExport (IEDocNamed str) = liftErrMsg $
- findNamedDoc str [ unL d | d <- decls ] >>= return . \case
- Nothing -> []
- Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc
-
- declWith :: Name -> ErrMsgGhc [ ExportItem Name ]
- declWith t =
- case findDecl t of
- ([L l (ValD _)], (doc, _)) -> do
- -- Top-level binding without type signature
- export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap
- return [export]
- (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
- let declNames = getMainDeclBinder (unL decl)
- in case () of
- _
- -- temp hack: we filter out separately exported ATs, since we haven't decided how
- -- to handle them yet. We should really give an warning message also, and filter the
- -- name out in mkVisibleNames...
- | t `elem` declATs (unL decl) -> return []
-
- -- We should not show a subordinate by itself if any of its
- -- parents is also exported. See note [1].
- | t `notElem` declNames,
- Just p <- find isExported (parents t $ unL decl) ->
- do liftErrMsg $ tell [
- "Warning: " ++ moduleString thisMod ++ ": " ++
- pretty dflags (nameOccName t) ++ " is exported separately but " ++
- "will be documented under " ++ pretty dflags (nameOccName p) ++
- ". Consider exporting it together with its parent(s)" ++
- " for code clarity." ]
- return []
-
- -- normal case
- | otherwise -> case decl of
- -- A single signature might refer to many names, but we
- -- create an export item for a single name only. So we
- -- modify the signature to contain only that single name.
- L loc (SigD sig) ->
- -- fromJust is safe since we already checked in guards
- -- that 't' is a name declared in this declaration.
- let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig
- in return [ mkExportDecl t newDecl docs_ ]
-
- L loc (TyClD cl@ClassDecl{}) -> do
- mdef <- liftGhcToErrMsgGhc $ minimalDef t
- let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
- return [ mkExportDecl t
- (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ]
-
- _ -> return [ mkExportDecl t decl docs_ ]
-
- -- Declaration from another package
- ([], _) -> do
- mayDecl <- hiDecl dflags t
- case mayDecl of
- Nothing -> return [ ExportNoDecl t [] ]
- Just decl ->
- -- We try to get the subs and docs
- -- from the installed .haddock file for that package.
- case M.lookup (nameModule t) instIfaceMap of
- Nothing -> do
- liftErrMsg $ tell
- ["Warning: Couldn't find .haddock for export " ++ pretty dflags t]
- let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ]
- return [ mkExportDecl t decl (noDocForDecl, subs_) ]
- Just iface ->
- return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ]
-
- _ -> return []
-
-
- mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name
- mkExportDecl name decl (doc, subs) = decl'
- where
- decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False
- mdl = nameModule name
- subs' = filter (isExported . fst) subs
- sub_names = map fst subs'
- fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ]
-
-
- isExported = (`elem` exportedNames)
-
-
- findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)]))
- findDecl n
- | m == thisMod, Just ds <- M.lookup n declMap =
- (ds, lookupDocs n warnings docMap argMap subMap)
- | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) =
- (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface))
- | otherwise = ([], (noDocForDecl, []))
- where
- m = nameModule n
-
-
-hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name))
-hiDecl dflags t = do
- mayTyThing <- liftGhcToErrMsgGhc $ lookupName t
- case mayTyThing of
- Nothing -> do
- liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t]
- return Nothing
- Just x -> return (Just (tyThingToLHsDecl x))
-
-
-hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name)
-hiValExportItem dflags name doc splice fixity = do
- mayDecl <- hiDecl dflags name
- case mayDecl of
- Nothing -> return (ExportNoDecl name [])
- Just decl -> return (ExportDecl decl doc [] [] fixities splice)
- where
- fixities = case fixity of
- Just f -> [(name, f)]
- Nothing -> []
-
-
--- | Lookup docs for a declaration from maps.
-lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])
-lookupDocs n warnings docMap argMap subMap =
- let lookupArgDoc x = M.findWithDefault M.empty x argMap in
- let doc = (lookupDoc n, lookupArgDoc n) in
- let subs = M.findWithDefault [] n subMap in
- let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in
- (doc, subDocs)
- where
- lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings)
-
-
--- | Return all export items produced by an exported module. That is, we're
--- interested in the exports produced by \"module B\" in such a scenario:
---
--- > module A (module B) where
--- > import B (...) hiding (...)
---
--- There are three different cases to consider:
---
--- 1) B is hidden, in which case we return all its exports that are in scope in A.
--- 2) B is visible, but not all its exports are in scope in A, in which case we
--- only return those that are.
--- 3) B is visible and all its exports are in scope, in which case we return
--- a single 'ExportModule' item.
-moduleExports :: Module -- ^ Module A
- -> ModuleName -- ^ The real name of B, the exported module
- -> DynFlags -- ^ The flags used when typechecking A
- -> WarningMap
- -> GlobalRdrEnv -- ^ The renaming environment used for A
- -> [Name] -- ^ All the exports of A
- -> [LHsDecl Name] -- ^ All the declarations in A
- -> IfaceMap -- ^ Already created interfaces
- -> InstIfaceMap -- ^ Interfaces in other packages
- -> Maps
- -> FixMap
- -> [SrcSpan] -- ^ Locations of all TH splices
- -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items
-moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices
- | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls
- | otherwise =
- case M.lookup m ifaceMap of
- Just iface
- | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)
- | otherwise -> return [ ExportModule m ]
-
- Nothing -> -- We have to try to find it in the installed interfaces
- -- (external packages).
- case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of
- Just iface -> return [ ExportModule (instMod iface) ]
- Nothing -> do
- liftErrMsg $
- tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++
- "documentation for exported module: " ++ pretty dflags expMod]
- return []
- where
- m = mkModule packageId expMod
- packageId = modulePackageId thisMod
-
-
--- Note [1]:
-------------
--- It is unnecessary to document a subordinate by itself at the top level if
--- any of its parents is also documented. Furthermore, if the subordinate is a
--- record field or a class method, documenting it under its parent
--- indicates its special status.
---
--- A user might expect that it should show up separately, so we issue a
--- warning. It's a fine opportunity to also tell the user she might want to
--- export the subordinate through the parent export item for clarity.
---
--- The code removes top-level subordinates also when the parent is exported
--- through a 'module' export. I think that is fine.
---
--- (For more information, see Trac #69)
-
-
-fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan]
- -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name]
-fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls =
- liftM catMaybes $ mapM mkExportItem (expandSig decls)
- where
- -- A type signature can have multiple names, like:
- -- foo, bar :: Types..
- --
- -- We go through the list of declarations and expand type signatures, so
- -- that every type signature has exactly one name!
- expandSig :: [LHsDecl name] -> [LHsDecl name]
- expandSig = foldr f []
- where
- f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name]
- f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names
- f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names
- f x xs = x : xs
-
- mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name))
- mkExportItem (L _ (DocD (DocGroup lev docStr))) = do
- return . Just . ExportGroup lev "" $ processDocString dflags gre docStr
- mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do
- return . Just . ExportDoc $ processDocStringParas dflags gre docStr
- mkExportItem (L l (ValD d))
- | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap =
- -- Top-level binding without type signature.
- let (doc, _) = lookupDocs name warnings docMap argMap subMap in
- fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap)
- | otherwise = return Nothing
- mkExportItem decl@(L l (InstD d))
- | Just name <- M.lookup (getInstLoc d) instMap =
- let (doc, subs) = lookupDocs name warnings docMap argMap subMap in
- return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
- mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do
- mdef <- liftGhcToErrMsgGhc $ minimalDef name
- let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef
- expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name
- mkExportItem decl@(L l d)
- | name:_ <- getMainDeclBinder d = expDecl decl l name
- | otherwise = return Nothing
-
- fixities name subs = [ (n,f) | n <- name : map fst subs
- , Just f <- [M.lookup n fixMap] ]
-
- expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices))
- where (doc, subs) = lookupDocs name warnings docMap argMap subMap
-
-
--- | Sometimes the declaration we want to export is not the "main" declaration:
--- it might be an individual record selector or a class method. In these
--- cases we have to extract the required declaration (and somehow cobble
--- together a type signature for it...).
-extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name
-extractDecl name mdl decl
- | name `elem` getMainDeclBinder (unLoc decl) = decl
- | otherwise =
- case unLoc decl of
- TyClD d@ClassDecl {} ->
- let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig,
- isVanillaLSig sig ] -- TODO: document fixity
- in case matches of
- [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d)
- L pos sig = extractClassDecl n tyvar_names s0
- in L pos (SigD sig)
- _ -> error "internal: extractDecl (ClassDecl)"
- TyClD d@DataDecl {} ->
- let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d)
- in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d))
- InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n
- , dfid_pats = HsWB { hswb_cts = tys }
- , dfid_defn = defn }) ->
- SigD <$> extractRecSel name mdl n tys (dd_cons defn)
- InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) ->
- let matches = [ d | L _ d <- insts
- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)
- , ConDeclField { cd_fld_name = L _ n } <- rec
- , n == name
- ]
- in case matches of
- [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0)
- _ -> error "internal: extractDecl (ClsInstD)"
- _ -> error "internal: extractDecl"
- where
- getTyVars = hsLTyVarLocNames . tyClDeclTyVars
-
-
-toTypeNoLoc :: Located Name -> LHsType Name
-toTypeNoLoc = noLoc . HsTyVar . unLoc
-
-
-extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name
-extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of
- L _ (HsForAllTy expl tvs (L _ preds) ty) ->
- L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))
- _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))
- where
- lctxt = noLoc . ctxt
- ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds
-extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl"
-
-
-extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name]
- -> LSig Name
-extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
-
-extractRecSel nm mdl t tvs (L _ con : rest) =
- case con_details con of
- RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->
- L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))
- _ -> extractRecSel nm mdl t tvs rest
- where
- matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]
- data_ty
- | ResTyGADT ty <- con_res con = ty
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
-
-
--- | Keep export items with docs.
-pruneExportItems :: [ExportItem Name] -> [ExportItem Name]
-pruneExportItems = filter hasDoc
- where
- hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d
- hasDoc _ = True
-
-
-mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name]
-mkVisibleNames (_, _, _, _, instMap) exports opts
- | OptHide `elem` opts = []
- | otherwise = let ns = concatMap exportName exports
- in seqList ns `seq` ns
- where
- exportName e@ExportDecl {} = name ++ subs
- where subs = map fst (expItemSubDocs e)
- name = case unLoc $ expItemDecl e of
- InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap
- decl -> getMainDeclBinder decl
- exportName ExportNoDecl {} = [] -- we don't count these as visible, since
- -- we don't want links to go to them.
- exportName _ = []
-
-seqList :: [a] -> ()
-seqList [] = ()
-seqList (x : xs) = x `seq` seqList xs
-
--- | Find a stand-alone documentation comment by its name.
-findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
-findNamedDoc name = search
- where
- search [] = do
- tell ["Cannot find documentation for: $" ++ name]
- return Nothing
- search (DocD (DocCommentNamed name' doc) : rest)
- | name == name' = return (Just doc)
- | otherwise = search rest
- search (_other_decl : rest) = search rest
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
deleted file mode 100644
index f1021436..00000000
--- a/src/Haddock/Interface/LexParseRn.hs
+++ /dev/null
@@ -1,146 +0,0 @@
-{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE BangPatterns #-}
- -----------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface.LexParseRn
--- Copyright : (c) Isaac Dupree 2009,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Interface.LexParseRn
- ( processDocString
- , processDocStringParas
- , processDocStrings
- , processModuleHeader
- ) where
-
-import Control.Applicative
-import Data.IntSet (toList)
-import Data.List
-import Documentation.Haddock.Doc (docConcat)
-import DynFlags (ExtensionFlag(..), languageExtensions)
-import FastString
-import GHC
-import Haddock.Interface.ParseModuleHeader
-import Haddock.Parser
-import Haddock.Types
-import Name
-import Outputable (showPpr)
-import RdrName
-
-processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)
-processDocStrings dflags gre strs =
- case docConcat $ map (processDocStringParas dflags gre) strs of
- DocEmpty -> Nothing
- x -> Just x
-
-
-processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
-processDocStringParas = process parseParas
-
-
-processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name
-processDocString = process parseString
-
-process :: (DynFlags -> String -> Doc RdrName)
- -> DynFlags
- -> GlobalRdrEnv
- -> HsDocString
- -> Doc Name
-process parse dflags gre (HsDocString fs) =
- rename dflags gre $ parse dflags (unpackFS fs)
-
-
-processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString
- -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))
-processModuleHeader dflags gre safety mayStr = do
- (hmi, doc) <-
- case mayStr of
- Nothing -> return failure
- Just (L _ (HsDocString fs)) -> do
- let str = unpackFS fs
- (hmi, doc) = parseModuleHeader dflags str
- !descr = rename dflags gre <$> hmi_description hmi
- hmi' = hmi { hmi_description = descr }
- doc' = rename dflags gre doc
- return (hmi', Just doc')
-
- let flags :: [ExtensionFlag]
- -- We remove the flags implied by the language setting and we display the language instead
- flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags)
- return (hmi { hmi_safety = Just $ showPpr dflags safety
- , hmi_language = language dflags
- , hmi_extensions = flags
- } , doc)
- where
- failure = (emptyHaddockModInfo, Nothing)
-
-
-rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name
-rename dflags gre = rn
- where
- rn d = case d of
- DocAppend a b -> DocAppend (rn a) (rn b)
- DocParagraph doc -> DocParagraph (rn doc)
- DocIdentifier x -> do
- let choices = dataTcOccs' x
- let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
- case names of
- [] ->
- case choices of
- [] -> DocMonospaced (DocString (showPpr dflags x))
- [a] -> outOfScope dflags a
- a:b:_ | isRdrTc a -> outOfScope dflags a
- | otherwise -> outOfScope dflags b
- [a] -> DocIdentifier a
- a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
- -- If an id can refer to multiple things, we give precedence to type
- -- constructors.
-
- DocWarning doc -> DocWarning (rn doc)
- DocEmphasis doc -> DocEmphasis (rn doc)
- DocBold doc -> DocBold (rn doc)
- DocMonospaced doc -> DocMonospaced (rn doc)
- DocUnorderedList docs -> DocUnorderedList (map rn docs)
- DocOrderedList docs -> DocOrderedList (map rn docs)
- DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ]
- DocCodeBlock doc -> DocCodeBlock (rn doc)
- DocIdentifierUnchecked x -> DocIdentifierUnchecked x
- DocModule str -> DocModule str
- DocHyperlink l -> DocHyperlink l
- DocPic str -> DocPic str
- DocAName str -> DocAName str
- DocProperty p -> DocProperty p
- DocExamples e -> DocExamples e
- DocEmpty -> DocEmpty
- DocString str -> DocString str
- DocHeader (Header l t) -> DocHeader $ Header l (rn t)
-
-dataTcOccs' :: RdrName -> [RdrName]
--- If the input is a data constructor, return both it and a type
--- constructor. This is useful when we aren't sure which we are
--- looking at.
---
--- We use this definition instead of the GHC's to provide proper linking to
--- functions accross modules. See ticket #253 on Haddock Trac.
-dataTcOccs' rdr_name
- | isDataOcc occ = [rdr_name, rdr_name_tc]
- | otherwise = [rdr_name]
- where
- occ = rdrNameOcc rdr_name
- rdr_name_tc = setRdrNameSpace rdr_name tcName
-
-
-outOfScope :: DynFlags -> RdrName -> Doc a
-outOfScope dflags x =
- case x of
- Unqual occ -> monospaced occ
- Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
- Orig _ occ -> monospaced occ
- Exact name -> monospaced name -- Shouldn't happen since x is out of scope
- where
- monospaced a = DocMonospaced (DocString (showPpr dflags a))
diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs
deleted file mode 100644
index 6848dc63..00000000
--- a/src/Haddock/Interface/ParseModuleHeader.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-{-# OPTIONS_GHC -Wwarn #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface.ParseModuleHeader
--- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where
-
-import Control.Applicative ((<$>))
-import Control.Monad (mplus)
-import Data.Char
-import DynFlags
-import Haddock.Parser
-import Haddock.Types
-import RdrName
-
--- -----------------------------------------------------------------------------
--- Parsing module headers
-
--- NB. The headers must be given in the order Module, Description,
--- Copyright, License, Maintainer, Stability, Portability, except that
--- any or all may be omitted.
-parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)
-parseModuleHeader dflags str0 =
- let
- getKey :: String -> String -> (Maybe String,String)
- getKey key str = case parseKey key str of
- Nothing -> (Nothing,str)
- Just (value,rest) -> (Just value,rest)
-
- (_moduleOpt,str1) = getKey "Module" str0
- (descriptionOpt,str2) = getKey "Description" str1
- (copyrightOpt,str3) = getKey "Copyright" str2
- (licenseOpt,str4) = getKey "License" str3
- (licenceOpt,str5) = getKey "Licence" str4
- (maintainerOpt,str6) = getKey "Maintainer" str5
- (stabilityOpt,str7) = getKey "Stability" str6
- (portabilityOpt,str8) = getKey "Portability" str7
-
- in (HaddockModInfo {
- hmi_description = parseString dflags <$> descriptionOpt,
- hmi_copyright = copyrightOpt,
- hmi_license = licenseOpt `mplus` licenceOpt,
- hmi_maintainer = maintainerOpt,
- hmi_stability = stabilityOpt,
- hmi_portability = portabilityOpt,
- hmi_safety = Nothing,
- hmi_language = Nothing, -- set in LexParseRn
- hmi_extensions = [] -- also set in LexParseRn
- }, parseParas dflags str8)
-
--- | This function is how we read keys.
---
--- all fields in the header are optional and have the form
---
--- [spaces1][field name][spaces] ":"
--- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")*
--- where each [spaces2] should have [spaces1] as a prefix.
---
--- Thus for the key "Description",
---
--- > Description : this is a
--- > rather long
--- >
--- > description
--- >
--- > The module comment starts here
---
--- the value will be "this is a .. description" and the rest will begin
--- at "The module comment".
-parseKey :: String -> String -> Maybe (String,String)
-parseKey key toParse0 =
- do
- let
- (spaces0,toParse1) = extractLeadingSpaces toParse0
-
- indentation = spaces0
- afterKey0 <- extractPrefix key toParse1
- let
- afterKey1 = extractLeadingSpaces afterKey0
- afterColon0 <- case snd afterKey1 of
- ':':afterColon -> return afterColon
- _ -> Nothing
- let
- (_,afterColon1) = extractLeadingSpaces afterColon0
-
- return (scanKey True indentation afterColon1)
- where
- scanKey :: Bool -> String -> String -> (String,String)
- scanKey _ _ [] = ([],[])
- scanKey isFirst indentation str =
- let
- (nextLine,rest1) = extractNextLine str
-
- accept = isFirst || sufficientIndentation || allSpaces
-
- sufficientIndentation = case extractPrefix indentation nextLine of
- Just (c:_) | isSpace c -> True
- _ -> False
-
- allSpaces = case extractLeadingSpaces nextLine of
- (_,[]) -> True
- _ -> False
- in
- if accept
- then
- let
- (scanned1,rest2) = scanKey False indentation rest1
-
- scanned2 = case scanned1 of
- "" -> if allSpaces then "" else nextLine
- _ -> nextLine ++ "\n" ++ scanned1
- in
- (scanned2,rest2)
- else
- ([],str)
-
- extractLeadingSpaces :: String -> (String,String)
- extractLeadingSpaces [] = ([],[])
- extractLeadingSpaces (s@(c:cs))
- | isSpace c =
- let
- (spaces1,cs1) = extractLeadingSpaces cs
- in
- (c:spaces1,cs1)
- | otherwise = ([],s)
-
- extractNextLine :: String -> (String,String)
- extractNextLine [] = ([],[])
- extractNextLine (c:cs)
- | c == '\n' =
- ([],cs)
- | otherwise =
- let
- (line,rest) = extractNextLine cs
- in
- (c:line,rest)
-
- -- comparison is case-insensitive.
- extractPrefix :: String -> String -> Maybe String
- extractPrefix [] s = Just s
- extractPrefix _ [] = Nothing
- extractPrefix (c1:cs1) (c2:cs2)
- | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2
- | otherwise = Nothing
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
deleted file mode 100644
index 748e0210..00000000
--- a/src/Haddock/Interface/Rename.hs
+++ /dev/null
@@ -1,506 +0,0 @@
-----------------------------------------------------------------------------
--- |
--- Module : Haddock.Interface.Rename
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Interface.Rename (renameInterface) where
-
-
-import Data.Traversable (traverse)
-
-import Haddock.GhcUtils
-import Haddock.Types
-
-import Bag (emptyBag)
-import GHC hiding (NoLink)
-import Name
-
-import Control.Applicative
-import Control.Monad hiding (mapM)
-import Data.List
-import qualified Data.Map as Map hiding ( Map )
-import Data.Traversable (mapM)
-import Prelude hiding (mapM)
-
-
-renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
-renameInterface dflags renamingEnv warnings iface =
-
- -- first create the local env, where every name exported by this module
- -- is mapped to itself, and everything else comes from the global renaming
- -- env
- let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
- where fn env name = Map.insert name (ifaceMod iface) env
-
- -- rename names in the exported declarations to point to things that
- -- are closer to, or maybe even exported by, the current module.
- (renamedExportItems, missingNames1)
- = runRnFM localEnv (renameExportItems (ifaceExportItems iface))
-
- (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))
-
- (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))
-
- (finalModuleDoc, missingNames4)
- = runRnFM localEnv (renameDocumentation (ifaceDoc iface))
-
- -- combine the missing names and filter out the built-ins, which would
- -- otherwise allways be missing.
- missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much
- (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4)
-
- -- filter out certain built in type constructors using their string
- -- representation. TODO: use the Name constants from the GHC API.
--- strings = filter (`notElem` ["()", "[]", "(->)"])
--- (map pretty missingNames)
- strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames
-
- in do
- -- report things that we couldn't link to. Only do this for non-hidden
- -- modules.
- unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
- tell ["Warning: " ++ moduleString (ifaceMod iface) ++
- ": could not find link destinations for:\n"++
- unwords (" " : strings) ]
-
- return $ iface { ifaceRnDoc = finalModuleDoc,
- ifaceRnDocMap = rnDocMap,
- ifaceRnArgMap = rnArgMap,
- ifaceRnExportItems = renamedExportItems }
-
-
---------------------------------------------------------------------------------
--- Monad for renaming
---
--- The monad does two things for us: it passes around the environment for
--- renaming, and it returns a list of names which couldn't be found in
--- the environment.
---------------------------------------------------------------------------------
-
-
-newtype RnM a =
- RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function
- -> (a,[Name])
- }
-
-instance Monad RnM where
- (>>=) = thenRn
- return = returnRn
-
-instance Functor RnM where
- fmap f x = do a <- x; return (f a)
-
-instance Applicative RnM where
- pure = return
- (<*>) = ap
-
-returnRn :: a -> RnM a
-returnRn a = RnM (const (a,[]))
-thenRn :: RnM a -> (a -> RnM b) -> RnM b
-m `thenRn` k = RnM (\lkp -> case unRn m lkp of
- (a,out1) -> case unRn (k a) lkp of
- (b,out2) -> (b,out1++out2))
-
-getLookupRn :: RnM (Name -> (Bool, DocName))
-getLookupRn = RnM (\lkp -> (lkp,[]))
-
-outRn :: Name -> RnM ()
-outRn name = RnM (const ((),[name]))
-
-lookupRn :: Name -> RnM DocName
-lookupRn name = do
- lkp <- getLookupRn
- case lkp name of
- (False,maps_to) -> do outRn name; return maps_to
- (True, maps_to) -> return maps_to
-
-
-runRnFM :: LinkEnv -> RnM a -> (a,[Name])
-runRnFM env rn = unRn rn lkp
- where
- lkp n = case Map.lookup n env of
- Nothing -> (False, Undocumented n)
- Just mdl -> (True, Documented n mdl)
-
-
---------------------------------------------------------------------------------
--- Renaming
---------------------------------------------------------------------------------
-
-
-rename :: Name -> RnM DocName
-rename = lookupRn
-
-
-renameL :: Located Name -> RnM (Located DocName)
-renameL = mapM rename
-
-
-renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]
-renameExportItems = mapM renameExportItem
-
-
-renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
-renameDocForDecl (doc, fnArgsDoc) =
- (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc
-
-
-renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
-renameDocumentation (Documentation mDoc mWarning) =
- Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning
-
-
-renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
-renameLDocHsSyn = return
-
-
-renameDoc :: Doc Name -> RnM (Doc DocName)
-renameDoc = traverse rename
-
-
-renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
-renameFnArgsDoc = mapM renameDoc
-
-
-renameLType :: LHsType Name -> RnM (LHsType DocName)
-renameLType = mapM renameType
-
-renameLKind :: LHsKind Name -> RnM (LHsKind DocName)
-renameLKind = renameLType
-
-renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))
-renameMaybeLKind = traverse renameLKind
-
-renameType :: HsType Name -> RnM (HsType DocName)
-renameType t = case t of
- HsForAllTy expl tyvars lcontext ltype -> do
- tyvars' <- renameLTyVarBndrs tyvars
- lcontext' <- renameLContext lcontext
- ltype' <- renameLType ltype
- return (HsForAllTy expl tyvars' lcontext' ltype')
-
- HsTyVar n -> return . HsTyVar =<< rename n
- HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
-
- HsAppTy a b -> do
- a' <- renameLType a
- b' <- renameLType b
- return (HsAppTy a' b')
-
- HsFunTy a b -> do
- a' <- renameLType a
- b' <- renameLType b
- return (HsFunTy a' b')
-
- HsListTy ty -> return . HsListTy =<< renameLType ty
- HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
- HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
- HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
-
- HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
-
- HsOpTy a (w, L loc op) b -> do
- op' <- rename op
- a' <- renameLType a
- b' <- renameLType b
- return (HsOpTy a' (w, L loc op') b')
-
- HsParTy ty -> return . HsParTy =<< renameLType ty
-
- HsKindSig ty k -> do
- ty' <- renameLType ty
- k' <- renameLKind k
- return (HsKindSig ty' k')
-
- HsDocTy ty doc -> do
- ty' <- renameLType ty
- doc' <- renameLDocHsSyn doc
- return (HsDocTy ty' doc')
-
- HsTyLit x -> return (HsTyLit x)
-
- HsWrapTy a b -> HsWrapTy a <$> renameType b
- HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
- HsCoreTy a -> pure (HsCoreTy a)
- HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b
- HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
- HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a
- HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
-
-renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName)
-renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c
-
-renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)
-renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })
- = do { tvs' <- mapM renameLTyVarBndr tvs
- ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }
- -- This is rather bogus, but I'm not sure what else to do
-
-renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)
-renameLTyVarBndr (L loc (UserTyVar n))
- = do { n' <- rename n
- ; return (L loc (UserTyVar n')) }
-renameLTyVarBndr (L loc (KindedTyVar n kind))
- = do { n' <- rename n
- ; kind' <- renameLKind kind
- ; return (L loc (KindedTyVar n' kind')) }
-
-renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName])
-renameLContext (L loc context) = do
- context' <- mapM renameLType context
- return (L loc context')
-
-
-renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (className, k, types, rest) = do
- className' <- rename className
- k' <- mapM renameType k
- types' <- mapM renameType types
- rest' <- case rest of
- ClassInst cs -> ClassInst <$> mapM renameType cs
- TypeInst ts -> TypeInst <$> traverse renameType ts
- DataInst dd -> DataInst <$> renameTyClD dd
- return (className', k', types', rest')
-
-
-renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
-renameLDecl (L loc d) = return . L loc =<< renameDecl d
-
-
-renameDecl :: HsDecl Name -> RnM (HsDecl DocName)
-renameDecl decl = case decl of
- TyClD d -> do
- d' <- renameTyClD d
- return (TyClD d')
- SigD s -> do
- s' <- renameSig s
- return (SigD s')
- ForD d -> do
- d' <- renameForD d
- return (ForD d')
- InstD d -> do
- d' <- renameInstD d
- return (InstD d')
- _ -> error "renameDecl"
-
-renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName))
-renameLThing fn (L loc x) = return . L loc =<< fn x
-
-renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName)
-renameTyClD d = case d of
- ForeignType lname b -> do
- lname' <- renameL lname
- return (ForeignType lname' b)
-
--- TyFamily flav lname ltyvars kind tckind -> do
- FamDecl { tcdFam = decl } -> do
- decl' <- renameFamilyDecl decl
- return (FamDecl { tcdFam = decl' })
-
- SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do
- lname' <- renameL lname
- tyvars' <- renameLTyVarBndrs tyvars
- rhs' <- renameLType rhs
- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })
-
- DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do
- lname' <- renameL lname
- tyvars' <- renameLTyVarBndrs tyvars
- defn' <- renameDataDefn defn
- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })
-
- ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars
- , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
- lcontext' <- renameLContext lcontext
- lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
- lfundeps' <- mapM renameLFunDep lfundeps
- lsigs' <- mapM renameLSig lsigs
- ats' <- mapM (renameLThing renameFamilyDecl) ats
- at_defs' <- mapM (mapM renameTyFamInstD) at_defs
- -- we don't need the default methods or the already collected doc entities
- return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
- , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
- , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })
-
- where
- renameLFunDep (L loc (xs, ys)) = do
- xs' <- mapM rename xs
- ys' <- mapM rename ys
- return (L loc (xs', ys'))
-
- renameLSig (L loc sig) = return . L loc =<< renameSig sig
-
-renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName)
-renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
- , fdTyVars = ltyvars, fdKindSig = tckind }) = do
- info' <- renameFamilyInfo info
- lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
- tckind' <- renameMaybeLKind tckind
- return (FamilyDecl { fdInfo = info', fdLName = lname'
- , fdTyVars = ltyvars', fdKindSig = tckind' })
-
-renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
-renameFamilyInfo DataFamily = return DataFamily
-renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
-renameFamilyInfo (ClosedTypeFamily eqns)
- = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns
- ; return $ ClosedTypeFamily eqns' }
-
-renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)
-renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
- , dd_kindSig = k, dd_cons = cons }) = do
- lcontext' <- renameLContext lcontext
- k' <- renameMaybeLKind k
- cons' <- mapM (mapM renameCon) cons
- -- I don't think we need the derivings, so we return Nothing
- return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
- , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing })
-
-renameCon :: ConDecl Name -> RnM (ConDecl DocName)
-renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars
- , con_cxt = lcontext, con_details = details
- , con_res = restype, con_doc = mbldoc }) = do
- lname' <- renameL lname
- ltyvars' <- renameLTyVarBndrs ltyvars
- lcontext' <- renameLContext lcontext
- details' <- renameDetails details
- restype' <- renameResType restype
- mbldoc' <- mapM renameLDocHsSyn mbldoc
- return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
- , con_details = details', con_res = restype', con_doc = mbldoc' })
- where
- renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields
- renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
- renameDetails (InfixCon a b) = do
- a' <- renameLType a
- b' <- renameLType b
- return (InfixCon a' b')
-
- renameResType (ResTyH98) = return ResTyH98
- renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t
-
-
-renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)
-renameConDeclFieldField (ConDeclField name t doc) = do
- name' <- renameL name
- t' <- renameLType t
- doc' <- mapM renameLDocHsSyn doc
- return (ConDeclField name' t' doc')
-
-
-renameSig :: Sig Name -> RnM (Sig DocName)
-renameSig sig = case sig of
- TypeSig lnames ltype -> do
- lnames' <- mapM renameL lnames
- ltype' <- renameLType ltype
- return (TypeSig lnames' ltype')
- PatSynSig lname args ltype lreq lprov -> do
- lname' <- renameL lname
- args' <- case args of
- PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs
- InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright
- ltype' <- renameLType ltype
- lreq' <- renameLContext lreq
- lprov' <- renameLContext lprov
- return $ PatSynSig lname' args' ltype' lreq' lprov'
- FixSig (FixitySig lname fixity) -> do
- lname' <- renameL lname
- return $ FixSig (FixitySig lname' fixity)
- MinimalSig s -> MinimalSig <$> traverse renameL s
- -- we have filtered out all other kinds of signatures in Interface.Create
- _ -> error "expected TypeSig"
-
-
-renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName)
-renameForD (ForeignImport lname ltype co x) = do
- lname' <- renameL lname
- ltype' <- renameLType ltype
- return (ForeignImport lname' ltype' co x)
-renameForD (ForeignExport lname ltype co x) = do
- lname' <- renameL lname
- ltype' <- renameLType ltype
- return (ForeignExport lname' ltype' co x)
-
-
-renameInstD :: InstDecl Name -> RnM (InstDecl DocName)
-renameInstD (ClsInstD { cid_inst = d }) = do
- d' <- renameClsInstD d
- return (ClsInstD { cid_inst = d' })
-renameInstD (TyFamInstD { tfid_inst = d }) = do
- d' <- renameTyFamInstD d
- return (TyFamInstD { tfid_inst = d' })
-renameInstD (DataFamInstD { dfid_inst = d }) = do
- d' <- renameDataFamInstD d
- return (DataFamInstD { dfid_inst = d' })
-
-renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)
-renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do
- ltype' <- renameLType ltype
- lATs' <- mapM (mapM renameTyFamInstD) lATs
- lADTs' <- mapM (mapM renameDataFamInstD) lADTs
- return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []
- , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })
-
-
-renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName)
-renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
- = do { eqn' <- renameLThing renameTyFamInstEqn eqn
- ; return (TyFamInstDecl { tfid_eqn = eqn'
- , tfid_fvs = placeHolderNames }) }
-
-renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)
-renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })
- = do { tc' <- renameL tc
- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
- ; rhs' <- renameLType rhs
- ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }
- , tfie_rhs = rhs' }) }
-
-renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName)
-renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn })
- = do { tc' <- renameL tc
- ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)
- ; defn' <- renameDataDefn defn
- ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }
- , dfid_defn = defn', dfid_fvs = placeHolderNames }) }
-
-renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
-renameExportItem item = case item of
- ExportModule mdl -> return (ExportModule mdl)
- ExportGroup lev id_ doc -> do
- doc' <- renameDoc doc
- return (ExportGroup lev id_ doc')
- ExportDecl decl doc subs instances fixities splice -> do
- decl' <- renameLDecl decl
- doc' <- renameDocForDecl doc
- subs' <- mapM renameSub subs
- instances' <- forM instances $ \(inst, idoc) -> do
- inst' <- renameInstHead inst
- idoc' <- mapM renameDoc idoc
- return (inst', idoc')
- fixities' <- forM fixities $ \(name, fixity) -> do
- name' <- lookupRn name
- return (name', fixity)
- return (ExportDecl decl' doc' subs' instances' fixities' splice)
- ExportNoDecl x subs -> do
- x' <- lookupRn x
- subs' <- mapM lookupRn subs
- return (ExportNoDecl x' subs')
- ExportDoc doc -> do
- doc' <- renameDoc doc
- return (ExportDoc doc')
-
-
-renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
-renameSub (n,doc) = do
- n' <- rename n
- doc' <- renameDocForDecl doc
- return (n', doc')
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
deleted file mode 100644
index bb997b9a..00000000
--- a/src/Haddock/InterfaceFile.hs
+++ /dev/null
@@ -1,636 +0,0 @@
-{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.InterfaceFile
--- Copyright : (c) David Waern 2006-2009,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Reading and writing the .haddock interface file
------------------------------------------------------------------------------
-module Haddock.InterfaceFile (
- InterfaceFile(..), ifPackageId,
- readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
- writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
-) where
-
-
-import Haddock.Types
-import Haddock.Utils hiding (out)
-
-import Control.Monad
-import Data.Array
-import Data.Functor ((<$>))
-import Data.IORef
-import Data.List
-import qualified Data.Map as Map
-import Data.Map (Map)
-import Data.Word
-
-import BinIface (getSymtabName, getDictFastString)
-import Binary
-import FastMutInt
-import FastString
-import GHC hiding (NoLink)
-import GhcMonad (withSession)
-import HscTypes
-import IfaceEnv
-import Name
-import UniqFM
-import UniqSupply
-import Unique
-
-
-data InterfaceFile = InterfaceFile {
- ifLinkEnv :: LinkEnv,
- ifInstalledIfaces :: [InstalledInterface]
-}
-
-
-ifPackageId :: InterfaceFile -> PackageId
-ifPackageId if_ =
- case ifInstalledIfaces if_ of
- [] -> error "empty InterfaceFile"
- iface:_ -> modulePackageId $ instMod iface
-
-
-binaryInterfaceMagic :: Word32
-binaryInterfaceMagic = 0xD0Cface
-
-
--- IMPORTANT: Since datatypes in the GHC API might change between major
--- versions, and because we store GHC datatypes in our interface files, we need
--- to make sure we version our interface files accordingly.
---
--- If you change the interface file format or adapt Haddock to work with a new
--- major version of GHC (so that the format changes indirectly) *you* need to
--- follow these steps:
---
--- (1) increase `binaryInterfaceVersion`
---
--- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion]
---
-binaryInterfaceVersion :: Word16
-#if __GLASGOW_HASKELL__ == 708
-binaryInterfaceVersion = 25
-
-binaryInterfaceVersionCompatibility :: [Word16]
-binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
-#else
-#error Unsupported GHC version
-#endif
-
-
-initBinMemSize :: Int
-initBinMemSize = 1024*1024
-
-
-writeInterfaceFile :: FilePath -> InterfaceFile -> IO ()
-writeInterfaceFile filename iface = do
- bh0 <- openBinMem initBinMemSize
- put_ bh0 binaryInterfaceMagic
- put_ bh0 binaryInterfaceVersion
-
- -- remember where the dictionary pointer will go
- dict_p_p <- tellBin bh0
- put_ bh0 dict_p_p
-
- -- remember where the symbol table pointer will go
- symtab_p_p <- tellBin bh0
- put_ bh0 symtab_p_p
-
- -- Make some intial state
- symtab_next <- newFastMutInt
- writeFastMutInt symtab_next 0
- symtab_map <- newIORef emptyUFM
- let bin_symtab = BinSymbolTable {
- bin_symtab_next = symtab_next,
- bin_symtab_map = symtab_map }
- dict_next_ref <- newFastMutInt
- writeFastMutInt dict_next_ref 0
- dict_map_ref <- newIORef emptyUFM
- let bin_dict = BinDictionary {
- bin_dict_next = dict_next_ref,
- bin_dict_map = dict_map_ref }
-
- -- put the main thing
- let bh = setUserData bh0 $ newWriteState (putName bin_symtab)
- (putFastString bin_dict)
- put_ bh iface
-
- -- write the symtab pointer at the front of the file
- symtab_p <- tellBin bh
- putAt bh symtab_p_p symtab_p
- seekBin bh symtab_p
-
- -- write the symbol table itself
- symtab_next' <- readFastMutInt symtab_next
- symtab_map' <- readIORef symtab_map
- putSymbolTable bh symtab_next' symtab_map'
-
- -- write the dictionary pointer at the fornt of the file
- dict_p <- tellBin bh
- putAt bh dict_p_p dict_p
- seekBin bh dict_p
-
- -- write the dictionary itself
- dict_next <- readFastMutInt dict_next_ref
- dict_map <- readIORef dict_map_ref
- putDictionary bh dict_next dict_map
-
- -- and send the result to the file
- writeBinMem bh filename
- return ()
-
-
-type NameCacheAccessor m = (m NameCache, NameCache -> m ())
-
-
-nameCacheFromGhc :: NameCacheAccessor Ghc
-nameCacheFromGhc = ( read_from_session , write_to_session )
- where
- read_from_session = do
- ref <- withSession (return . hsc_NC)
- liftIO $ readIORef ref
- write_to_session nc' = do
- ref <- withSession (return . hsc_NC)
- liftIO $ writeIORef ref nc'
-
-
-freshNameCache :: NameCacheAccessor IO
-freshNameCache = ( create_fresh_nc , \_ -> return () )
- where
- create_fresh_nc = do
- u <- mkSplitUniqSupply 'a' -- ??
- return (initNameCache u [])
-
-
--- | Read a Haddock (@.haddock@) interface file. Return either an
--- 'InterfaceFile' or an error message.
---
--- This function can be called in two ways. Within a GHC session it will
--- update the use and update the session's name cache. Outside a GHC session
--- a new empty name cache is used. The function is therefore generic in the
--- monad being used. The exact monad is whichever monad the first
--- argument, the getter and setter of the name cache, requires.
---
-readInterfaceFile :: forall m.
- MonadIO m
- => NameCacheAccessor m
- -> FilePath
- -> m (Either String InterfaceFile)
-readInterfaceFile (get_name_cache, set_name_cache) filename = do
- bh0 <- liftIO $ readBinMem filename
-
- magic <- liftIO $ get bh0
- version <- liftIO $ get bh0
-
- case () of
- _ | magic /= binaryInterfaceMagic -> return . Left $
- "Magic number mismatch: couldn't load interface file: " ++ filename
- | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $
- "Interface file is of wrong version: " ++ filename
- | otherwise -> with_name_cache $ \update_nc -> do
-
- dict <- get_dictionary bh0
-
- -- read the symbol table so we are capable of reading the actual data
- bh1 <- do
- let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
- (getDictFastString dict)
- symtab <- update_nc (get_symbol_table bh1)
- return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab)
- (getDictFastString dict)
-
- -- load the actual data
- iface <- liftIO $ get bh1
- return (Right iface)
- where
- with_name_cache :: forall a.
- ((forall n b. MonadIO n
- => (NameCache -> n (NameCache, b))
- -> n b)
- -> m a)
- -> m a
- with_name_cache act = do
- nc_var <- get_name_cache >>= (liftIO . newIORef)
- x <- act $ \f -> do
- nc <- liftIO $ readIORef nc_var
- (nc', x) <- f nc
- liftIO $ writeIORef nc_var nc'
- return x
- liftIO (readIORef nc_var) >>= set_name_cache
- return x
-
- get_dictionary bin_handle = liftIO $ do
- dict_p <- get bin_handle
- data_p <- tellBin bin_handle
- seekBin bin_handle dict_p
- dict <- getDictionary bin_handle
- seekBin bin_handle data_p
- return dict
-
- get_symbol_table bh1 theNC = liftIO $ do
- symtab_p <- get bh1
- data_p' <- tellBin bh1
- seekBin bh1 symtab_p
- (nc', symtab) <- getSymbolTable bh1 theNC
- seekBin bh1 data_p'
- return (nc', symtab)
-
-
--------------------------------------------------------------------------------
--- * Symbol table
--------------------------------------------------------------------------------
-
-
-putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
-putName BinSymbolTable{
- bin_symtab_map = symtab_map_ref,
- bin_symtab_next = symtab_next } bh name
- = do
- symtab_map <- readIORef symtab_map_ref
- case lookupUFM symtab_map name of
- Just (off,_) -> put_ bh (fromIntegral off :: Word32)
- Nothing -> do
- off <- readFastMutInt symtab_next
- writeFastMutInt symtab_next (off+1)
- writeIORef symtab_map_ref
- $! addToUFM symtab_map name (off,name)
- put_ bh (fromIntegral off :: Word32)
-
-
-data BinSymbolTable = BinSymbolTable {
- bin_symtab_next :: !FastMutInt, -- The next index to use
- bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
- -- indexed by Name
- }
-
-
-putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
-putFastString BinDictionary { bin_dict_next = j_r,
- bin_dict_map = out_r} bh f
- = do
- out <- readIORef out_r
- let unique = getUnique f
- case lookupUFM out unique of
- Just (j, _) -> put_ bh (fromIntegral j :: Word32)
- Nothing -> do
- j <- readFastMutInt j_r
- put_ bh (fromIntegral j :: Word32)
- writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM out unique (j, f)
-
-
-data BinDictionary = BinDictionary {
- bin_dict_next :: !FastMutInt, -- The next index to use
- bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
- -- indexed by FastString
- }
-
-
-putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
-putSymbolTable bh next_off symtab = do
- put_ bh next_off
- let names = elems (array (0,next_off-1) (eltsUFM symtab))
- mapM_ (\n -> serialiseName bh n symtab) names
-
-
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
- sz <- get bh
- od_names <- replicateM sz (get bh)
- let arr = listArray (0,sz-1) names
- (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names
- return (namecache', arr)
-
-
-type OnDiskName = (PackageId, ModuleName, OccName)
-
-
-fromOnDiskName
- :: Array Int Name
- -> NameCache
- -> OnDiskName
- -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
- let
- modu = mkModule pid mod_name
- cache = nsNames nc
- in
- case lookupOrigNameCache cache modu occ of
- Just name -> (nc, name)
- Nothing ->
- let
- us = nsUniqs nc
- u = uniqFromSupply us
- name = mkExternalName u modu occ noSrcSpan
- new_cache = extendNameCache cache modu occ name
- in
- case splitUniqSupply us of { (us',_) ->
- ( nc{ nsUniqs = us', nsNames = new_cache }, name )
- }
-
-
-serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
-serialiseName bh name _ = do
- let modu = nameModule name
- put_ bh (modulePackageId modu, moduleName modu, nameOccName name)
-
-
--------------------------------------------------------------------------------
--- * GhcBinary instances
--------------------------------------------------------------------------------
-
-
-instance (Ord k, Binary k, Binary v) => Binary (Map k v) where
- put_ bh m = put_ bh (Map.toList m)
- get bh = fmap (Map.fromList) (get bh)
-
-
-instance Binary InterfaceFile where
- put_ bh (InterfaceFile env ifaces) = do
- put_ bh env
- put_ bh ifaces
-
- get bh = do
- env <- get bh
- ifaces <- get bh
- return (InterfaceFile env ifaces)
-
-
-instance Binary InstalledInterface where
- put_ bh (InstalledInterface modu info docMap argMap
- exps visExps opts subMap fixMap) = do
- put_ bh modu
- put_ bh info
- put_ bh docMap
- put_ bh argMap
- put_ bh exps
- put_ bh visExps
- put_ bh opts
- put_ bh subMap
- put_ bh fixMap
-
- get bh = do
- modu <- get bh
- info <- get bh
- docMap <- get bh
- argMap <- get bh
- exps <- get bh
- visExps <- get bh
- opts <- get bh
- subMap <- get bh
- fixMap <- get bh
-
- return (InstalledInterface modu info docMap argMap
- exps visExps opts subMap fixMap)
-
-
-instance Binary DocOption where
- put_ bh OptHide = do
- putByte bh 0
- put_ bh OptPrune = do
- putByte bh 1
- put_ bh OptIgnoreExports = do
- putByte bh 2
- put_ bh OptNotHome = do
- putByte bh 3
- put_ bh OptShowExtensions = do
- putByte bh 4
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- return OptHide
- 1 -> do
- return OptPrune
- 2 -> do
- return OptIgnoreExports
- 3 -> do
- return OptNotHome
- 4 -> do
- return OptShowExtensions
- _ -> fail "invalid binary data found"
-
-
-instance Binary Example where
- put_ bh (Example expression result) = do
- put_ bh expression
- put_ bh result
- get bh = do
- expression <- get bh
- result <- get bh
- return (Example expression result)
-
-instance Binary Hyperlink where
- put_ bh (Hyperlink url label) = do
- put_ bh url
- put_ bh label
- get bh = do
- url <- get bh
- label <- get bh
- return (Hyperlink url label)
-
-instance Binary Picture where
- put_ bh (Picture uri title) = do
- put_ bh uri
- put_ bh title
- get bh = do
- uri <- get bh
- title <- get bh
- return (Picture uri title)
-
-instance Binary a => Binary (Header a) where
- put_ bh (Header l t) = do
- put_ bh l
- put_ bh t
- get bh = do
- l <- get bh
- t <- get bh
- return (Header l t)
-
-{-* Generated by DrIFT : Look, but Don't Touch. *-}
-instance (Binary mod, Binary id) => Binary (DocH mod id) where
- put_ bh DocEmpty = do
- putByte bh 0
- put_ bh (DocAppend aa ab) = do
- putByte bh 1
- put_ bh aa
- put_ bh ab
- put_ bh (DocString ac) = do
- putByte bh 2
- put_ bh ac
- put_ bh (DocParagraph ad) = do
- putByte bh 3
- put_ bh ad
- put_ bh (DocIdentifier ae) = do
- putByte bh 4
- put_ bh ae
- put_ bh (DocModule af) = do
- putByte bh 5
- put_ bh af
- put_ bh (DocEmphasis ag) = do
- putByte bh 6
- put_ bh ag
- put_ bh (DocMonospaced ah) = do
- putByte bh 7
- put_ bh ah
- put_ bh (DocUnorderedList ai) = do
- putByte bh 8
- put_ bh ai
- put_ bh (DocOrderedList aj) = do
- putByte bh 9
- put_ bh aj
- put_ bh (DocDefList ak) = do
- putByte bh 10
- put_ bh ak
- put_ bh (DocCodeBlock al) = do
- putByte bh 11
- put_ bh al
- put_ bh (DocHyperlink am) = do
- putByte bh 12
- put_ bh am
- put_ bh (DocPic x) = do
- putByte bh 13
- put_ bh x
- put_ bh (DocAName an) = do
- putByte bh 14
- put_ bh an
- put_ bh (DocExamples ao) = do
- putByte bh 15
- put_ bh ao
- put_ bh (DocIdentifierUnchecked x) = do
- putByte bh 16
- put_ bh x
- put_ bh (DocWarning ag) = do
- putByte bh 17
- put_ bh ag
- put_ bh (DocProperty x) = do
- putByte bh 18
- put_ bh x
- put_ bh (DocBold x) = do
- putByte bh 19
- put_ bh x
- put_ bh (DocHeader aa) = do
- putByte bh 20
- put_ bh aa
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- return DocEmpty
- 1 -> do
- aa <- get bh
- ab <- get bh
- return (DocAppend aa ab)
- 2 -> do
- ac <- get bh
- return (DocString ac)
- 3 -> do
- ad <- get bh
- return (DocParagraph ad)
- 4 -> do
- ae <- get bh
- return (DocIdentifier ae)
- 5 -> do
- af <- get bh
- return (DocModule af)
- 6 -> do
- ag <- get bh
- return (DocEmphasis ag)
- 7 -> do
- ah <- get bh
- return (DocMonospaced ah)
- 8 -> do
- ai <- get bh
- return (DocUnorderedList ai)
- 9 -> do
- aj <- get bh
- return (DocOrderedList aj)
- 10 -> do
- ak <- get bh
- return (DocDefList ak)
- 11 -> do
- al <- get bh
- return (DocCodeBlock al)
- 12 -> do
- am <- get bh
- return (DocHyperlink am)
- 13 -> do
- x <- get bh
- return (DocPic x)
- 14 -> do
- an <- get bh
- return (DocAName an)
- 15 -> do
- ao <- get bh
- return (DocExamples ao)
- 16 -> do
- x <- get bh
- return (DocIdentifierUnchecked x)
- 17 -> do
- ag <- get bh
- return (DocWarning ag)
- 18 -> do
- x <- get bh
- return (DocProperty x)
- 19 -> do
- x <- get bh
- return (DocBold x)
- 20 -> do
- aa <- get bh
- return (DocHeader aa)
- _ -> error "invalid binary data found in the interface file"
-
-
-instance Binary name => Binary (HaddockModInfo name) where
- put_ bh hmi = do
- put_ bh (hmi_description hmi)
- put_ bh (hmi_copyright hmi)
- put_ bh (hmi_license hmi)
- put_ bh (hmi_maintainer hmi)
- put_ bh (hmi_stability hmi)
- put_ bh (hmi_portability hmi)
- put_ bh (hmi_safety hmi)
- put_ bh (fromEnum <$> hmi_language hmi)
- put_ bh (map fromEnum $ hmi_extensions hmi)
-
- get bh = do
- descr <- get bh
- copyr <- get bh
- licen <- get bh
- maint <- get bh
- stabi <- get bh
- porta <- get bh
- safet <- get bh
- langu <- fmap toEnum <$> get bh
- exten <- map toEnum <$> get bh
- return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten)
-
-instance Binary DocName where
- put_ bh (Documented name modu) = do
- putByte bh 0
- put_ bh name
- put_ bh modu
- put_ bh (Undocumented name) = do
- putByte bh 1
- put_ bh name
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- name <- get bh
- modu <- get bh
- return (Documented name modu)
- 1 -> do
- name <- get bh
- return (Undocumented name)
- _ -> error "get DocName: Bad h"
diff --git a/src/Haddock/ModuleTree.hs b/src/Haddock/ModuleTree.hs
deleted file mode 100644
index 2a7fbfcc..00000000
--- a/src/Haddock/ModuleTree.hs
+++ /dev/null
@@ -1,56 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.ModuleTree
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where
-
-
-import Haddock.Types ( Doc )
-
-import GHC ( Name )
-import Module ( Module, moduleNameString, moduleName, modulePackageId,
- packageIdString )
-
-
-data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree]
-
-
-mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree]
-mkModuleTree showPkgs mods =
- foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ]
- where
- modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_))
- | otherwise = Nothing
- fn (mod_,pkg,short) = addToTrees mod_ pkg short
-
-
-addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree]
-addToTrees [] _ _ ts = ts
-addToTrees ss pkg short [] = mkSubTree ss pkg short
-addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)
- | s1 > s2 = t : addToTrees (s1:ss) pkg short ts
- | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts
- | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts
- where
- this_pkg = if null ss then pkg else node_pkg
- this_short = if null ss then short else node_short
-
-
-mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree]
-mkSubTree [] _ _ = []
-mkSubTree [s] pkg short = [Node s True pkg short []]
-mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
-
-
-splitModule :: Module -> [String]
-splitModule mdl = split (moduleNameString (moduleName mdl))
- where split mod0 = case break (== '.') mod0 of
- (s1, '.':s2) -> s1 : split s2
- (s1, _) -> [s1]
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
deleted file mode 100644
index b166de46..00000000
--- a/src/Haddock/Options.hs
+++ /dev/null
@@ -1,287 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Options
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Definition of the command line interface of Haddock.
------------------------------------------------------------------------------
-module Haddock.Options (
- parseHaddockOpts,
- Flag(..),
- getUsage,
- optTitle,
- outputDir,
- optContentsUrl,
- optIndexUrl,
- optCssFile,
- sourceUrls,
- wikiUrls,
- optDumpInterfaceFile,
- optLaTeXStyle,
- qualification,
- verbosity,
- ghcFlags,
- readIfaceArgs
-) where
-
-
-import Distribution.Verbosity
-import Haddock.Utils
-import Haddock.Types
-import System.Console.GetOpt
-import qualified Data.Char as Char
-
-
-data Flag
- = Flag_BuiltInThemes
- | Flag_CSS String
--- | Flag_DocBook
- | Flag_ReadInterface String
- | Flag_DumpInterface String
- | Flag_Heading String
- | Flag_Html
- | Flag_Hoogle
- | Flag_Lib String
- | Flag_OutputDir FilePath
- | Flag_Prologue FilePath
- | Flag_SourceBaseURL String
- | Flag_SourceModuleURL String
- | Flag_SourceEntityURL String
- | Flag_SourceLEntityURL String
- | Flag_WikiBaseURL String
- | Flag_WikiModuleURL String
- | Flag_WikiEntityURL String
- | Flag_LaTeX
- | Flag_LaTeXStyle String
- | Flag_Help
- | Flag_Verbosity String
- | Flag_Version
- | Flag_CompatibleInterfaceVersions
- | Flag_InterfaceVersion
- | Flag_UseContents String
- | Flag_GenContents
- | Flag_UseIndex String
- | Flag_GenIndex
- | Flag_IgnoreAllExports
- | Flag_HideModule String
- | Flag_ShowExtensions String
- | Flag_OptGhc String
- | Flag_GhcLibDir String
- | Flag_GhcVersion
- | Flag_PrintGhcPath
- | Flag_PrintGhcLibDir
- | Flag_NoWarnings
- | Flag_UseUnicode
- | Flag_NoTmpCompDir
- | Flag_Qualification String
- | Flag_PrettyHtml
- | Flag_PrintMissingDocs
- deriving (Eq)
-
-
-options :: Bool -> [OptDescr Flag]
-options backwardsCompat =
- [
- Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR")
- "path to a GHC lib dir, to override the default path",
- Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR")
- "directory in which to put the output files",
- Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR")
- "location of Haddock's auxiliary files",
- Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
- "read an interface from FILE",
- Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
- "write the resulting interface to FILE",
--- Option ['S'] ["docbook"] (NoArg Flag_DocBook)
--- "output in DocBook XML",
- Option ['h'] ["html"] (NoArg Flag_Html)
- "output in HTML (XHTML 1.0)",
- Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
- Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
- Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
- Option [] ["hoogle"] (NoArg Flag_Hoogle)
- "output for Hoogle",
- Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL")
- "URL for a source code link on the contents\nand index pages",
- Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
- (ReqArg Flag_SourceModuleURL "URL")
- "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
- Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL")
- "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
- Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
- "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
- Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL")
- "URL for a comments link on the contents\nand index pages",
- Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL")
- "URL for a comments link for each module\n(using the %{MODULE} var)",
- Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL")
- "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
- Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH")
- "the CSS file or theme directory to use for HTML output",
- Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes)
- "include all the built-in haddock themes",
- Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE")
- "file containing prologue text",
- Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
- "page heading",
- Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")
- "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
- Option ['?'] ["help"] (NoArg Flag_Help)
- "display this help and exit",
- Option ['V'] ["version"] (NoArg Flag_Version)
- "output version information and exit",
- Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions)
- "output compatible interface file versions and exit",
- Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
- "output interface file version and exit",
- Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
- "set verbosity level",
- Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
- "use a separately-generated HTML contents page",
- Option [] ["gen-contents"] (NoArg Flag_GenContents)
- "generate an HTML contents from specified\ninterfaces",
- Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
- "use a separately-generated HTML index",
- Option [] ["gen-index"] (NoArg Flag_GenIndex)
- "generate an HTML index from specified\ninterfaces",
- Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
- "behave as if all modules have the\nignore-exports atribute",
- Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
- "behave as if MODULE has the hide attribute",
- Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")
- "behave as if MODULE has the show-extensions attribute",
- Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")
- "option to be forwarded to GHC",
- Option [] ["ghc-version"] (NoArg Flag_GhcVersion)
- "output GHC version in numeric format",
- Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath)
- "output path to GHC binary",
- Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir)
- "output GHC lib dir",
- Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
- Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
- "do not re-direct compilation output to a temporary directory",
- Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
- "generate html with newlines and indenting (for use with --html)",
- Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs)
- "print information about any undocumented entities"
- ]
-
-
-getUsage :: IO String
-getUsage = do
- prog <- getProgramName
- return $ usageInfo (usageHeader prog) (options False)
- where
- usageHeader :: String -> String
- usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
-
-
-parseHaddockOpts :: [String] -> IO ([Flag], [String])
-parseHaddockOpts params =
- case getOpt Permute (options True) params of
- (flags, args, []) -> return (flags, args)
- (_, _, errors) -> do
- usage <- getUsage
- throwE (concat errors ++ usage)
-
-
-optTitle :: [Flag] -> Maybe String
-optTitle flags =
- case [str | Flag_Heading str <- flags] of
- [] -> Nothing
- (t:_) -> Just t
-
-
-outputDir :: [Flag] -> FilePath
-outputDir flags =
- case [ path | Flag_OutputDir path <- flags ] of
- [] -> "."
- paths -> last paths
-
-
-optContentsUrl :: [Flag] -> Maybe String
-optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ]
-
-
-optIndexUrl :: [Flag] -> Maybe String
-optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]
-
-
-optCssFile :: [Flag] -> Maybe FilePath
-optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
-
-
-sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
-sourceUrls flags =
- (optLast [str | Flag_SourceBaseURL str <- flags]
- ,optLast [str | Flag_SourceModuleURL str <- flags]
- ,optLast [str | Flag_SourceEntityURL str <- flags]
- ,optLast [str | Flag_SourceLEntityURL str <- flags])
-
-
-wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
-wikiUrls flags =
- (optLast [str | Flag_WikiBaseURL str <- flags]
- ,optLast [str | Flag_WikiModuleURL str <- flags]
- ,optLast [str | Flag_WikiEntityURL str <- flags])
-
-
-optDumpInterfaceFile :: [Flag] -> Maybe FilePath
-optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
-
-
-optLaTeXStyle :: [Flag] -> Maybe String
-optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ]
-
-
-qualification :: [Flag] -> Either String QualOption
-qualification flags =
- case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
- [] -> Right OptNoQual
- ["none"] -> Right OptNoQual
- ["full"] -> Right OptFullQual
- ["local"] -> Right OptLocalQual
- ["relative"] -> Right OptRelativeQual
- ["aliased"] -> Right OptAliasedQual
- [arg] -> Left $ "unknown qualification type " ++ show arg
- _:_ -> Left "qualification option given multiple times"
-
-
-verbosity :: [Flag] -> Verbosity
-verbosity flags =
- case [ str | Flag_Verbosity str <- flags ] of
- [] -> normal
- x:_ -> case parseVerbosity x of
- Left e -> throwE e
- Right v -> v
-
-
-ghcFlags :: [Flag] -> [String]
-ghcFlags flags = [ option | Flag_OptGhc option <- flags ]
-
-
-readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]
-readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
- where
- parseIfaceOption :: String -> (DocPaths, FilePath)
- parseIfaceOption str =
- case break (==',') str of
- (fpath, ',':rest) ->
- case break (==',') rest of
- (src, ',':file) -> ((fpath, Just src), file)
- (file, _) -> ((fpath, Nothing), file)
- (file, _) -> (("", Nothing), file)
-
-
--- | Like 'listToMaybe' but returns the last element instead of the first.
-optLast :: [a] -> Maybe a
-optLast [] = Nothing
-optLast xs = Just (last xs)
diff --git a/src/Haddock/Parser.hs b/src/Haddock/Parser.hs
deleted file mode 100644
index ea4b7a3f..00000000
--- a/src/Haddock/Parser.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving
- , FlexibleInstances, UndecidableInstances
- , IncoherentInstances #-}
-{-# LANGUAGE LambdaCase #-}
--- |
--- Module : Haddock.Parser
--- Copyright : (c) Mateusz Kowalczyk 2013,
--- Simon Hengel 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
-
-module Haddock.Parser ( parseParas
- , parseString
- , parseIdent
- ) where
-
-import qualified Documentation.Haddock.Parser as P
-import DynFlags (DynFlags)
-import FastString (mkFastString)
-import Documentation.Haddock.Types
-import Lexer (mkPState, unP, ParseResult(POk))
-import Parser (parseIdentifier)
-import RdrName (RdrName)
-import SrcLoc (mkRealSrcLoc, unLoc)
-import StringBuffer (stringToStringBuffer)
-
-parseParas :: DynFlags -> String -> DocH mod RdrName
-parseParas d = P.overIdentifier (parseIdent d) . P.parseParas
-
-parseString :: DynFlags -> String -> DocH mod RdrName
-parseString d = P.overIdentifier (parseIdent d) . P.parseString
-
-parseIdent :: DynFlags -> String -> Maybe RdrName
-parseIdent dflags str0 =
- let buffer = stringToStringBuffer str0
- realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0
- pstate = mkPState dflags buffer realSrcLc
- in case unP parseIdentifier pstate of
- POk _ name -> Just (unLoc name)
- _ -> Nothing
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
deleted file mode 100644
index 85b3a592..00000000
--- a/src/Haddock/Types.hs
+++ /dev/null
@@ -1,552 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Types
--- Copyright : (c) Simon Marlow 2003-2006,
--- David Waern 2006-2009,
--- Mateusz Kowalczyk 2013
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskellorg
--- Stability : experimental
--- Portability : portable
---
--- Types that are commonly used through-out Haddock. Some of the most
--- important types are defined here, like 'Interface' and 'DocName'.
------------------------------------------------------------------------------
-module Haddock.Types (
- module Haddock.Types
- , HsDocString, LHsDocString
- , Fixity(..)
- , module Documentation.Haddock.Types
- ) where
-
-import Control.Exception
-import Control.Arrow hiding ((<+>))
-import Control.DeepSeq
-import Data.Typeable
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Documentation.Haddock.Types
-import BasicTypes (Fixity(..))
-import GHC hiding (NoLink)
-import DynFlags (ExtensionFlag, Language)
-import OccName
-import Outputable
-import Control.Applicative (Applicative(..))
-import Control.Monad (ap)
-
------------------------------------------------------------------------------
--- * Convenient synonyms
------------------------------------------------------------------------------
-
-
-type IfaceMap = Map Module Interface
-type InstIfaceMap = Map Module InstalledInterface -- TODO: rename
-type DocMap a = Map Name (Doc a)
-type ArgMap a = Map Name (Map Int (Doc a))
-type SubMap = Map Name [Name]
-type DeclMap = Map Name [LHsDecl Name]
-type InstMap = Map SrcSpan Name
-type FixMap = Map Name Fixity
-type SrcMap = Map PackageId FilePath
-type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources
-
-
------------------------------------------------------------------------------
--- * Interface
------------------------------------------------------------------------------
-
-
--- | 'Interface' holds all information used to render a single Haddock page.
--- It represents the /interface/ of a module. The core business of Haddock
--- lies in creating this structure. Note that the record contains some fields
--- that are only used to create the final record, and that are not used by the
--- backends.
-data Interface = Interface
- {
- -- | The module behind this interface.
- ifaceMod :: !Module
-
- -- | Original file name of the module.
- , ifaceOrigFilename :: !FilePath
-
- -- | Textual information about the module.
- , ifaceInfo :: !(HaddockModInfo Name)
-
- -- | Documentation header.
- , ifaceDoc :: !(Documentation Name)
-
- -- | Documentation header with cross-reference information.
- , ifaceRnDoc :: !(Documentation DocName)
-
- -- | Haddock options for this module (prune, ignore-exports, etc).
- , ifaceOptions :: ![DocOption]
-
- -- | Declarations originating from the module. Excludes declarations without
- -- names (instances and stand-alone documentation comments). Includes
- -- names of subordinate declarations mapped to their parent declarations.
- , ifaceDeclMap :: !(Map Name [LHsDecl Name])
-
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- , ifaceDocMap :: !(DocMap Name)
- , ifaceArgMap :: !(ArgMap Name)
-
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- , ifaceRnDocMap :: !(DocMap DocName)
- , ifaceRnArgMap :: !(ArgMap DocName)
-
- , ifaceSubMap :: !(Map Name [Name])
- , ifaceFixMap :: !(Map Name Fixity)
-
- , ifaceExportItems :: ![ExportItem Name]
- , ifaceRnExportItems :: ![ExportItem DocName]
-
- -- | All names exported by the module.
- , ifaceExports :: ![Name]
-
- -- | All \"visible\" names exported by the module.
- -- A visible name is a name that will show up in the documentation of the
- -- module.
- , ifaceVisibleExports :: ![Name]
-
- -- | Aliases of module imports as in @import A.B.C as C@.
- , ifaceModuleAliases :: !AliasMap
-
- -- | Instances exported by the module.
- , ifaceInstances :: ![ClsInst]
- , ifaceFamInstances :: ![FamInst]
-
- -- | The number of haddockable and haddocked items in the module, as a
- -- tuple. Haddockable items are the exports and the module itself.
- , ifaceHaddockCoverage :: !(Int, Int)
-
- -- | Warnings for things defined in this module.
- , ifaceWarningMap :: !WarningMap
- }
-
-type WarningMap = DocMap Name
-
-
--- | A subset of the fields of 'Interface' that we store in the interface
--- files.
-data InstalledInterface = InstalledInterface
- {
- -- | The module represented by this interface.
- instMod :: Module
-
- -- | Textual information about the module.
- , instInfo :: HaddockModInfo Name
-
- -- | Documentation of declarations originating from the module (including
- -- subordinates).
- , instDocMap :: DocMap Name
-
- , instArgMap :: ArgMap Name
-
- -- | All names exported by this module.
- , instExports :: [Name]
-
- -- | All \"visible\" names exported by the module.
- -- A visible name is a name that will show up in the documentation of the
- -- module.
- , instVisibleExports :: [Name]
-
- -- | Haddock options for this module (prune, ignore-exports, etc).
- , instOptions :: [DocOption]
-
- , instSubMap :: Map Name [Name]
- , instFixMap :: Map Name Fixity
- }
-
-
--- | Convert an 'Interface' to an 'InstalledInterface'
-toInstalledIface :: Interface -> InstalledInterface
-toInstalledIface interface = InstalledInterface
- { instMod = ifaceMod interface
- , instInfo = ifaceInfo interface
- , instDocMap = ifaceDocMap interface
- , instArgMap = ifaceArgMap interface
- , instExports = ifaceExports interface
- , instVisibleExports = ifaceVisibleExports interface
- , instOptions = ifaceOptions interface
- , instSubMap = ifaceSubMap interface
- , instFixMap = ifaceFixMap interface
- }
-
-
------------------------------------------------------------------------------
--- * Export items & declarations
------------------------------------------------------------------------------
-
-
-data ExportItem name
-
- -- | An exported declaration.
- = ExportDecl
- {
- -- | A declaration.
- expItemDecl :: !(LHsDecl name)
-
- -- | Maybe a doc comment, and possibly docs for arguments (if this
- -- decl is a function or type-synonym).
- , expItemMbDoc :: !(DocForDecl name)
-
- -- | Subordinate names, possibly with documentation.
- , expItemSubDocs :: ![(name, DocForDecl name)]
-
- -- | Instances relevant to this declaration, possibly with
- -- documentation.
- , expItemInstances :: ![DocInstance name]
-
- -- | Fixity decls relevant to this declaration (including subordinates).
- , expItemFixities :: ![(name, Fixity)]
-
- -- | Whether the ExportItem is from a TH splice or not, for generating
- -- the appropriate type of Source link.
- , expItemSpliced :: !Bool
- }
-
- -- | An exported entity for which we have no documentation (perhaps because it
- -- resides in another package).
- | ExportNoDecl
- { expItemName :: !name
-
- -- | Subordinate names.
- , expItemSubs :: ![name]
- }
-
- -- | A section heading.
- | ExportGroup
- {
- -- | Section level (1, 2, 3, ...).
- expItemSectionLevel :: !Int
-
- -- | Section id (for hyperlinks).
- , expItemSectionId :: !String
-
- -- | Section heading text.
- , expItemSectionText :: !(Doc name)
- }
-
- -- | Some documentation.
- | ExportDoc !(Doc name)
-
- -- | A cross-reference to another module.
- | ExportModule !Module
-
-data Documentation name = Documentation
- { documentationDoc :: Maybe (Doc name)
- , documentationWarning :: !(Maybe (Doc name))
- } deriving Functor
-
-
--- | Arguments and result are indexed by Int, zero-based from the left,
--- because that's the easiest to use when recursing over types.
-type FnArgsDoc name = Map Int (Doc name)
-type DocForDecl name = (Documentation name, FnArgsDoc name)
-
-
-noDocForDecl :: DocForDecl name
-noDocForDecl = (Documentation Nothing Nothing, Map.empty)
-
-
-unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name
-unrenameDocForDecl (doc, fnArgsDoc) =
- (fmap getName doc, (fmap . fmap) getName fnArgsDoc)
-
-
------------------------------------------------------------------------------
--- * Cross-referencing
------------------------------------------------------------------------------
-
-
--- | Type of environment used to cross-reference identifiers in the syntax.
-type LinkEnv = Map Name Module
-
-
--- | Extends 'Name' with cross-reference information.
-data DocName
- = Documented Name Module
- -- ^ This thing is part of the (existing or resulting)
- -- documentation. The 'Module' is the preferred place
- -- in the documentation to refer to.
- | Undocumented Name
- -- ^ This thing is not part of the (existing or resulting)
- -- documentation, as far as Haddock knows.
- deriving Eq
-
-
-instance NamedThing DocName where
- getName (Documented name _) = name
- getName (Undocumented name) = name
-
-
------------------------------------------------------------------------------
--- * Instances
------------------------------------------------------------------------------
-
--- | The three types of instances
-data InstType name
- = ClassInst [HsType name] -- ^ Context
- | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side)
- | DataInst (TyClDecl name) -- ^ Data constructors
-
-instance OutputableBndr a => Outputable (InstType a) where
- ppr (ClassInst a) = text "ClassInst" <+> ppr a
- ppr (TypeInst a) = text "TypeInst" <+> ppr a
- ppr (DataInst a) = text "DataInst" <+> ppr a
-
--- | An instance head that may have documentation.
-type DocInstance name = (InstHead name, Maybe (Doc name))
-
--- | The head of an instance. Consists of a class name, a list of kind
--- parameters, a list of type parameters and an instance type
-type InstHead name = (name, [HsType name], [HsType name], InstType name)
-
------------------------------------------------------------------------------
--- * Documentation comments
------------------------------------------------------------------------------
-
-
-type LDoc id = Located (Doc id)
-
-type Doc id = DocH (ModuleName, OccName) id
-
-instance (NFData a, NFData mod)
- => NFData (DocH mod a) where
- rnf doc = case doc of
- DocEmpty -> ()
- DocAppend a b -> a `deepseq` b `deepseq` ()
- DocString a -> a `deepseq` ()
- DocParagraph a -> a `deepseq` ()
- DocIdentifier a -> a `deepseq` ()
- DocIdentifierUnchecked a -> a `deepseq` ()
- DocModule a -> a `deepseq` ()
- DocWarning a -> a `deepseq` ()
- DocEmphasis a -> a `deepseq` ()
- DocBold a -> a `deepseq` ()
- DocMonospaced a -> a `deepseq` ()
- DocUnorderedList a -> a `deepseq` ()
- DocOrderedList a -> a `deepseq` ()
- DocDefList a -> a `deepseq` ()
- DocCodeBlock a -> a `deepseq` ()
- DocHyperlink a -> a `deepseq` ()
- DocPic a -> a `deepseq` ()
- DocAName a -> a `deepseq` ()
- DocProperty a -> a `deepseq` ()
- DocExamples a -> a `deepseq` ()
- DocHeader a -> a `deepseq` ()
-
-
-instance NFData Name
-instance NFData OccName
-instance NFData ModuleName
-
-instance NFData id => NFData (Header id) where
- rnf (Header a b) = a `deepseq` b `deepseq` ()
-
-instance NFData Hyperlink where
- rnf (Hyperlink a b) = a `deepseq` b `deepseq` ()
-
-instance NFData Picture where
- rnf (Picture a b) = a `deepseq` b `deepseq` ()
-
-instance NFData Example where
- rnf (Example a b) = a `deepseq` b `deepseq` ()
-
-
-exampleToString :: Example -> String
-exampleToString (Example expression result) =
- ">>> " ++ expression ++ "\n" ++ unlines result
-
-
-data DocMarkup id a = Markup
- { markupEmpty :: a
- , markupString :: String -> a
- , markupParagraph :: a -> a
- , markupAppend :: a -> a -> a
- , markupIdentifier :: id -> a
- , markupIdentifierUnchecked :: (ModuleName, OccName) -> a
- , markupModule :: String -> a
- , markupWarning :: a -> a
- , markupEmphasis :: a -> a
- , markupBold :: a -> a
- , markupMonospaced :: a -> a
- , markupUnorderedList :: [a] -> a
- , markupOrderedList :: [a] -> a
- , markupDefList :: [(a,a)] -> a
- , markupCodeBlock :: a -> a
- , markupHyperlink :: Hyperlink -> a
- , markupAName :: String -> a
- , markupPic :: Picture -> a
- , markupProperty :: String -> a
- , markupExample :: [Example] -> a
- , markupHeader :: Header a -> a
- }
-
-
-data HaddockModInfo name = HaddockModInfo
- { hmi_description :: Maybe (Doc name)
- , hmi_copyright :: Maybe String
- , hmi_license :: Maybe String
- , hmi_maintainer :: Maybe String
- , hmi_stability :: Maybe String
- , hmi_portability :: Maybe String
- , hmi_safety :: Maybe String
- , hmi_language :: Maybe Language
- , hmi_extensions :: [ExtensionFlag]
- }
-
-
-emptyHaddockModInfo :: HaddockModInfo a
-emptyHaddockModInfo = HaddockModInfo
- { hmi_description = Nothing
- , hmi_copyright = Nothing
- , hmi_license = Nothing
- , hmi_maintainer = Nothing
- , hmi_stability = Nothing
- , hmi_portability = Nothing
- , hmi_safety = Nothing
- , hmi_language = Nothing
- , hmi_extensions = []
- }
-
-
------------------------------------------------------------------------------
--- * Options
------------------------------------------------------------------------------
-
-
-{-! for DocOption derive: Binary !-}
--- | Source-level options for controlling the documentation.
-data DocOption
- = OptHide -- ^ This module should not appear in the docs.
- | OptPrune
- | OptIgnoreExports -- ^ Pretend everything is exported.
- | OptNotHome -- ^ Not the best place to get docs for things
- -- exported by this module.
- | OptShowExtensions -- ^ Render enabled extensions for this module.
- deriving (Eq, Show)
-
-
--- | Option controlling how to qualify names
-data QualOption
- = OptNoQual -- ^ Never qualify any names.
- | OptFullQual -- ^ Qualify all names fully.
- | OptLocalQual -- ^ Qualify all imported names fully.
- | OptRelativeQual -- ^ Like local, but strip module prefix
- -- from modules in the same hierarchy.
- | OptAliasedQual -- ^ Uses aliases of module names
- -- as suggested by module import renamings.
- -- However, we are unfortunately not able
- -- to maintain the original qualifications.
- -- Image a re-export of a whole module,
- -- how could the re-exported identifiers be qualified?
-
-type AliasMap = Map Module ModuleName
-
-data Qualification
- = NoQual
- | FullQual
- | LocalQual Module
- | RelativeQual Module
- | AliasedQual AliasMap Module
- -- ^ @Module@ contains the current module.
- -- This way we can distinguish imported and local identifiers.
-
-makeContentsQual :: QualOption -> Qualification
-makeContentsQual qual =
- case qual of
- OptNoQual -> NoQual
- _ -> FullQual
-
-makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification
-makeModuleQual qual aliases mdl =
- case qual of
- OptLocalQual -> LocalQual mdl
- OptRelativeQual -> RelativeQual mdl
- OptAliasedQual -> AliasedQual aliases mdl
- OptFullQual -> FullQual
- OptNoQual -> NoQual
-
-
------------------------------------------------------------------------------
--- * Error handling
------------------------------------------------------------------------------
-
-
--- A monad which collects error messages, locally defined to avoid a dep on mtl
-
-
-type ErrMsg = String
-newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) }
-
-
-instance Functor ErrMsgM where
- fmap f (Writer (a, msgs)) = Writer (f a, msgs)
-
-instance Applicative ErrMsgM where
- pure = return
- (<*>) = ap
-
-instance Monad ErrMsgM where
- return a = Writer (a, [])
- m >>= k = Writer $ let
- (a, w) = runWriter m
- (b, w') = runWriter (k a)
- in (b, w ++ w')
-
-
-tell :: [ErrMsg] -> ErrMsgM ()
-tell w = Writer ((), w)
-
-
--- Exceptions
-
-
--- | Haddock's own exception type.
-data HaddockException = HaddockException String deriving Typeable
-
-
-instance Show HaddockException where
- show (HaddockException str) = str
-
-
-throwE :: String -> a
-instance Exception HaddockException
-throwE str = throw (HaddockException str)
-
-
--- In "Haddock.Interface.Create", we need to gather
--- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does,
--- but we can't just use @GhcT ErrMsgM@ because GhcT requires the
--- transformed monad to be MonadIO.
-newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) }
---instance MonadIO ErrMsgGhc where
--- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO
---er, implementing GhcMonad involves annoying ExceptionMonad and
---WarnLogMonad classes, so don't bother.
-liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a
-liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[]))
-liftErrMsg :: ErrMsgM a -> ErrMsgGhc a
-liftErrMsg = WriterGhc . return . runWriter
--- for now, use (liftErrMsg . tell) for this
---tell :: [ErrMsg] -> ErrMsgGhc ()
---tell msgs = WriterGhc $ return ( (), msgs )
-
-
-instance Functor ErrMsgGhc where
- fmap f (WriterGhc x) = WriterGhc (fmap (first f) x)
-
-instance Applicative ErrMsgGhc where
- pure = return
- (<*>) = ap
-
-instance Monad ErrMsgGhc where
- return a = WriterGhc (return (a, []))
- m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) ->
- fmap (second (msgs1 ++)) (runWriterGhc (k a))
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
deleted file mode 100644
index ee7bfd0a..00000000
--- a/src/Haddock/Utils.hs
+++ /dev/null
@@ -1,480 +0,0 @@
-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Utils
--- Copyright : (c) The University of Glasgow 2001-2002,
--- Simon Marlow 2003-2006,
--- David Waern 2006-2009
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Utils (
-
- -- * Misc utilities
- restrictTo, emptyHsQTvs,
- toDescription, toInstalledDescription,
-
- -- * Filename utilities
- moduleHtmlFile, moduleHtmlFile',
- contentsHtmlFile, indexHtmlFile,
- frameIndexHtmlFile,
- moduleIndexFrameName, mainFrameName, synopsisFrameName,
- subIndexHtmlFile,
- jsFile, framesFile,
-
- -- * Anchor and URL utilities
- moduleNameUrl, moduleNameUrl', moduleUrl,
- nameAnchorId,
- makeAnchorId,
-
- -- * Miscellaneous utilities
- getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
-
- -- * HTML cross reference mapping
- html_xrefs_ref, html_xrefs_ref',
-
- -- * Doc markup
- markup,
- idMarkup,
-
- -- * List utilities
- replace,
- spanWith,
-
- -- * MTL stuff
- MonadIO(..),
-
- -- * Logging
- parseVerbosity,
- out,
-
- -- * System tools
- getProcessID
- ) where
-
-
-import Haddock.Types
-import Haddock.GhcUtils
-
-import GHC
-import Name
-
-import Control.Monad ( liftM )
-import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr )
-import Numeric ( showIntAtBase )
-import Data.Map ( Map )
-import qualified Data.Map as Map hiding ( Map )
-import Data.IORef ( IORef, newIORef, readIORef )
-import Data.List ( isSuffixOf )
-import Data.Maybe ( mapMaybe )
-import System.Environment ( getProgName )
-import System.Exit
-import System.IO ( hPutStr, stderr )
-import System.IO.Unsafe ( unsafePerformIO )
-import qualified System.FilePath.Posix as HtmlPath
-import Distribution.Verbosity
-import Distribution.ReadE
-
-#ifndef mingw32_HOST_OS
-import qualified System.Posix.Internals
-#endif
-
-import MonadUtils ( MonadIO(..) )
-
-
---------------------------------------------------------------------------------
--- * Logging
---------------------------------------------------------------------------------
-
-
-parseVerbosity :: String -> Either String Verbosity
-parseVerbosity = runReadE flagToVerbosity
-
-
--- | Print a message to stdout, if it is not too verbose
-out :: MonadIO m
- => Verbosity -- ^ program verbosity
- -> Verbosity -- ^ message verbosity
- -> String -> m ()
-out progVerbosity msgVerbosity msg
- | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg
- | otherwise = return ()
-
-
---------------------------------------------------------------------------------
--- * Some Utilities
---------------------------------------------------------------------------------
-
-
--- | Extract a module's short description.
-toDescription :: Interface -> Maybe (Doc Name)
-toDescription = hmi_description . ifaceInfo
-
-
--- | Extract a module's short description.
-toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)
-toInstalledDescription = hmi_description . instInfo
-
-
---------------------------------------------------------------------------------
--- * Making abstract declarations
---------------------------------------------------------------------------------
-
-
-restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name
-restrictTo names (L loc decl) = L loc $ case decl of
- TyClD d | isDataDecl d ->
- TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) })
- TyClD d | isClassDecl d ->
- TyClD (d { tcdSigs = restrictDecls names (tcdSigs d),
- tcdATs = restrictATs names (tcdATs d) })
- _ -> decl
-
-restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name
-restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons })
- | DataType <- new_or_data
- = defn { dd_cons = restrictCons names cons }
- | otherwise -- Newtype
- = case restrictCons names cons of
- [] -> defn { dd_ND = DataType, dd_cons = [] }
- [con] -> defn { dd_cons = [con] }
- _ -> error "Should not happen"
-
-restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name]
-restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
- where
- keep d | unLoc (con_name d) `elem` names =
- case con_details d of
- PrefixCon _ -> Just d
- RecCon fields
- | all field_avail fields -> Just d
- | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })
- -- if we have *all* the field names available, then
- -- keep the record declaration. Otherwise degrade to
- -- a constructor declaration. This isn't quite right, but
- -- it's the best we can do.
- InfixCon _ _ -> Just d
- where
- field_avail (ConDeclField n _ _) = unLoc n `elem` names
- field_types flds = [ t | ConDeclField _ t _ <- flds ]
-
- keep _ = Nothing
-
-
-restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]
-restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
-
-
-restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name]
-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
-
-emptyHsQTvs :: LHsTyVarBndrs Name
--- This function is here, rather than in HsTypes, because it *renamed*, but
--- does not necessarily have all the rigt kind variables. It is used
--- in Haddock just for printing, so it doesn't matter
-emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] }
-
-
---------------------------------------------------------------------------------
--- * Filename mangling functions stolen from s main/DriverUtil.lhs.
---------------------------------------------------------------------------------
-
-
-baseName :: ModuleName -> FilePath
-baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
-
-
-moduleHtmlFile :: Module -> FilePath
-moduleHtmlFile mdl =
- case Map.lookup mdl html_xrefs of
- Nothing -> baseName mdl' ++ ".html"
- Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"]
- where
- mdl' = moduleName mdl
-
-
-moduleHtmlFile' :: ModuleName -> FilePath
-moduleHtmlFile' mdl =
- case Map.lookup mdl html_xrefs' of
- Nothing -> baseName mdl ++ ".html"
- Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]
-
-
-contentsHtmlFile, indexHtmlFile :: String
-contentsHtmlFile = "index.html"
-indexHtmlFile = "doc-index.html"
-
-
--- | The name of the module index file to be displayed inside a frame.
--- Modules are display in full, but without indentation. Clicking opens in
--- the main window.
-frameIndexHtmlFile :: String
-frameIndexHtmlFile = "index-frames.html"
-
-
-moduleIndexFrameName, mainFrameName, synopsisFrameName :: String
-moduleIndexFrameName = "modules"
-mainFrameName = "main"
-synopsisFrameName = "synopsis"
-
-
-subIndexHtmlFile :: String -> String
-subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html"
- where b | all isAlpha ls = ls
- | otherwise = concatMap (show . ord) ls
-
-
--------------------------------------------------------------------------------
--- * Anchor and URL utilities
---
--- NB: Anchor IDs, used as the destination of a link within a document must
--- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's
--- various needs and compatibility constraints, means these IDs have to match:
--- [A-Za-z][A-Za-z0-9:_.-]*
--- Such IDs do not need to be escaped in any way when used as the fragment part
--- of a URL. Indeed, %-escaping them can lead to compatibility issues as it
--- isn't clear if such fragment identifiers should, or should not be unescaped
--- before being matched with IDs in the target document.
--------------------------------------------------------------------------------
-
-
-moduleUrl :: Module -> String
-moduleUrl = moduleHtmlFile
-
-
-moduleNameUrl :: Module -> OccName -> String
-moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n
-
-
-moduleNameUrl' :: ModuleName -> OccName -> String
-moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n
-
-
-nameAnchorId :: OccName -> String
-nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)
- where prefix | isValOcc name = 'v'
- | otherwise = 't'
-
-
--- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is
--- identity preserving.
-makeAnchorId :: String -> String
-makeAnchorId [] = []
-makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
- where
- escape p c | p c = [c]
- | otherwise = '-' : show (ord c) ++ "-"
- isLegal ':' = True
- isLegal '_' = True
- isLegal '.' = True
- isLegal c = isAscii c && isAlphaNum c
- -- NB: '-' is legal in IDs, but we use it as the escape char
-
-
--------------------------------------------------------------------------------
--- * Files we need to copy from our $libdir
--------------------------------------------------------------------------------
-
-
-jsFile, framesFile :: String
-jsFile = "haddock-util.js"
-framesFile = "frames.html"
-
-
--------------------------------------------------------------------------------
--- * Misc.
--------------------------------------------------------------------------------
-
-
-getProgramName :: IO String
-getProgramName = liftM (`withoutSuffix` ".bin") getProgName
- where str `withoutSuffix` suff
- | suff `isSuffixOf` str = take (length str - length suff) str
- | otherwise = str
-
-
-bye :: String -> IO a
-bye s = putStr s >> exitSuccess
-
-
-die :: String -> IO a
-die s = hPutStr stderr s >> exitWith (ExitFailure 1)
-
-
-dieMsg :: String -> IO a
-dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)
-
-
-noDieMsg :: String -> IO ()
-noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s)
-
-
-mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)]
-mapSnd _ [] = []
-mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
-
-
-mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
-mapMaybeM _ Nothing = return Nothing
-mapMaybeM f (Just a) = liftM Just (f a)
-
-
-escapeStr :: String -> String
-escapeStr = escapeURIString isUnreserved
-
-
--- Following few functions are copy'n'pasted from Network.URI module
--- to avoid depending on the network lib, since doing so gives a
--- circular build dependency between haddock and network
--- (at least if you want to build network with haddock docs)
-escapeURIChar :: (Char -> Bool) -> Char -> String
-escapeURIChar p c
- | p c = [c]
- | otherwise = '%' : myShowHex (ord c) ""
- where
- myShowHex :: Int -> ShowS
- myShowHex n r = case showIntAtBase 16 toChrHex n r of
- [] -> "00"
- [a] -> ['0',a]
- cs -> cs
- toChrHex d
- | d < 10 = chr (ord '0' + fromIntegral d)
- | otherwise = chr (ord 'A' + fromIntegral (d - 10))
-
-
-escapeURIString :: (Char -> Bool) -> String -> String
-escapeURIString = concatMap . escapeURIChar
-
-
-isUnreserved :: Char -> Bool
-isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")
-
-
-isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool
-isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
-isDigitChar c = c >= '0' && c <= '9'
-isAlphaNumChar c = isAlphaChar c || isDigitChar c
-
-
------------------------------------------------------------------------------
--- * HTML cross references
---
--- For each module, we need to know where its HTML documentation lives
--- so that we can point hyperlinks to it. It is extremely
--- inconvenient to plumb this information to all the places that need
--- it (basically every function in HaddockHtml), and furthermore the
--- mapping is constant for any single run of Haddock. So for the time
--- being I'm going to use a write-once global variable.
------------------------------------------------------------------------------
-
-
-{-# NOINLINE html_xrefs_ref #-}
-html_xrefs_ref :: IORef (Map Module FilePath)
-html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
-
-
-{-# NOINLINE html_xrefs_ref' #-}
-html_xrefs_ref' :: IORef (Map ModuleName FilePath)
-html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map"))
-
-
-{-# NOINLINE html_xrefs #-}
-html_xrefs :: Map Module FilePath
-html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
-
-
-{-# NOINLINE html_xrefs' #-}
-html_xrefs' :: Map ModuleName FilePath
-html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref')
-
-
------------------------------------------------------------------------------
--- * List utils
------------------------------------------------------------------------------
-
-
-replace :: Eq a => a -> a -> [a] -> [a]
-replace a b = map (\x -> if x == a then b else x)
-
-
-spanWith :: (a -> Maybe b) -> [a] -> ([b],[a])
-spanWith _ [] = ([],[])
-spanWith p xs@(a:as)
- | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs)
- | otherwise = ([],xs)
-
-
------------------------------------------------------------------------------
--- * Put here temporarily
------------------------------------------------------------------------------
-
-
-markup :: DocMarkup id a -> Doc id -> a
-markup m DocEmpty = markupEmpty m
-markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s) = markupString m s
-markup m (DocParagraph d) = markupParagraph m (markup m d)
-markup m (DocIdentifier x) = markupIdentifier m x
-markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
-markup m (DocModule mod0) = markupModule m mod0
-markup m (DocWarning d) = markupWarning m (markup m d)
-markup m (DocEmphasis d) = markupEmphasis m (markup m d)
-markup m (DocBold d) = markupBold m (markup m d)
-markup m (DocMonospaced d) = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (DocHyperlink l) = markupHyperlink m l
-markup m (DocAName ref) = markupAName m ref
-markup m (DocPic img) = markupPic m img
-markup m (DocProperty p) = markupProperty m p
-markup m (DocExamples e) = markupExample m e
-markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t))
-
-
-markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
-markupPair m (a,b) = (markup m a, markup m b)
-
-
--- | The identity markup
-idMarkup :: DocMarkup a (Doc a)
-idMarkup = Markup {
- markupEmpty = DocEmpty,
- markupString = DocString,
- markupParagraph = DocParagraph,
- markupAppend = DocAppend,
- markupIdentifier = DocIdentifier,
- markupIdentifierUnchecked = DocIdentifierUnchecked,
- markupModule = DocModule,
- markupWarning = DocWarning,
- markupEmphasis = DocEmphasis,
- markupBold = DocBold,
- markupMonospaced = DocMonospaced,
- markupUnorderedList = DocUnorderedList,
- markupOrderedList = DocOrderedList,
- markupDefList = DocDefList,
- markupCodeBlock = DocCodeBlock,
- markupHyperlink = DocHyperlink,
- markupAName = DocAName,
- markupPic = DocPic,
- markupProperty = DocProperty,
- markupExample = DocExamples,
- markupHeader = DocHeader
- }
-
-
------------------------------------------------------------------------------
--- * System tools
------------------------------------------------------------------------------
-
-
-#ifdef mingw32_HOST_OS
-foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
-#else
-getProcessID :: IO Int
-getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid
-#endif
diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs
deleted file mode 100644
index 2ef3a257..00000000
--- a/src/Haddock/Version.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.Version
--- Copyright : (c) Simon Marlow 2003
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
------------------------------------------------------------------------------
-module Haddock.Version (
- projectName, projectVersion, projectUrl
-) where
-
-#ifdef IN_GHC_TREE
-import Paths_haddock ( version )
-#else
-import Paths_haddock_api ( version )
-#endif
-import Data.Version ( showVersion )
-
-projectName :: String
-projectName = "Haddock"
-
-projectUrl :: String
-projectUrl = "http://www.haskell.org/haddock/"
-
-projectVersion :: String
-projectVersion = showVersion version
diff --git a/src/haddock.sh b/src/haddock.sh
deleted file mode 100644
index f1ad0191..00000000
--- a/src/haddock.sh
+++ /dev/null
@@ -1,7 +0,0 @@
-# Mini-driver for Haddock
-
-# needs the following variables:
-# HADDOCKLIB
-# HADDOCKBIN
-
-$HADDOCKBIN --lib $HADDOCKLIB ${1+"$@"}
--
cgit v1.2.3