diff options
Diffstat (limited to 'src')
30 files changed, 0 insertions, 9851 deletions
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+"$@"} |