haddock 2.26.0 → 2.27.0
raw patch · 75 files changed
+1557/−856 lines, 75 filesdep ~basedep ~ghcdep ~haddock-api
Dependency ranges changed: base, ghc, haddock-api
Files
- README.md +3/−3
- doc/intro.rst +27/−66
- doc/invoking.rst +11/−0
- doc/markup.rst +22/−16
- haddock-api/src/Documentation/Haddock.hs +1/−3
- haddock-api/src/Haddock.hs +125/−44
- haddock-api/src/Haddock/Backends/Hoogle.hs +8/−9
- haddock-api/src/Haddock/Backends/Hyperlinker.hs +14/−10
- haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +14/−9
- haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +15/−7
- haddock-api/src/Haddock/Backends/LaTeX.hs +23/−18
- haddock-api/src/Haddock/Backends/Xhtml.hs +203/−70
- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +24/−22
- haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +7/−4
- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +4/−3
- haddock-api/src/Haddock/Backends/Xhtml/Meta.hs +1/−1
- haddock-api/src/Haddock/Backends/Xhtml/Themes.hs +4/−3
- haddock-api/src/Haddock/Backends/Xhtml/Types.hs +11/−0
- haddock-api/src/Haddock/Convert.hs +26/−26
- haddock-api/src/Haddock/GhcUtils.hs +20/−22
- haddock-api/src/Haddock/Interface.hs +64/−27
- haddock-api/src/Haddock/Interface/AttachInstances.hs +2/−3
- haddock-api/src/Haddock/Interface/Create.hs +78/−61
- haddock-api/src/Haddock/Interface/Json.hs +3/−1
- haddock-api/src/Haddock/Interface/LexParseRn.hs +14/−5
- haddock-api/src/Haddock/Interface/Rename.hs +15/−13
- haddock-api/src/Haddock/Interface/Specialize.hs +10/−11
- haddock-api/src/Haddock/InterfaceFile.hs +83/−157
- haddock-api/src/Haddock/Options.hs +26/−5
- haddock-api/src/Haddock/Parser.hs +1/−2
- haddock-api/src/Haddock/Types.hs +21/−18
- haddock-api/src/Haddock/Utils/Json.hs +355/−22
- haddock-api/src/Haddock/Utils/Json/Parser.hs +102/−0
- haddock-api/src/Haddock/Utils/Json/Types.hs +42/−0
- haddock-library/src/CompatPrelude.hs +2/−1
- haddock-library/src/Documentation/Haddock/Markup.hs +1/−1
- haddock-library/src/Documentation/Haddock/Parser.hs +20/−6
- haddock-library/src/Documentation/Haddock/Parser/Identifier.hs +2/−3
- haddock-library/src/Documentation/Haddock/Parser/Monad.hs +2/−3
- haddock-library/src/Documentation/Haddock/Types.hs +7/−6
- haddock.cabal +10/−6
- hoogle-test/ref/Bug873/test.txt +0/−27
- hoogle-test/src/Bug806/Bug806.hs +0/−1
- hoogle-test/src/Bug873/Bug873.hs +0/−6
- html-test/ref/Bug1004.html +6/−6
- html-test/ref/Bug313.html +6/−6
- html-test/ref/Bug574.html +1/−1
- html-test/ref/BundledPatterns.html +5/−5
- html-test/ref/BundledPatterns2.html +5/−5
- html-test/ref/ConstructorArgs.html +1/−1
- html-test/ref/FunArgs.html +3/−1
- html-test/ref/Identifiers.html +5/−5
- html-test/ref/Instances.html +25/−25
- html-test/ref/Nesting.html +4/−4
- html-test/ref/Test.html +2/−2
- html-test/ref/TypeOperators.html +8/−2
- html-test/src/Bug308.hs +1/−1
- html-test/src/Bug745.hs +1/−1
- html-test/src/BundledPatterns2.hs +1/−2
- html-test/src/ConstructorArgs.hs +1/−1
- html-test/src/DefaultAssociatedTypes.hs +1/−1
- html-test/src/GadtConstructorArgs.hs +1/−1
- html-test/src/Operators.hs +1/−1
- html-test/src/QuasiQuote.hs +1/−1
- hypsrc-test/Main.hs +1/−1
- hypsrc-test/ref/src/Classes.html +10/−7
- hypsrc-test/ref/src/Constructors.html +1/−0
- hypsrc-test/ref/src/LinkingIdentifiers.html +1/−1
- hypsrc-test/ref/src/Operators.html +18/−38
- hypsrc-test/ref/src/Quasiquoter.html +5/−1
- hypsrc-test/ref/src/Records.html +8/−8
- hypsrc-test/ref/src/UsingQuasiquotes.html +8/−2
- hypsrc-test/src/LinkingIdentifiers.hs +1/−1
- hypsrc-test/src/Operators.hs +1/−3
- latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs +1/−1
README.md view
@@ -2,7 +2,7 @@ Haddock is the standard tool for generating documentation from Haskell code. Full documentation about Haddock itself can be found in the `doc/` subdirectory,-in [reStructedText format][ReST] format.+in [reStructuredText][reST] format. ## Project overview @@ -29,6 +29,6 @@ [CI badge]: https://github.com/haskell/haddock/actions/workflows/ci.yml/badge.svg [Hackage page]: https://hackage.haskell.org/package/haddock [Hackage badge]: https://img.shields.io/hackage/v/haddock.svg-[ReST]: http://www.sphinx-doc.org/en/stable/rest.html+[reST]: https://www.sphinx-doc.org/en/master/usage/restructuredtext/index.html [Documentation.Haddock]: http://hackage.haskell.org/package/haddock-api/docs/Documentation-Haddock.html-[cabal v2]: http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html+[cabal v2]: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html
doc/intro.rst view
@@ -25,7 +25,7 @@ The easier it is to write documentation, the more likely the programmer is to do it. Haddock therefore uses lightweight markup in its annotations, taking several ideas from- `IDoc <http://www.cse.unsw.edu.au/~chak/haskell/idoc/>`__. In fact,+ `IDoc <https://web.archive.org/web/20180621053227/http://www.cse.unsw.edu.au/~chak/haskell/idoc/>`__. In fact, Haddock can understand IDoc-annotated source code. - The documentation should not expose any of the structure of the@@ -59,8 +59,8 @@ Obtaining Haddock ----------------- -Distributions (source & binary) of Haddock can be obtained from its `web-site <http://www.haskell.org/haddock/>`__.+Haddock is distributed with GHC distributions, and will automatically be provided if you use +`ghcup <https://www.haskell.org/ghcup>`__, for instance. Up-to-date sources can also be obtained from our public GitHub repository. The Haddock sources are at@@ -72,77 +72,38 @@ The following license covers this documentation, and the Haddock source code, except where otherwise indicated. - Copyright 2002-2010, Simon Marlow. All rights reserved.+ Copyright (c) 2002-2010, Simon Marlow+ All rights reserved. Redistribution and use in source and binary forms, with or without- modification, are permitted provided that the following conditions- are met:+ modification, are permitted provided that the following conditions are+ met: - - Redistributions of source code must retain the above copyright+ 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - - Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in- the documentation and/or other materials provided with the+ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution. - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR- PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR- BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Contributors ------------ -Haddock was originally written by Simon Marlow. Since it is an open-source project, many people have contributed to its development over the-years. Below is a list of contributors in alphabetical order that we-hope is somewhat complete. If you think you are missing from this list,-please contact us.--- Ashley Yakeley-- Benjamin Franksen-- Brett Letner-- Clemens Fruhwirth-- Conal Elliott-- David Waern-- Duncan Coutts-- George Pollard-- George Russel-- Hal Daume-- Ian Lynagh-- Isaac Dupree-- Joachim Breitner-- Krasimir Angelov-- Lennart Augustsson-- Luke Plant-- Malcolm Wallace-- Manuel Chakravarty-- Marcin Szamotulski-- Mark Lentczner-- Mark Shields-- Mateusz Kowalczyk-- Mike Thomas-- Neil Mitchell-- Oliver Brown-- Roman Cheplyaka-- Ross Paterson-- Sigbjorn Finne-- Simon Hengel-- Simon Marlow-- Simon Peyton-Jones-- Stefan O'Rear-- Sven Panne-- Thomas Schilling-- Wolfgang Jeltsch-- Yitzchak Gale+A list of contributors to the project can be seen at+``https://github.com/haskell/haddock/graphs/contributors``. Acknowledgements ----------------@@ -150,11 +111,11 @@ Several documentation systems provided the inspiration for Haddock, most notably: -- `IDoc <http://www.cse.unsw.edu.au/~chak/haskell/idoc/>`__+- `IDoc <https://web.archive.org/web/20180621053227/http://www.cse.unsw.edu.au/~chak/haskell/idoc/>`__ -- `HDoc <http://www.fmi.uni-passau.de/~groessli/hdoc/>`__+- `HDoc <https://mail.haskell.org/pipermail/haskelldoc/2001-April/000067.html>`__ -- `Doxygen <http://www.stack.nl/~dimitri/doxygen/>`__+- `Doxygen <https://www.doxygen.nl/index.html>`__ and probably several others I've forgotten.
doc/invoking.rst view
@@ -58,6 +58,7 @@ --read-interface=<docpath>,<file> -i <docpath>,<srcpath>,<file> --read-interface=<docpath>,<srcpath>,<file>+ -i <docpath>,<srcpath>,<visibility>,<file> Read the interface file in file, which must have been produced by running Haddock with the :option:`--dump-interface` option. The interface@@ -77,6 +78,9 @@ hyperlinks but within sources rendered with :option:`--hyperlinked-source` option. + If visibility is set to `hidden`, modules from that interface file will+ not be listed in haddock generated content file.+ Multiple :option:`--read-interface` options may be given. .. option:: -D <file>@@ -222,6 +226,13 @@ Reserved for future use (output documentation in DocBook XML format).++.. option:: --base-url=<url>++ Base url for static assets (eg. css, javascript, json files etc.).+ When present, static assets are not copied. This option is useful+ when creating documentation for multiple packages, it allows to have+ a single copy of static assets served from the given url. .. option:: --source-base=<url> --source-module=<url>
doc/markup.rst view
@@ -178,7 +178,7 @@ Most instances are top-level, so can be documented as in :ref:`top-level-declaration`. The exception to this is instance that are come from a ``deriving`` clause on a datatype declaration. These can-the documented like this: ::+be documented like this: :: data D a = L a | M deriving ( Eq -- ^ @since 4.5@@ -950,25 +950,31 @@ -- | A prefix operator @'(++)'@ and an infix identifier @'`elem`'@. -Emphasis, Bold and Monospaced Text+Emphasis, Bold and Monospaced styled Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Emphasis may be added by surrounding text with ``/.../``. Other markup-is valid inside emphasis. To have a forward slash inside of emphasis,-just escape it: ``/fo\/o/``+Text can be emphasized, made bold (strong) or monospaced (typewriter font) +by surrounding it with slashes, double-underscores or at-symbols: :: -Bold (strong) text is indicated by surrounding it with ``__...__``.-Other markup is valid inside bold. For example, ``__/foo/__`` will make-the emphasised text ``foo`` bold. You don't have to escape a single-underscore if you need it bold:-``__This_text_with_underscores_is_bold__``.+ -- | This is /emphasized text/, __bold text__ and @monospaced text@. -Monospaced (or typewriter) text is indicated by surrounding it with-``@...@``. Other markup is valid inside a monospaced span: for example-``@'f' a b@`` will hyperlink the identifier ``f`` inside the code-fragment, but ``@__FILE__@`` will render ``FILE`` in bold with no-underscores, which may not be what you had in mind.+Note that those styled texts must be kept on the same line: :: + -- | Styles /do not work+ -- | when continuing on the next line/++Other markup is valid inside emphasized, bold and monospaced text.++Frequent special cases: ++* To have a forward slash inside of emphasis, just escape it: ``/fo\/o/``.+* There's no need to escape a single underscore if you need it+ bold: ``__This_text_with_underscores_is_bold__``.+* ``@'f' a b@`` will hyperlink the identifier ``f`` inside the code+ fragment.+* ``@__FILE__@`` will render ``FILE`` in bold with no underscores, + which may not be what you had in mind.+ Linking to Modules ~~~~~~~~~~~~~~~~~~ @@ -1120,7 +1126,7 @@ The link text is used as a description for the URL if the output format supports it.-+ Images ~~~~~~
haddock-api/src/Documentation/Haddock.hs view
@@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : portable ----- The Haddock API: A rudimentory, highly experimental API exposing some of+-- The Haddock API: A rudimentary, highly experimental API exposing some of -- the internals of Haddock. Don't expect it to be stable. ----------------------------------------------------------------------------- module Documentation.Haddock (@@ -52,9 +52,7 @@ -- * Interface files InterfaceFile(..), readInterfaceFile,- nameCacheFromGhc, freshNameCache,- NameCacheAccessor, -- * Flags and options Flag(..),
haddock-api/src/Haddock.hs view
@@ -1,6 +1,11 @@-{-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock@@ -46,7 +51,7 @@ import Data.Bifunctor (second) import Data.Foldable (forM_, foldl') import Data.Traversable (for)-import Data.List (isPrefixOf)+import Data.List (find, isPrefixOf, nub) import Control.Exception import Data.Maybe import Data.IORef@@ -69,8 +74,11 @@ import GHC hiding (verbosity) import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity)+import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Env import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Types.Name.Cache import GHC.Unit import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString@@ -188,17 +196,24 @@ unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do- mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks- forM_ mIfaceFile $ \(_, ifaceFile) -> do- putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)+ name_cache <- freshNameCache+ mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), Visible, path)] noChecks+ forM_ mIfaceFile $ \(_,_,_, ifaceFile) -> do+ putMsg logger $ renderJson (jsonInterfaceFile ifaceFile) if not (null files) then do (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files+ let packageInfo = PackageInfo { piPackageName =+ fromMaybe (PackageName mempty) (optPackageName flags)+ , piPackageVersion =+ fromMaybe (makeVersion []) (optPackageVersion flags)+ } -- Dump an "interface file" (.haddock file), if requested. forM_ (optDumpInterfaceFile flags) $ \path -> liftIO $ do writeInterfaceFile path InterfaceFile { ifInstalledIfaces = map toInstalledIface ifaces+ , ifPackageInfo = packageInfo , ifLinkEnv = homeLinks } @@ -210,7 +225,8 @@ throwE "No input file(s)." -- Get packages supplied with --read-interface.- packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks+ name_cache <- liftIO $ freshNameCache+ packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages []@@ -249,42 +265,64 @@ readPackagesAndProcessModules :: [Flag] -> [String]- -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)+ -> Ghc ([(DocPaths, Visibility, FilePath, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags- packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks+ name_cache <- hsc_NC <$> getSession+ packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock.- let ifaceFiles = map snd packages+ let ifaceFiles = map (\(_, _, _, ifaceFile) -> ifaceFile) packages (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles return (packages, ifaces, homeLinks) renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption- -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()+ -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do- updateHTMLXRefs pkgs+ updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) ->+ ( case baseUrl flags of+ Nothing -> fst docPath+ Just url -> url </> packageName (ifUnitId ifaceFile)+ , ifaceFile)) pkgs) let- ifaceFiles = map snd pkgs- installedIfaces = concatMap ifInstalledIfaces ifaceFiles+ installedIfaces =+ map+ (\(_, showModules, ifaceFilePath, ifaceFile)+ -> (ifaceFilePath, mkPackageInterfaces showModules ifaceFile))+ pkgs extSrcMap = Map.fromList $ do- ((_, Just path), ifile) <- pkgs+ ((_, Just path), _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap+ where+ -- get package name from unit-id+ packageName :: Unit -> String+ packageName unit =+ case lookupUnit unit_state unit of+ Nothing -> show unit+ Just pkg -> unitPackageNameString pkg -- | Render the interfaces with whatever backend is specified in the flags. render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]- -> [InstalledInterface] -> Map Module FilePath -> IO ()-render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do+ -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO ()+render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = do let+ packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty)+ $ optPackageName flags+ , piPackageVersion = fromMaybe (makeVersion [])+ $ optPackageVersion flags+ }+ title = fromMaybe "" (optTitle flags) unicode = Flag_UseUnicode `elem` flags pretty = Flag_PrettyHtml `elem` flags opt_wiki_urls = wikiUrls flags+ opt_base_url = baseUrl flags opt_contents_url = optContentsUrl flags opt_index_url = optIndexUrl flags odir = outputDir flags@@ -294,13 +332,37 @@ dflags' | unicode = gopt_set dflags Opt_PrintUnicodeSyntax | otherwise = dflags+ logger = setLogFlags log' (initLogFlags dflags') 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 ]+ -- /All/ interfaces including external package modules, grouped by+ -- interface file (package).+ allPackages :: [PackageInterfaces]+ allPackages = [PackageInterfaces+ { piPackageInfo = packageInfo+ , piVisibility = Visible+ , piInstalledInterfaces = map toInstalledIface ifaces+ }]+ ++ map snd packages + -- /All/ visible interfaces including external package modules, grouped by+ -- interface file (package).+ allVisiblePackages :: [PackageInterfaces]+ allVisiblePackages = [ pinfo { piInstalledInterfaces =+ filter (\i -> OptHide `notElem` instOptions i)+ piInstalledInterfaces+ }+ | pinfo@PackageInterfaces+ { piVisibility = Visible+ , piInstalledInterfaces+ } <- allPackages+ ]++ -- /All/ installed interfaces.+ allInstalledIfaces :: [InstalledInterface]+ allInstalledIfaces = concatMap (piInstalledInterfaces . snd) packages+ pkgMod = fmap ifaceMod (listToMaybe ifaces) pkgKey = fmap moduleUnit pkgMod pkgStr = fmap unitString pkgKey@@ -343,7 +405,7 @@ sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') installedMap :: Map Module InstalledInterface- installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ]+ installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- allInstalledIfaces ] -- The user gives use base-4.9.0.0, but the InstalledInterface -- records the *wired in* identity base. So untranslate it@@ -366,38 +428,58 @@ themes <- getThemes libDir flags >>= either bye return let withQuickjump = Flag_QuickJumpIndex `elem` flags+ withBaseURL = isJust+ . find (\flag -> case flag of+ Flag_BaseURL base_url ->+ base_url /= "." && base_url /= "./"+ _ -> False+ )+ $ flags when (Flag_GenIndex `elem` flags) $ do- withTiming logger dflags' "ppHtmlIndex" (const ()) $ do+ withTiming logger "ppHtmlIndex" (const ()) $ do _ <- {-# SCC ppHtmlIndex #-} ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls- allVisibleIfaces pretty+ withQuickjump+ (concatMap piInstalledInterfaces allVisiblePackages) pretty return () - copyHtmlBits odir libDir themes withQuickjump+ unless withBaseURL $+ copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do- withTiming logger dflags' "ppHtmlContents" (const ()) $ do+ withTiming logger "ppHtmlContents" (const ()) $ do _ <- {-# SCC ppHtmlContents #-} ppHtmlContents unit_state odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls- allVisibleIfaces True prologue pretty+ withQuickjump+ allVisiblePackages True prologue pretty sincePkg (makeContentsQual qual) return () copyHtmlBits odir libDir themes withQuickjump + when withQuickjump $ void $+ ppJsonIndex odir sourceUrls' opt_wiki_urls+ unicode Nothing qual+ ifaces+ ( nub+ . map fst+ . filter ((== Visible) . piVisibility . snd)+ $ packages)+ when (Flag_Html `elem` flags) $ do- withTiming logger dflags' "ppHtml" (const ()) $ do+ withTiming logger "ppHtml" (const ()) $ do _ <- {-# SCC ppHtml #-} ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir prologue- themes opt_mathjax sourceUrls' opt_wiki_urls- opt_contents_url opt_index_url unicode sincePkg qual- pretty withQuickjump+ themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url+ opt_contents_url opt_index_url unicode sincePkg packageInfo+ qual pretty withQuickjump return ()- copyHtmlBits odir libDir themes withQuickjump- writeHaddockMeta odir withQuickjump+ unless withBaseURL $ do+ copyHtmlBits odir libDir themes withQuickjump+ writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them@@ -423,14 +505,14 @@ ] when (Flag_LaTeX `elem` flags) $ do- withTiming logger dflags' "ppLatex" (const ()) $ do+ withTiming logger "ppLatex" (const ()) $ do _ <- {-# SCC ppLatex #-} ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir return () when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do- withTiming logger dflags' "ppHyperlinkedSource" (const ()) $ do+ withTiming logger "ppHyperlinkedSource" (const ()) $ do _ <- {-# SCC ppHyperlinkedSource #-} ppHyperlinkedSource (verbosity flags) odir libDir opt_source_css pretty srcMap ifaces return ()@@ -441,23 +523,22 @@ ------------------------------------------------------------------------------- -readInterfaceFiles :: MonadIO m- => NameCacheAccessor m- -> [(DocPaths, FilePath)]+readInterfaceFiles :: NameCache+ -> [(DocPaths, Visibility, FilePath)] -> Bool- -> m [(DocPaths, InterfaceFile)]+ -> IO [(DocPaths, Visibility, FilePath, InterfaceFile)] readInterfaceFiles name_cache_accessor pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't- tryReadIface (paths, file) =+ tryReadIface (paths, vis, file) = readInterfaceFile name_cache_accessor file bypass_version_check >>= \case- Left err -> liftIO $ do+ Left err -> do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) putStrLn "Skipping this interface." return Nothing- Right f -> return $ Just (paths, f)+ Right f -> return (Just (paths, vis, file, f)) -------------------------------------------------------------------------------@@ -678,12 +759,12 @@ isSourceCssFlag _ = False -updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()+updateHTMLXRefs :: [(FilePath, 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+ mapping = [ (instMod iface, html) | (html, ifaces) <- packages , iface <- ifInstalledIfaces ifaces ] mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
haddock-api/src/Haddock/Backends/Hoogle.hs view
@@ -31,7 +31,6 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Parser.Annotation (IsUnicodeSyntax(..)) import GHC.Unit.State import Data.Char@@ -88,7 +87,7 @@ drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) drop_ty (HsListTy x a) = HsListTy x (drop_lty a) drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b)- drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) b (drop_lty c)+ drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c) drop_ty (HsParTy x a) = HsParTy x (drop_lty a) drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b drop_ty (HsDocTy _ a _) = drop_ty $ unL a@@ -247,11 +246,11 @@ f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat- [(concatMap (lookupCon dflags subdocs . noLocA . extFieldOcc . unLoc) (cd_fld_names r)) ++- [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]+ [(concatMap (lookupCon dflags subdocs . noLocA . foExt . unLoc) (cd_fld_names r)) +++ [out dflags (map (foExt . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)+ funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y) apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y) typeSig nm flds = operator nm ++ " :: " ++@@ -280,12 +279,12 @@ name = out dflags $ map unL names con_sig_ty = HsSig noExtField outer_bndrs theta_ty where theta_ty = case mcxt of- Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })+ Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty }) Nothing -> tau_ty tau_ty = foldr mkFunTy res_ty $ case args of PrefixConGADT pos_args -> map hsScaledThing pos_args- RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)+ RecConGADT (L _ flds) _ -> map (cd_fld_type . unL) flds+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]@@ -354,7 +353,7 @@ markupMathInline = const $ str "<math>", markupMathDisplay = const $ str "<math>", markupUnorderedList = box (TagL 'u'),- markupOrderedList = box (TagL 'o'),+ markupOrderedList = box (TagL 'o') . map snd, markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel),
haddock-api/src/Haddock/Backends/Hyperlinker.hs view
@@ -9,6 +9,7 @@ import Haddock.Types import Haddock.Utils (writeUtf8File, out, verbose, Verbosity)+import Haddock.InterfaceFile import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types@@ -20,13 +21,11 @@ import System.FilePath import GHC.Iface.Ext.Types ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) )-import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..))-import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc )+import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result )+import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc, srcSpanFile ) import Data.Map as M import GHC.Data.FastString ( mkFastString ) import GHC.Unit.Module ( Module, moduleName )-import GHC.Types.Name.Cache ( initNameCache )-import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) -- | Generate hyperlinked source for given interfaces.@@ -58,21 +57,19 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of Just hfp -> do -- Parse the GHC-produced HIE file- u <- mkSplitUniqSupply 'a'- let nc = (initNameCache u [])- ncu = NCU $ \f -> pure $ snd $ f nc+ nc <- freshNameCache HieFile { hie_hs_file = file , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc } <- hie_file_result- <$> (readHieFile ncu hfp)+ <$> (readHieFile nc hfp) -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file mast | M.size asts == 1 = snd <$> M.lookupMin asts | otherwise = M.lookup (HiePath (mkFastString file)) asts- tokens = parse df file rawSrc+ tokens' = parse df file rawSrc ast = fromMaybe (emptyHieAst fileFs) mast fullAst = recoverFullIfaceTypes df types ast @@ -82,6 +79,14 @@ else out verbosity verbose $ unwords [ "couldn't find ast for" , file, show (M.keys asts) ] + -- The C preprocessor can double the backslashes on tokens (see #19236),+ -- which means the source spans will not be comparable and we will not+ -- be able to associate the HieAST with the correct tokens.+ --+ -- We work around this by setting the source span of the tokens to the file+ -- name from the HieAST+ let tokens = fmap (\tk -> tk {tkSpan = (tkSpan tk){srcSpanFile = srcSpanFile $ nodeSpan fullAst}}) tokens'+ -- Produce and write out the hyperlinked sources writeUtf8File path . renderToString pretty . render' fullAst $ tokens Nothing -> return ()@@ -107,4 +112,3 @@ -- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir </> "html" </> "solarized.css"-
haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs view
@@ -10,14 +10,17 @@ import qualified Data.ByteString as BS +import GHC.Platform import GHC.Types.SourceText import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Data.FastString ( mkFastString )-import GHC.Parser.Errors.Ppr ( pprError )+import GHC.Parser.Errors.Ppr ()+import qualified GHC.Types.Error as E import GHC.Parser.Lexer as Lexer ( P(..), ParseResult(..), PState(..), Token(..)- , initParserState, lexer, mkParserOpts, getErrorMessages)+ , initParserState, lexer, mkParserOpts, getPsErrorMessages) import GHC.Data.Bag ( bagToList ) import GHC.Utils.Outputable ( text, ($$) ) import GHC.Utils.Panic ( panic )@@ -40,7 +43,7 @@ parse dflags fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks PFailed pst ->- let err:_ = bagToList (fmap pprError (getErrorMessages pst)) in+ let err:_ = bagToList (E.getMessages $ getPsErrorMessages pst) in panic $ showSDoc dflags $ text "Hyperlinker parse error:" $$ pprLocMsgEnvelope err where@@ -48,8 +51,10 @@ initState = initParserState pflags buf start buf = stringBufferFromByteString bs start = mkRealSrcLoc (mkFastString fpath) 1 1- pflags = mkParserOpts (warningFlags dflags)- (extensionFlags dflags)+ arch_os = platformArchOS (targetPlatform dflags)+ pflags = mkParserOpts (extensionFlags dflags)+ (initDiagOpts dflags)+ (supportedLanguagesAndExtensions arch_os) (safeImportsOn dflags) False -- lex Haddocks as comment tokens True -- produce comment tokens@@ -233,6 +238,7 @@ ITrequires -> TkKeyword ITinline_prag {} -> TkPragma+ ITopaque_prag {} -> TkPragma ITspec_prag {} -> TkPragma ITspec_inline_prag {} -> TkPragma ITsource_prag {} -> TkPragma@@ -263,6 +269,7 @@ ITequal -> TkGlyph ITlam -> TkGlyph ITlcase -> TkGlyph+ ITlcases -> TkGlyph ITvbar -> TkGlyph ITlarrow {} -> TkGlyph ITrarrow {} -> TkGlyph@@ -350,10 +357,7 @@ ITeof -> TkUnknown ITlineComment {} -> TkComment- ITdocCommentNext {} -> TkComment- ITdocCommentPrev {} -> TkComment- ITdocCommentNamed {} -> TkComment- ITdocSection {} -> TkComment+ ITdocComment {} -> TkComment ITdocOptions {} -> TkComment -- The lexer considers top-level pragmas as comments (see `pragState` in@@ -374,6 +378,7 @@ inPragma False tok = case tok of ITinline_prag {} -> True+ ITopaque_prag {} -> True ITspec_prag {} -> True ITspec_inline_prag {} -> True ITsource_prag {} -> True
haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} @@ -24,6 +23,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set+import qualified Data.List as List import Text.XHtml (Html, HtmlAttr, (!)) import qualified Text.XHtml as Html@@ -141,8 +141,8 @@ contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details - -- pick an arbitary non-evidence identifier to hyperlink with- identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details+ -- pick an arbitrary non-evidence identifier to hyperlink with+ identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers details notEvidence = not . any isEvidenceContext . identInfo -- If we have name information, we can make links@@ -249,14 +249,20 @@ Left name -> externalModHyperlink name where+ -- In a Nix environment, we have file:// URLs with absolute paths+ makeHyperlinkUrl url | List.isPrefixOf "file://" url = url+ makeHyperlinkUrl url = ".." </> url+ internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] externalNameHyperlink name content = case Map.lookup mdl srcs of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleNameUrl mdl name ]- Just (SrcExternal path) -> Html.anchor content !- [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." </> path) ]+ Just (SrcExternal path) ->+ let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleNameUrl mdl name+ in Html.anchor content !+ [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing hyperlinkUrl ] Nothing -> content where mdl = nameModule name@@ -265,8 +271,10 @@ case Map.lookup moduleName srcs' of Just SrcLocal -> Html.anchor content ! [ Html.href $ hypSrcModuleUrl' moduleName ]- Just (SrcExternal path) -> Html.anchor content !- [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." </> path) ]+ Just (SrcExternal path) ->+ let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleUrl' moduleName+ in Html.anchor content !+ [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing hyperlinkUrl ] Nothing -> content
haddock-api/src/Haddock/Backends/LaTeX.hs view
@@ -24,7 +24,7 @@ import GHC.Utils.Ppr hiding (Doc, quote) import qualified GHC.Utils.Ppr as Pretty -import GHC.Types.Basic ( PromotionFlag(..) )+import GHC.Types.Basic ( PromotionFlag(..), isPromoted ) import GHC hiding (fromMaybeContext ) import GHC.Types.Name.Occurrence import GHC.Types.Name ( nameOccName )@@ -843,7 +843,7 @@ fieldPart = case con of ConDeclGADT{con_g_args = con_args'} -> case con_args' of -- GADT record declarations- RecConGADT _ -> doConstrArgsWithDocs []+ RecConGADT _ _ -> doConstrArgsWithDocs [] -- GADT prefix data constructors PrefixConGADT args | hasArgDocs -> doConstrArgsWithDocs (map hsScaledThing args) _ -> empty@@ -887,12 +887,12 @@ -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =- decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))+ decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . foLabel . unLoc) names)) <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation- mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst+ mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- | Pretty-print a bundled pattern synonym@@ -983,12 +983,13 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX-ppLContext Nothing _ = empty-ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode-ppLContextNoArrow Nothing _ = empty-ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode+ppLContext :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX+ppLContext Nothing _ = empty+ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode +ppLContextNoArrow :: LHsContext DocNameI -> Bool -> LaTeX+ppLContextNoArrow ctxt unicode = ppContextNoArrow (unLoc ctxt) unicode+ ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX ppContextNoLocsMaybe [] _ = Nothing ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode@@ -1101,15 +1102,15 @@ = sep [ ppHsForAllTelescope tele unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsQualTy _ ctxt ty) unicode- = sep [ ppLContext ctxt unicode+ = sep [ ppLContext (Just ctxt) unicode , ppr_mono_lty ty unicode ] ppr_mono_ty (HsFunTy _ mult ty1 ty2) u = sep [ ppr_mono_lty ty1 u , arr <+> ppr_mono_lty ty2 u ] where arr = case mult of- HsLinearArrow _ _ -> lollipop u+ HsLinearArrow _ -> lollipop u HsUnrestrictedArrow _ -> arrow u- HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u+ HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u <+> arrow u ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name@@ -1132,9 +1133,13 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode = hsep [ppr_mono_lty fun_ty unicode, atSign unicode <> ppr_mono_lty arg_ki unicode] -ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode- = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode+ = ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode where+ ppr_op_prom | isPromoted prom+ = char '\'' <> ppr_op+ | otherwise+ = ppr_op ppr_op | isSymOcc (getOccName op) = ppLDocName op | otherwise = char '`' <> ppLDocName op <> char '`' @@ -1260,7 +1265,7 @@ , markupPic = \p _ -> inlineElem (markupPic p) , markupMathInline = \p _ -> inlineElem (markupMathInline p) , markupMathDisplay = \p _ -> blockElem (markupMathDisplay p)- , markupOrderedList = \p v -> blockElem (enumeratedList (map (\p' -> p' v empty) p))+ , markupOrderedList = \p v -> blockElem (enumeratedList (map (\(_, p') -> p' v empty) p)) , markupDefList = \l v -> blockElem (descriptionList (map (\(a,b) -> (a v empty, b v empty)) l)) , markupCodeBlock = \p _ -> blockElem (quote (verb (p Verb empty))) , markupHyperlink = \(Hyperlink u l) v -> inlineElem (markupLink u (fmap (\x -> x v empty) l))@@ -1296,7 +1301,7 @@ Just label -> text "\\href" <> braces (text url) <> braces label Nothing -> text "\\url" <> braces (text url) - -- Is there a better way of doing this? Just a space is an aribtrary choice.+ -- Is there a better way of doing this? Just a space is an arbitrary choice. markupPic (Picture uri title) = parens (imageText title) where imageText Nothing = beg@@ -1328,7 +1333,7 @@ data StringContext = Plain -- ^ all special characters have to be escape- | Mono -- ^ on top of special characters, escape space chraacters+ | Mono -- ^ on top of special characters, escape space characters | Verb -- ^ don't escape anything @@ -1389,7 +1394,7 @@ -- TODO: @verbatim@ is too much since ----- * Haddock supports markup _inside_ of codeblocks. Right now, the LaTeX+-- * Haddock supports markup _inside_ of code blocks. Right now, the LaTeX -- representing that markup gets printed verbatim -- * Verbatim environments are not supported everywhere (example: not nested -- inside a @tabulary@ environment)
haddock-api/src/Haddock/Backends/Xhtml.hs view
@@ -11,10 +11,11 @@ -- Stability : experimental -- Portability : portable ------------------------------------------------------------------------------{-# LANGUAGE CPP, NamedFieldPuns #-}+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-} module Haddock.Backends.Xhtml ( ppHtml, copyHtmlBits, ppHtmlIndex, ppHtmlContents,+ ppJsonIndex ) where @@ -27,7 +28,9 @@ import Haddock.Backends.Xhtml.Themes import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils+import Haddock.InterfaceFile (PackageInfo (..), PackageInterfaces (..), ppPackageInfo) import Haddock.ModuleTree+import Haddock.Options (Visibility (..)) import Haddock.Types import Haddock.Version import Haddock.Utils@@ -38,12 +41,16 @@ import Control.Monad ( when, unless ) import qualified Data.ByteString.Builder as Builder+import Data.Bifunctor ( bimap ) import Data.Char ( toUpper, isSpace )+import Data.Either ( partitionEithers )+import Data.Foldable ( traverse_) import Data.List ( sortBy, isPrefixOf, intersperse ) import Data.Maybe import System.Directory import System.FilePath hiding ( (</>) ) import qualified System.IO as IO+import qualified System.FilePath as FilePath import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set )@@ -68,10 +75,12 @@ -> Maybe String -- ^ The mathjax URL (--mathjax) -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki)+ -> BaseURL -- ^ The base URL (--base-url) -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) -> Maybe String -- ^ Package name+ -> PackageInfo -- ^ Package info -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> Bool -- ^ Also write Quickjump index@@ -79,8 +88,8 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode- pkg qual debug withQuickjump = do+ maybe_base_url maybe_contents_url maybe_index_url unicode+ pkg packageInfo qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i@@ -88,22 +97,30 @@ when (isNothing maybe_contents_url) $ ppHtmlContents state odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url- (map toInstalledIface visible_ifaces ++ reexported_ifaces)+ withQuickjump+ [PackageInterfaces+ { piPackageInfo = packageInfo+ , piVisibility = Visible+ , piInstalledInterfaces = map toInstalledIface visible_ifaces+ ++ reexported_ifaces+ }] False -- we don't want to display the packages in a single-package contents prologue debug pkg (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url+ withQuickjump (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug - when withQuickjump $- ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual- visible_ifaces+ when withQuickjump $+ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual+ visible_ifaces [] mapM_ (ppHtmlModule odir doctitle themes- maybe_mathjax_url maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces+ maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+ maybe_contents_url maybe_index_url withQuickjump+ unicode pkg qual debug) visible_ifaces copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()@@ -119,16 +136,23 @@ return () -headHtml :: String -> Themes -> Maybe String -> Html-headHtml docTitle themes mathjax_url =- header <<+headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html+headHtml docTitle themes mathjax_url base_url =+ header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url)+ << [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"] , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"] , thetitle << docTitle- , styleSheet themes- , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml+ , styleSheet base_url themes+ , thelink ! [ rel "stylesheet"+ , thetype "text/css"+ , href (withBaseURL base_url quickJumpCssFile) ]+ << noHtml , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml- , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml+ , script ! [ src (withBaseURL base_url haddockJsFile)+ , emptyAttr "async"+ , thetype "text/javascript" ]+ << noHtml , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf , script ! [src mjUrl, thetype "text/javascript"] << noHtml ]@@ -142,6 +166,15 @@ , "}" , "});" ] +quickJumpButtonLi :: Bool -- ^ With Quick Jump?+ -> Maybe Html+-- The TypeScript should replace this <li> element, given its id. However, in+-- case it does not, the element is given content here too.+quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"]+ << anchor ! [href "#"] << "Quick Jump"++quickJumpButtonLi False = Nothing+ srcButton :: SourceURLs -> Maybe Interface -> Maybe Html srcButton (Just src_base_url, _, _, _) Nothing = Just (anchor ! [href src_base_url] << "Source")@@ -180,20 +213,18 @@ bodyHtml :: String -> Maybe Interface -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String+ -> Bool -- ^ With Quick Jump? -> Html -> Html bodyHtml doctitle iface maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url+ withQuickjump pageContent = body << [ divPackageHeader << [ nonEmptySectionName << doctitle,- 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"]+ ulist ! [theclass "links", identifier "page-menu"]+ << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis) ], divContent << pageContent, divFooter << paragraph << (@@ -202,6 +233,13 @@ (" version " ++ projectVersion) ) ]+ where+ otherButtonLis = (fmap . fmap) (li <<)+ [ srcButton maybe_source_url iface+ , wikiButton maybe_wiki_url (ifaceMod <$> iface)+ , contentsButton maybe_contents_url+ , indexButton maybe_index_url+ ] moduleInfo :: Interface -> Html moduleInfo iface =@@ -264,30 +302,44 @@ -> Maybe String -> SourceURLs -> WikiURLs- -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)+ -> Bool -- ^ With Quick Jump?+ -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool -> Maybe Package -- ^ Current package -> Qualification -- ^ How to qualify names -> IO () ppHtmlContents state odir doctitle _maybe_package themes mathjax_url maybe_index_url- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do- let tree = mkModuleTree state showPkgs- [(instMod iface, toInstalledDescription iface)- | iface <- ifaces- , not (instIsSig iface)]- sig_tree = mkModuleTree state showPkgs- [(instMod iface, toInstalledDescription iface)- | iface <- ifaces- , instIsSig iface]+ maybe_source_url maybe_wiki_url withQuickjump+ packages showPkgs prologue debug pkg qual = do+ let trees =+ [ ( piPackageInfo pinfo+ , mkModuleTree state showPkgs+ [(instMod iface, toInstalledDescription iface)+ | iface <- piInstalledInterfaces pinfo+ , not (instIsSig iface)+ ]+ )+ | pinfo <- packages+ ]+ sig_trees =+ [ ( piPackageInfo pinfo+ , mkModuleTree state showPkgs+ [(instMod iface, toInstalledDescription iface)+ | iface <- piInstalledInterfaces pinfo+ , instIsSig iface+ ]+ )+ | pinfo <- packages+ ] html =- headHtml doctitle themes mathjax_url ++++ headHtml doctitle themes mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url- Nothing maybe_index_url << [+ Nothing maybe_index_url withQuickjump << [ ppPrologue pkg qual doctitle prologue,- ppSignatureTree pkg qual sig_tree,- ppModuleTree pkg qual tree+ ppSignatureTrees pkg qual sig_trees,+ ppModuleTrees pkg qual trees ] createDirectoryIfMissing True odir writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)@@ -302,17 +354,37 @@ ppPrologue pkg qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc)) +ppSignatureTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html+ppSignatureTrees _ _ tss | all (null . snd) tss = mempty+ppSignatureTrees pkg qual [(info, ts)] = + divPackageList << (sectionName << "Signatures" +++ ppSignatureTree pkg qual "n" info ts)+ppSignatureTrees pkg qual tss =+ divModuleList <<+ (sectionName << "Signatures"+ +++ concatHtml [ ppSignatureTree pkg qual("n."++show i++".") info ts+ | (i, (info, ts)) <- zip [(1::Int)..] tss+ ]) -ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html-ppSignatureTree _ _ [] = mempty-ppSignatureTree pkg qual ts =- divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)+ppSignatureTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html+ppSignatureTree _ _ _ _ [] = mempty+ppSignatureTree pkg qual p info ts =+ divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) +ppModuleTrees :: Maybe Package -> Qualification -> [(PackageInfo, [ModuleTree])] -> Html+ppModuleTrees _ _ tss | all (null . snd) tss = mempty+ppModuleTrees pkg qual [(info, ts)] =+ divModuleList << (sectionName << "Modules" +++ ppModuleTree pkg qual "n" info ts)+ppModuleTrees pkg qual tss =+ divPackageList <<+ (sectionName << "Packages"+ +++ concatHtml [ppModuleTree pkg qual ("n."++show i++".") info ts+ | (i, (info, ts)) <- zip [(1::Int)..] tss+ ]) -ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html-ppModuleTree _ _ [] = mempty-ppModuleTree pkg qual ts =- divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)+ppModuleTree :: Maybe Package -> Qualification -> String -> PackageInfo -> [ModuleTree] -> Html+ppModuleTree _ _ _ _ [] = mempty+ppModuleTree pkg qual p info ts =+ divModuleList << (sectionName << ppPackageInfo info +++ mkNodeList pkg qual [] p ts) mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html@@ -361,6 +433,35 @@ -- * Generate the index -------------------------------------------------------------------------------- +data JsonIndexEntry = JsonIndexEntry {+ jieHtmlFragment :: String,+ jieName :: String,+ jieModule :: String,+ jieLink :: String+ }+ deriving Show++instance ToJSON JsonIndexEntry where+ toJSON JsonIndexEntry+ { jieHtmlFragment+ , jieName+ , jieModule+ , jieLink } =+ Object+ [ "display_html" .= String jieHtmlFragment+ , "name" .= String jieName+ , "module" .= String jieModule+ , "link" .= String jieLink+ ]++instance FromJSON JsonIndexEntry where+ parseJSON = withObject "JsonIndexEntry" $ \v ->+ JsonIndexEntry+ <$> v .: "display_html"+ <*> v .: "name"+ <*> v .: "module"+ <*> v .: "link"+ ppJsonIndex :: FilePath -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki)@@ -368,34 +469,55 @@ -> Maybe Package -> QualOption -> [Interface]+ -> [FilePath] -- ^ file paths to interface files+ -- (--read-interface) -> IO ()-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do createDirectoryIfMissing True odir- IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do- Builder.hPutBuilder h (encodeToBuilder modules)+ (errors, installedIndexes) <-+ partitionEithers+ <$> traverse+ (\ifaceFile -> do+ let indexFile = takeDirectory ifaceFile+ FilePath.</> "doc-index.json"+ a <- doesFileExist indexFile+ if a then+ bimap (indexFile,) (map (fixLink ifaceFile))+ <$> eitherDecodeFile @[JsonIndexEntry] indexFile+ else+ return (Right [])+ )+ installedIfacesPaths+ traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)+ errors+ IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->+ Builder.hPutBuilder+ h (encodeToBuilder (encodeIndexes (concat installedIndexes))) where- modules :: Value- modules = Array (concatMap goInterface ifaces)+ encodeIndexes :: [JsonIndexEntry] -> Value+ encodeIndexes installedIndexes =+ toJSON+ (concatMap fromInterface ifaces+ ++ installedIndexes) - goInterface :: Interface -> [Value]- goInterface iface =- concatMap (goExport mdl qual) (ifaceRnExportItems iface)+ fromInterface :: Interface -> [JsonIndexEntry]+ fromInterface iface =+ mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface where aliases = ifaceModuleAliases iface qual = makeModuleQual qual_opt aliases mdl mdl = ifaceMod iface - goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]- goExport mdl qual item+ mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry+ mkIndex mdl qual item | Just item_html <- processExport True links_info unicode pkg qual item- = [ Object- [ "display_html" .= String (showHtmlFragment item_html)- , "name" .= String (unwords (map getOccString names))- , "module" .= String (moduleString mdl)- , "link" .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))- ]- ]- | otherwise = []+ = Just JsonIndexEntry+ { jieHtmlFragment = showHtmlFragment item_html+ , jieName = unwords (map getOccString names)+ , jieModule = moduleString mdl+ , jieLink = fromMaybe "" (listToMaybe (map (nameLink mdl) names))+ }+ | otherwise = Nothing where names = exportName item ++ exportSubs item @@ -413,6 +535,13 @@ links_info = (maybe_source_url, maybe_wiki_url) + -- update link using relative path to output directory+ fixLink :: FilePath+ -> JsonIndexEntry -> JsonIndexEntry+ fixLink ifaceFile jie = + jie { jieLink = makeRelative odir (takeDirectory ifaceFile)+ FilePath.</> jieLink jie }+ ppHtmlIndex :: FilePath -> String -> Maybe String@@ -421,11 +550,12 @@ -> Maybe String -> SourceURLs -> WikiURLs+ -> Bool -- ^ With Quick Jump? -> [InstalledInterface] -> Bool -> IO () ppHtmlIndex odir doctitle _maybe_package themes- maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do+ maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do let html = indexPage split_indices Nothing (if split_indices then [] else index) @@ -441,10 +571,10 @@ where indexPage showLetters ch items =- headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url ++++ headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++ bodyHtml doctitle Nothing maybe_source_url maybe_wiki_url- maybe_contents_url Nothing << [+ maybe_contents_url Nothing withQuickjump << [ if showLetters then indexInitialLetterLinks else noHtml, if null items then noHtml else divIndex << [sectionName << indexName ch, buildIndex items]@@ -541,12 +671,15 @@ ppHtmlModule :: FilePath -> String -> Themes- -> Maybe String -> SourceURLs -> WikiURLs- -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption+ -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL+ -> Maybe String -> Maybe String+ -> Bool -- ^ With Quick Jump?+ -> Bool -> Maybe Package -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes- maybe_mathjax_url maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url unicode pkg qual debug iface = do+ maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url+ maybe_contents_url maybe_index_url withQuickjump+ unicode pkg qual debug iface = do let mdl = ifaceMod iface aliases = ifaceModuleAliases iface@@ -563,10 +696,10 @@ = toHtml mdl_str real_qual = makeModuleQual qual aliases mdl html =- headHtml mdl_str_annot themes maybe_mathjax_url ++++ headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++ bodyHtml doctitle (Just iface) maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url << [+ maybe_contents_url maybe_index_url withQuickjump << [ divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)), ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual ]
haddock-api/src/Haddock/Backends/Xhtml/Decl.hs view
@@ -167,7 +167,7 @@ leader' = leader <+> ppForAllPart unicode qual tele do_args n leader (HsQualTy _ lctxt ltype)- | null (fromMaybeContext lctxt)+ | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])@@ -436,13 +436,15 @@ ------------------------------------------------------------------------------- -ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode+ppLContext :: Maybe (LHsContext DocNameI) -> Unicode -> Qualification -> HideEmptyContexts -> Html ppLContext Nothing u q h = ppContext [] u q h ppLContext (Just c) u q h = ppContext (unLoc c) u q h-ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h-ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h +ppLContextNoArrow :: LHsContext DocNameI -> Unicode+ -> Qualification -> HideEmptyContexts -> Html+ppLContextNoArrow c u q h = ppContextNoArrow (unLoc c) u q h+ ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $ ppContextNoLocsMaybe (map unLoc cxt) unicode qual emptyCtxts@@ -725,7 +727,7 @@ L _ rtyp = dropWildCards typ -- Instance methods signatures are synified and thus don't have a useful -- SrcSpan value. Use the methods name location instead.- return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head lnames) names rtyp lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2@@ -967,7 +969,7 @@ fieldPart = case con of ConDeclGADT{con_g_args = con_args'} -> case con_args' of -- GADT record declarations- RecConGADT _ -> [ doConstrArgsWithDocs [] ]+ RecConGADT _ _ -> [ doConstrArgsWithDocs [] ] -- GADT prefix data constructors PrefixConGADT args | hasArgDocs -> [ doConstrArgsWithDocs args ] _ -> []@@ -1025,7 +1027,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) | L _ name <- names- , let field = (unLoc . rdrNameFieldOcc) name+ , let field = (unLoc . foLabel) name ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype@@ -1035,12 +1037,12 @@ where -- don't use cd_fld_doc for same reason we don't use con_doc above -- Where there is more than one name, they all have the same documentation- mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst+ mbDoc = lookup (foExt $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html ppShortField summary unicode qual (ConDeclField _ names ltype _)- = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names))+ = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . foLabel . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype @@ -1185,13 +1187,13 @@ hasNonEmptyContext t = case unLoc t of HsForAllTy _ _ s -> hasNonEmptyContext s- HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True+ HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True HsFunTy _ _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty t = case unLoc t of HsForAllTy _ _ s -> isFirstContextEmpty s- HsQualTy _ cxt _ -> null (fromMaybeContext cxt)+ HsQualTy _ cxt _ -> null (unLoc cxt) HsFunTy _ _ _ s -> isFirstContextEmpty s _ -> False @@ -1230,7 +1232,7 @@ = ppForAllPart unicode qual tele <+> ppr_mono_lty ty unicode qual emptyCtxts ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts- = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts+ = ppLContext (Just ctxt) unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts -- UnicodeSyntax alternatives ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _@@ -1248,9 +1250,9 @@ , arr <+> ppr_mono_lty ty2 u q e ] where arr = case mult of- HsLinearArrow _ _ -> lollipop u+ HsLinearArrow _ -> lollipop u HsUnrestrictedArrow _ -> arrow u- HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u+ HsExplicitMult _ m _ -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u ppr_mono_ty (HsTupleTy _ con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys)@@ -1279,15 +1281,15 @@ = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts] -ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _- = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts+ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _+ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts where- -- `(:)` is valid in type signature only as constructor to promoted list- -- and needs to be quoted in code so we explicitly quote it here too.- ppr_op- | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'- | otherwise = ppr_op'- ppr_op' = ppLDocName qual Infix op+ ppr_op_prom+ | isPromoted prom+ = promoQuote ppr_op+ | otherwise+ = ppr_op+ ppr_op = ppLDocName qual Infix op ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts = parens (ppr_mono_lty ty unicode qual emptyCtxts)
haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -46,7 +46,7 @@ markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \(ModLink m lbl) -> let (mdl,ref) = break (=='#') m- -- Accomodate for old style+ -- Accommodate for old style -- foo\#bar anchors mdl' = case reverse mdl of '\\':_ -> init mdl@@ -57,7 +57,7 @@ markupBold = strong, markupMonospaced = thecode, markupUnorderedList = unordList,- markupOrderedList = ordList,+ markupOrderedList = makeOrdList, markupDefList = defList, markupCodeBlock = pre, markupHyperlink = \(Hyperlink url mLabel)@@ -112,9 +112,12 @@ htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + makeOrdList :: HTML a => [(Int, a)] -> Html+ makeOrdList items = olist << map (\(index, a) -> li ! [intAttr "value" index] << a) items+ -- | We use this intermediate type to transform the input 'Doc' tree -- in an arbitrary way before rendering, such as grouping some--- elements. This is effectivelly a hack to prevent the 'Doc' type+-- elements. This is effectively a hack to prevent the 'Doc' type -- from changing if it is possible to recover the layout information -- we won't need after the fact. data Hack a id =@@ -277,5 +280,5 @@ fmtUnParagraphLists :: DocMarkup (Wrap a) (Doc a) fmtUnParagraphLists = idMarkup { markupUnorderedList = DocUnorderedList . map unParagraph,- markupOrderedList = DocOrderedList . map unParagraph+ markupOrderedList = DocOrderedList . map (\(index, a) -> (index, unParagraph a)) }
haddock-api/src/Haddock/Backends/Xhtml/Layout.hs view
@@ -15,7 +15,7 @@ divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface,- divIndex, divAlphabet, divModuleList, divContentsList,+ divIndex, divAlphabet, divPackageList, divModuleList, divContentsList, sectionName, nonEmptySectionName,@@ -81,7 +81,7 @@ divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynopsis, divInterface,- divIndex, divAlphabet, divModuleList, divContentsList+ divIndex, divAlphabet, divPackageList, divModuleList, divContentsList :: Html -> Html divPackageHeader = sectionDiv "package-header"@@ -96,6 +96,7 @@ divIndex = sectionDiv "index" divAlphabet = sectionDiv "alphabet" divModuleList = sectionDiv "module-list"+divPackageList = sectionDiv "module-list" --------------------------------------------------------------------------------@@ -219,7 +220,7 @@ where wrap = ((h1 << "Orphan instances") +++) instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice- id_ = makeAnchorId $ "orphans"+ id_ = makeAnchorId "orphans" subInstHead :: String -- ^ Instance unique id (for anchor generation)
haddock-api/src/Haddock/Backends/Xhtml/Meta.hs view
@@ -14,7 +14,7 @@ -- | Writes a json encoded file containing additional -- information about the generated documentation. This--- is useful for external tools (e.g. hackage).+-- is useful for external tools (e.g., Hackage). writeHaddockMeta :: FilePath -> Bool -> IO () writeHaddockMeta odir withQuickjump = do let
haddock-api/src/Haddock/Backends/Xhtml/Themes.hs view
@@ -17,6 +17,7 @@ where import Haddock.Options+import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL ) import Control.Monad (liftM) import Data.Char (toLower)@@ -176,13 +177,13 @@ cssFiles ts = nub $ concatMap themeFiles ts -styleSheet :: Themes -> Html-styleSheet ts = toHtml $ zipWith mkLink rels ts+styleSheet :: BaseURL -> Themes -> Html+styleSheet base_url ts = toHtml $ zipWith mkLink rels ts where rels = "stylesheet" : repeat "alternate stylesheet" mkLink aRel t = thelink- ! [ href (themeHref t), rel aRel, thetype "text/css",+ ! [ href (withBaseURL base_url (themeHref t)), rel aRel, thetype "text/css", XHtml.title (themeName t) ] << noHtml
haddock-api/src/Haddock/Backends/Xhtml/Types.hs view
@@ -12,6 +12,8 @@ ----------------------------------------------------------------------------- module Haddock.Backends.Xhtml.Types ( SourceURLs, WikiURLs,+ BaseURL,+ withBaseURL, LinksInfo, Splice, Unicode,@@ -20,12 +22,21 @@ import Data.Map import GHC+import qualified System.FilePath as FilePath -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) +-- | base url for loading js, json, css resources. The default is "."+--+type BaseURL = Maybe String++-- TODO: we shouldn't use 'FilePath.</>'+withBaseURL :: BaseURL -> String -> String+withBaseURL Nothing uri = uri+withBaseURL (Just baseUrl) uri = baseUrl FilePath.</> uri -- The URL for source and wiki links type LinksInfo = (SourceURLs, WikiURLs)
haddock-api/src/Haddock/Convert.hs view
@@ -19,8 +19,6 @@ PrintRuntimeReps(..), ) where -#include "HsVersions.h"- import GHC.Data.Bag ( emptyBag ) import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) ) import GHC.Types.SourceText (SourceText(..))@@ -47,9 +45,9 @@ import GHC.Builtin.Names ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedDataConKey, boxedRepDataConKey ) import GHC.Types.Unique ( getUnique )-import GHC.Utils.Misc ( chkAppend, debugIsOn, dropList, equalLength+import GHC.Utils.Misc ( chkAppend, dropList, equalLength , filterByList, filterOut )-import GHC.Utils.Panic ( assertPanic )+import GHC.Utils.Panic.Plain ( assert ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.SrcLoc@@ -126,7 +124,7 @@ vs = tyConVisibleTyVars (classTyCon cl) in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl- { tcdCtxt = synifyCtx (classSCTheta cl)+ { tcdCtxt = Just $ synifyCtx (classSCTheta cl) , tcdLName = synifyNameN cl , tcdTyVars = synifyTyVars vs , tcdFixity = synifyFixity cl@@ -304,7 +302,7 @@ alg_deriv = [] defn = HsDataDefn { dd_ext = noExtField , dd_ND = alg_nd- , dd_ctxt = alg_ctx+ , dd_ctxt = Just alg_ctx , dd_cType = Nothing , dd_kindSig = kindSig , dd_cons = cons@@ -343,14 +341,14 @@ synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = let rhs = map (noLocA . tyVarName) (filterByList inj tvs)- in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs+ in Just $ noLocA $ InjectivityAnn noAnn (noLocA lhs) rhs synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind- | isLiftedTypeKind kind = noLoc $ NoSig noExtField- | otherwise = noLoc $ KindSig noExtField (synifyKindSig kind)+ | isLiftedTypeKind kind = noLocA $ NoSig noExtField+ | otherwise = noLocA $ KindSig noExtField (synifyKindSig kind) synifyFamilyResultSig (Just name) kind =- noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind))+ noLocA $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its@@ -377,7 +375,7 @@ -- skip any EqTheta, use 'orig'inal syntax ctx | null theta = Nothing- | otherwise = synifyCtx theta+ | otherwise = Just $ synifyCtx theta linear_tys = zipWith (\ty bang ->@@ -389,7 +387,7 @@ field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLocA $- ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy+ ConDeclField noAnn [noLocA $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy Nothing mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)@@ -403,7 +401,7 @@ mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn mk_gadt_arg_tys- | use_named_field_syntax = RecConGADT (noLocA field_tys)+ | use_named_field_syntax = RecConGADT (noLocA field_tys) noHsUniTok | otherwise = PrefixConGADT (map hsUnrestricted linear_tys) -- finally we get synifyDataCon's result!@@ -464,8 +462,8 @@ mainSig t = synifySigType DeleteTopLevelQuantification vs t defSig t = synifySigType ImplicitizeForAll vs t -synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn)-synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))+synifyCtx :: [PredType] -> LHsContext GhcRn+synifyCtx ts = noLocA ( map (synifyType WithinType []) ts) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn@@ -608,23 +606,25 @@ tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise- -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy+ -> noLocA $ HsOpTy noAnn IsPromoted hTy (noLocA $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name- = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty)+ = noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys- = noLocA $ HsOpTy noExtField+ = noLocA $ HsOpTy noAnn+ NotPromoted (synifyType WithinType vs ty1) (noLocA eqTyConName) (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys- = mk_app_tys (HsOpTy noExtField+ = mk_app_tys (HsOpTy noAnn+ prom (synifyType WithinType vs ty1) (noLocA $ getName tc) (synifyType WithinType vs ty2))@@ -799,9 +799,9 @@ synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn synifyMult vs t = case t of- One -> HsLinearArrow NormalSyntax Nothing- Many -> HsUnrestrictedArrow NormalSyntax- ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty)+ One -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)+ Many -> HsUnrestrictedArrow noHsUniTok+ ty -> HsExplicitMult noHsTok (synifyType WithinType vs ty) noHsUniTok @@ -933,8 +933,8 @@ tcSplitForAllTysReqPreserveSynonyms ty = let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isVisibleArgFlag ty req_bndrs = mapMaybe mk_req_bndr_maybe all_bndrs in- ASSERT( req_bndrs `equalLength` all_bndrs )- (req_bndrs, body)+ assert ( req_bndrs `equalLength` all_bndrs)+ (req_bndrs, body) where mk_req_bndr_maybe :: TyCoVarBinder -> Maybe ReqTVBinder mk_req_bndr_maybe (Bndr tv argf) = case argf of@@ -946,8 +946,8 @@ tcSplitForAllTysInvisPreserveSynonyms ty = let (all_bndrs, body) = tcSplitSomeForAllTysPreserveSynonyms isInvisibleArgFlag ty inv_bndrs = mapMaybe mk_inv_bndr_maybe all_bndrs in- ASSERT( inv_bndrs `equalLength` all_bndrs )- (inv_bndrs, body)+ assert ( inv_bndrs `equalLength` all_bndrs)+ (inv_bndrs, body) where mk_inv_bndr_maybe :: TyCoVarBinder -> Maybe InvisTVBinder mk_inv_bndr_maybe (Bndr tv argf) = case argf of
haddock-api/src/Haddock/GhcUtils.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}+{-# LANGUAGE BangPatterns, FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -95,7 +96,7 @@ ifTrueJust False = const Nothing sigName :: LSig GhcRn -> [IdP GhcRn]-sigName (L _ sig) = sigNameNoLoc sig+sigName (L _ sig) = sigNameNoLoc emptyOccEnv sig -- | Was this signature given by the user? isUserLSig :: forall p. UnXRec p => LSig p -> Bool@@ -114,7 +115,7 @@ -- instantiated at DocNameI instead of (GhcPass _). -- | Like 'hsTyVarName' from GHC API, but not instantiated at (GhcPass _)-hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ NoExtCon, UnXRec n)+hsTyVarBndrName :: forall flag n. (XXTyVarBndr n ~ DataConCantHappen, UnXRec n) => HsTyVarBndr flag n -> IdP n hsTyVarBndrName (UserTyVar _ _ name) = unXRec @n name hsTyVarBndrName (KindedTyVar _ _ name _) = unXRec @n name@@ -135,7 +136,7 @@ mkEmptySigType :: LHsType GhcRn -> LHsSigType GhcRn -- Dubious, because the implicit binders are empty even--- though the type might have free varaiables+-- though the type might have free variables mkEmptySigType lty@(L loc ty) = L loc $ case ty of HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } , hst_body = body }@@ -171,17 +172,17 @@ , sig_body = theta_ty }) where theta_ty | Just theta <- mcxt- = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })+ = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty -- tau_ty :: LHsType DocNameI tau_ty = case args of- RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty+ RecConGADT flds _ -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI- mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)+ mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT@@ -192,7 +193,7 @@ case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name]-getMainDeclBinderI (SigD _ d) = sigNameNoLoc d+getMainDeclBinderI (SigD _ d) = sigNameNoLoc emptyOccEnv d getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name] getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinderI _ = []@@ -226,12 +227,11 @@ , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go_ty (L loc ty) = L loc (HsQualTy { hst_xqual = noExtField- , hst_ctxt = add_ctxt Nothing, hst_body = L loc ty })+ , hst_ctxt = add_ctxt (noLocA []), hst_body = L loc ty }) - extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0)+ extra_pred = nlHsTyConApp NotPromoted Prefix cls (lHsQTyVarsToTypes tvs0) - add_ctxt Nothing = Just $ noLocA [extra_pred]- add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)+ add_ctxt (L loc preds) = L loc (extra_pred : preds) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine @@ -284,14 +284,14 @@ ConDeclGADT { con_g_args = con_args' } -> case con_args' of PrefixConGADT {} -> Just d- RecConGADT fields+ RecConGADT fields _ | all field_avail (unLoc fields) -> Just d | otherwise -> Just (d { con_g_args = PrefixConGADT (field_types $ unLoc fields) }) -- see above where field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField _ fs _ _))- = all (\f -> extFieldOcc (unLoc f) `elem` names) fs+ = all (\f -> foExt (unLoc f) `elem` names) fs field_types flds = [ hsUnrestricted t | L _ (ConDeclField _ _ t _) <- flds ] @@ -356,9 +356,7 @@ go p (HsQualTy x ctxt ty) = let p' [_] = PREC_CTX p' _ = PREC_TOP -- parens will get added anyways later...- ctxt' = case ctxt of- Nothing -> Nothing- Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c+ ctxt' = mapXRec @a (\xs -> map (goL (p' xs)) xs) ctxt in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty) go p (HsFunTy x w ty1 ty2)@@ -367,8 +365,8 @@ = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) go p (HsAppKindTy x fun_ty arg_ki) = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)- go p (HsOpTy x ty1 op ty2)- = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)+ go p (HsOpTy x prom ty1 op ty2)+ = paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2) go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go _ t@HsTyVar{} = t go _ t@HsStarTy{} = t@@ -469,12 +467,12 @@ children con = case getRecConArgs_maybe con of Nothing -> []- Just flds -> map (extFieldOcc . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds)+ Just flds -> map (foExt . unLoc) $ concatMap (cd_fld_names . unLoc) (unLoc flds) instance Parent (TyClDecl GhcRn) where children d | isDataDecl d = map unLoc $ concatMap (getConNames . unLoc)- $ (dd_cons . tcdDataDefn) $ d+ $ (dd_cons . tcdDataDefn) d | isClassDecl d = map (unLoc . fdLName . unLoc) (tcdATs d) ++ [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]@@ -556,7 +554,7 @@ -- -- /O(1)/ takeStringBuffer :: Int -> StringBuffer -> ByteString-takeStringBuffer !n !(S.StringBuffer fp _ cur) = BS.PS fp cur n+takeStringBuffer !n (S.StringBuffer fp _ cur) = BS.PS fp cur n -- | Return the prefix of the first 'StringBuffer' that /isn't/ in the second -- 'StringBuffer'. **The behavior is undefined if the 'StringBuffers' use
haddock-api/src/Haddock/Interface.hs view
@@ -46,7 +46,7 @@ import Haddock.Utils (Verbosity (..), normal, out, verbose) import Control.Monad (unless, when)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Class (MonadIO) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.List (foldl', isPrefixOf, nub) import Text.Printf (printf)@@ -54,23 +54,16 @@ import qualified Data.Set as Set import GHC hiding (verbosity)-import GHC.Data.FastString (unpackFS)-import GHC.Data.Graph.Directed (flattenSCCs)-import GHC.Driver.Env (hsc_dflags, hsc_home_unit, hsc_logger, hsc_static_plugins, hsc_units)+import GHC.Data.Graph.Directed+import GHC.Driver.Env import GHC.Driver.Monad (modifySession, withTimingM) import GHC.Driver.Session hiding (verbosity) import GHC.HsToCore.Docs (getMainDeclBinder)-import GHC.Plugins (Outputable, Plugin (..), PluginWithArgs (..), StaticPlugin (..), defaultPlugin, keepRenamedSource)+import GHC.Plugins import GHC.Tc.Types (TcGblEnv (..), TcM) import GHC.Tc.Utils.Env (tcLookupGlobal) import GHC.Tc.Utils.Monad (getTopEnv, setGblEnv)-import GHC.Types.Name (nameIsFromExternalPackage, nameOccName)-import GHC.Types.Name.Occurrence (isTcOcc)-import GHC.Types.Name.Reader (globalRdrEnvElts, greMangledName, unQualOK)-import GHC.Unit.Module.Env (ModuleSet, emptyModuleSet, mkModuleSet, unionModuleSet)-import GHC.Unit.Module.Graph (ModuleGraphNode (..))-import GHC.Unit.Module.ModSummary (emsModSummary, isBootSummary)-import GHC.Unit.Types (IsBootInterface (..))+import GHC.Unit.Module.Graph import GHC.Utils.Error (withTiming) #if defined(mingw32_HOST_OS)@@ -145,20 +138,19 @@ let installHaddockPlugin :: HscEnv -> HscEnv- installHaddockPlugin hsc_env = hsc_env- {- hsc_dflags =- gopt_set (hsc_dflags hsc_env) Opt_PluginTrustworthy- , hsc_static_plugins =- haddockPlugin : hsc_static_plugins hsc_env- }+ installHaddockPlugin hsc_env =+ let+ old_plugins = hsc_plugins hsc_env+ new_plugins = old_plugins { staticPlugins = haddockPlugin : staticPlugins old_plugins }+ hsc_env' = hsc_env { hsc_plugins = new_plugins }+ in hscUpdateFlags (flip gopt_set Opt_PluginTrustworthy) hsc_env' -- Note that we would rather use withTempSession but as long as we -- have the separate attachInstances step we need to keep the session -- alive to be able to find all the instances. modifySession installHaddockPlugin - targets <- mapM (\filePath -> guessTarget filePath Nothing) modules+ targets <- mapM (\filePath -> guessTarget filePath Nothing Nothing) modules setTargets targets loadOk <- withTimingM "load" (const ()) $@@ -173,13 +165,59 @@ moduleSet <- liftIO getModules let+ -- We topologically sort the module graph including boot files,+ -- so it should be acylic (hopefully we failed much earlier if this is not the case)+ -- We then filter out boot modules from the resultant topological sort+ --+ -- We do it this way to make 'buildHomeLinks' a bit more stable+ -- 'buildHomeLinks' depends on the topological order of its input in order+ -- to construct its result. In particular, modules closer to the bottom of+ -- the dependency chain are to be prefered for link destinations.+ --+ -- If there are cycles in the graph, then this order is indeterminate+ -- (the nodes in the cycle can be ordered in any way).+ -- While 'topSortModuleGraph' does guarantee stability for equivalent+ -- module graphs, seemingly small changes in the ModuleGraph can have+ -- big impacts on the `LinkEnv` constructed.+ --+ -- For example, suppose+ -- G1 = A.hs -> B.hs -> C.hs (where '->' denotes an import).+ --+ -- Then suppose C.hs is changed to have a cyclic dependency on A+ --+ -- G2 = A.hs -> B.hs -> C.hs -> A.hs-boot+ --+ -- For G1, `C.hs` is preferred for link destinations. However, for G2,+ -- the topologically sorted order not taking into account boot files (so+ -- C -> A) is completely indeterminate.+ -- Using boot files to resolve cycles, we end up with the original order+ -- [C, B, A] (in decreasing order of preference for links)+ --+ -- This exact case came up in testing for the 'base' package, where there+ -- is a big module cycle involving 'Prelude' on windows, but the cycle doesn't+ -- include 'Prelude' on non-windows platforms. This lead to drastically different+ -- LinkEnv's (and failing haddockHtmlTests) across the platforms+ --+ -- In effect, for haddock users this behaviour (using boot files to eliminate cycles)+ -- means that {-# SOURCE #-} imports no longer count towards re-ordering+ -- the preference of modules for linking.+ --+ -- i.e. if module A imports B, then B is preferred over A,+ -- but if module A {-# SOURCE #-} imports B, then we can't say the same.+ --+ go (AcyclicSCC (ModuleNode _ ms))+ | NotBoot <- isBootSummary ms = [ms]+ | otherwise = []+ go (AcyclicSCC _) = []+ go (CyclicSCC _) = error "haddock: module graph cyclic even with boot files"+ ifaces :: [Interface] ifaces = [ Map.findWithDefault (error "haddock:iface")- (ms_mod (emsModSummary ems))+ (ms_mod ms) ifaceMap- | ModuleNode ems <- flattenSCCs $ topSortModuleGraph True modGraph Nothing+ | ms <- concatMap go $ topSortModuleGraph False modGraph Nothing ] return (ifaces, moduleSet)@@ -212,7 +250,7 @@ | otherwise = do hsc_env <- getTopEnv ifaces <- liftIO $ readIORef ifaceMapRef- (iface, modules) <- withTiming (hsc_logger hsc_env) (hsc_dflags hsc_env)+ (iface, modules) <- withTiming (hsc_logger hsc_env) "processModule" (const ()) $ processModule1 verbosity flags ifaces instIfaceMap hsc_env mod_summary tc_gbl_env @@ -266,9 +304,8 @@ (!interface, messages) <- do logger <- getLogger- dflags <- getDynFlags {-# SCC createInterface #-}- withTiming logger dflags "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $+ withTiming logger "createInterface" (const ()) $ runIfM (fmap Just . tcLookupGlobal) $ createInterface1 flags unit_state mod_summary tc_gbl_env ifaces inst_ifaces @@ -318,7 +355,7 @@ ] where formatName :: SrcSpan -> HsDecl GhcRn -> String- formatName loc n = p (getMainDeclBinder n) ++ case loc of+ formatName loc n = p (getMainDeclBinder emptyOccEnv n) ++ case loc of RealSrcSpan rss _ -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> ""@@ -356,7 +393,7 @@ -- 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)+buildHomeLinks ifaces = foldl' upd Map.empty (reverse ifaces) where upd old_env iface | OptHide `elem` ifaceOptions iface = old_env
haddock-api/src/Haddock/Interface/AttachInstances.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -136,12 +135,12 @@ , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++- [ (n',f) | n <- getMainDeclBinder d+ [ (n',f) | n <- getMainDeclBinder emptyOccEnv d , n' <- n : (map fst subDocs ++ patsyn_names) , f <- maybeToList (getFixity n') ] } where- patsyn_names = concatMap (getMainDeclBinder . fst) patsyns+ patsyn_names = concatMap (getMainDeclBinder emptyOccEnv . fst) patsyns attachFixities e = e -- spanName: attach the location to the name that is the same file as the instance location
haddock-api/src/Haddock/Interface/Create.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wwarn #-}@@ -35,7 +34,7 @@ import Haddock.Convert (PrintRuntimeReps (..), tyThingToLHsDecl) import Haddock.GhcUtils (addClassContext, filterSigNames, lHsQTyVarsToTypes, mkEmptySigType, moduleString, parents, pretty, restrictTo, sigName, unL)-import Haddock.Interface.LexParseRn (processDocString, processDocStringParas, processDocStrings, processModuleHeader)+import Haddock.Interface.LexParseRn import Haddock.Options (Flag (..), modulePackageInfo) import Haddock.Types hiding (liftErrMsg) import Haddock.Utils (replace)@@ -55,36 +54,35 @@ import GHC hiding (lookupName) import GHC.Core.Class (ClassMinimalDef, classMinimalDef) import GHC.Core.ConLike (ConLike (..))-import GHC.Data.FastString (bytesFS, unpackFS)+import GHC.Data.FastString (unpackFS) import GHC.Driver.Ppr (showSDoc)-import GHC.HsToCore.Docs hiding (mkMaps)+import GHC.HsToCore.Docs hiding (mkMaps, unionArgMaps) import GHC.IORef (readIORef)-import GHC.Parser.Annotation (IsUnicodeSyntax (..)) import GHC.Stack (HasCallStack) import GHC.Tc.Types hiding (IfM) import GHC.Tc.Utils.Monad (finalSafeMode) import GHC.Types.Avail hiding (avail) import qualified GHC.Types.Avail as Avail import GHC.Types.Basic (PromotionFlag (..))-import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName)+import GHC.Types.Name (getOccString, getSrcSpan, isDataConName, isValName, nameIsLocalOrFrom, nameOccName, emptyOccEnv) import GHC.Types.Name.Env (lookupNameEnv) import GHC.Types.Name.Reader (GlobalRdrEnv, greMangledName, lookupGlobalRdrEnv) import GHC.Types.Name.Set (elemNameSet, mkNameSet) import GHC.Types.SourceFile (HscSource (..)) import GHC.Types.SourceText (SourceText (..), sl_fs)+import GHC.Unit.Types import qualified GHC.Types.SrcLoc as SrcLoc import qualified GHC.Unit.Module as Module import GHC.Unit.Module.ModSummary (msHsFilePath)-import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..)) import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits) import qualified GHC.Utils.Outputable as O import GHC.Utils.Panic (pprPanic)-import GHC.HsToCore.Docs hiding (mkMaps) import GHC.Unit.Module.Warnings+import GHC.Types.Unique.Map newtype IfEnv m = IfEnv {- -- | Lookup names in the enviroment.+ -- | Lookup names in the environment. ife_lookup_name :: Name -> m (Maybe TyThing) } @@ -257,7 +255,7 @@ -- Process the top-level module header documentation. (!info, header_doc) <- liftErrMsg $ processModuleHeader dflags pkg_name- tcg_rdr_env safety (thMbDocStr <|> (unLoc <$> tcg_doc_hdr))+ tcg_rdr_env safety (fmap hsDocString thMbDocStr <|> (hsDocString . unLoc <$> tcg_doc_hdr)) -- Warnings on declarations in this module decl_warnings <- liftErrMsg (mkWarningMap dflags tcg_warns tcg_rdr_env exported_names)@@ -266,7 +264,7 @@ mod_warning <- liftErrMsg (moduleWarning dflags tcg_rdr_env tcg_warns) let- -- Warnings in this module and transitive warnings from dependend modules+ -- Warnings in this module and transitive warnings from dependent modules warnings :: Map Name (Doc Name) warnings = M.unions (decl_warnings : map ifaceWarningMap (M.elems ifaces)) @@ -335,7 +333,7 @@ M.fromList $ mapMaybe (\(SrcLoc.L _ impDecl) -> do SrcLoc.L _ alias <- ideclAs impDecl- return $+ return (lookupModuleDyn state -- TODO: This is supremely dodgy, because in general the -- UnitId isn't going to look anything like the package@@ -351,8 +349,7 @@ -- them to the user. We should reuse that information; -- or at least reuse the renamed imports, which know what -- they import!- (fmap Module.fsToUnit $- fmap sl_fs $ ideclPkgQual impDecl)+ (ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias)) impDecls@@ -395,11 +392,11 @@ -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn ::- UnitState -> Maybe Unit -> ModuleName -> Module-lookupModuleDyn _ (Just pkgId) mdlName =- Module.mkModule pkgId mdlName-lookupModuleDyn state Nothing mdlName =- case lookupModuleInAllUnits state mdlName of+ UnitState -> PkgQual -> ModuleName -> Module+lookupModuleDyn state pkg_qual mdlName = case pkg_qual of+ OtherPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName+ ThisPkg uid -> Module.mkModule (RealUnit (Definite uid)) mdlName+ NoPkgQual -> case lookupModuleInAllUnits state mdlName of (m,_):_ -> m [] -> Module.mkModule Module.mainUnit mdlName @@ -408,7 +405,7 @@ -- Warnings ------------------------------------------------------------------------------- -mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap+mkWarningMap :: DynFlags -> Warnings a -> GlobalRdrEnv -> [Name] -> ErrMsgM WarningMap mkWarningMap dflags warnings gre exps = case warnings of NoWarnings -> pure M.empty WarnAll _ -> pure M.empty@@ -419,18 +416,18 @@ , let n = greMangledName elt, n `elem` exps ] in M.fromList <$> traverse (bitraverse pure (parseWarning dflags gre)) ws' -moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> ErrMsgM (Maybe (Doc Name))+moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings a -> ErrMsgM (Maybe (Doc Name)) moduleWarning _ _ NoWarnings = pure Nothing moduleWarning _ _ (WarnSome _) = pure Nothing moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w -parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name)+parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt a -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of- DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (bytesFS . sl_fs . unLoc) msg)- WarningTxt _ msg -> format "Warning: " (foldMap (bytesFS . sl_fs . unLoc) msg)+ DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg)+ WarningTxt _ msg -> format "Warning: " (foldMap (unpackFS . sl_fs . hsDocString . unLoc) msg) where format x bs = DocWarning . DocParagraph . DocAppend (DocString x)- <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs)+ <$> processDocStringFromString dflags gre bs -------------------------------------------------------------------------------@@ -482,7 +479,7 @@ -> Maybe Package -- this package -> GlobalRdrEnv -> [Name]- -> [(LHsDecl GhcRn, [HsDocString])]+ -> [(LHsDecl GhcRn, [HsDoc GhcRn])] -> ExtractedTHDocs -- ^ Template Haskell putDoc docs -> ErrMsgM Maps mkMaps dflags pkgName gre instances decls thDocs = do@@ -515,36 +512,40 @@ thMappings = do let ExtractedTHDocs _- (DeclDocMap declDocs)- (ArgDocMap argDocs)- (DeclDocMap instDocs) = thDocs- ds2mdoc :: HsDocString -> ErrMsgM (MDoc Name)- ds2mdoc = processDocStringParas dflags pkgName gre+ declDocs+ argDocs+ instDocs = thDocs+ ds2mdoc :: (HsDoc GhcRn) -> ErrMsgM (MDoc Name)+ ds2mdoc = processDocStringParas dflags pkgName gre . hsDocString - declDocs' <- mapM ds2mdoc declDocs- argDocs' <- mapM (mapM ds2mdoc) argDocs- instDocs' <- mapM ds2mdoc instDocs+ let cvt = M.fromList . nonDetEltsUniqMap++ declDocs' <- mapM ds2mdoc (cvt declDocs)+ argDocs' <- mapM (mapM ds2mdoc) (cvt argDocs)+ instDocs' <- mapM ds2mdoc (cvt instDocs) return (declDocs' <> instDocs', argDocs') - mappings :: (LHsDecl GhcRn, [HsDocString])+ mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, IntMap (MDoc Name))] , [(Name, [LHsDecl GhcRn])] )- mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do- let declDoc :: [HsDocString] -> IntMap HsDocString+ mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), hs_docStrs) = do+ let docStrs = map hsDocString hs_docStrs+ declDoc :: [HsDocString] -> IntMap HsDocString -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name)) declDoc strs m = do doc' <- processDocStrings dflags pkgName gre strs m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (declTypeDocs decl)+ (doc, args) <- declDoc docStrs (fmap hsDocString (declTypeDocs decl)) let subs :: [(Name, [HsDocString], IntMap HsDocString)]- subs = subordinates instanceMap decl+ subs = map (\(n, ds, im) -> (n, map hsDocString ds, fmap hsDocString im))+ $ subordinates emptyOccEnv instanceMap decl (subDocs, subArgs) <- unzip <$> traverse (\(_, strs, m) -> declDoc strs m) subs @@ -575,8 +576,24 @@ TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d') _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].- names _ decl = getMainDeclBinder decl+ names _ decl = getMainDeclBinder emptyOccEnv decl +-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two+-- maps with values for the same key merge the inner map as well.+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.++unionArgMaps :: forall b . Map Name (IntMap b)+ -> Map Name (IntMap b)+ -> Map Name (IntMap b)+unionArgMaps a b = M.foldrWithKey go b a+ where+ go :: Name -> IntMap b+ -> Map Name (IntMap b) -> Map Name (IntMap b)+ go n newArgMap acc+ | Just oldArgMap <- M.lookup n acc =+ M.insert n (newArgMap `IM.union` oldArgMap) acc+ | otherwise = M.insert n newArgMap acc+ -- Note [2]: ------------ -- We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried@@ -637,11 +654,11 @@ Just exports -> liftM concat $ mapM lookupExport exports where lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do- doc <- processDocString dflags gre docStr+ doc <- processDocString dflags gre (hsDocString . unLoc $ docStr) return [ExportGroup lev "" doc] lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do- doc <- processDocStringParas dflags pkgName gre docStr+ doc <- processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr) return [ExportDoc doc] lookupExport (IEDocNamed _ str, _) = liftErrMsg $@@ -709,7 +726,7 @@ export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->- let declNames = getMainDeclBinder (unL decl)+ let declNames = getMainDeclBinder emptyOccEnv (unL decl) in case () of _ -- We should not show a subordinate by itself if any of its@@ -788,7 +805,7 @@ let patSynNames =- concatMap (getMainDeclBinder . fst) bundledPatSyns+ concatMap (getMainDeclBinder emptyOccEnv . fst) bundledPatSyns fixities = [ (n, f)@@ -1010,17 +1027,17 @@ (concat . concat) `fmap` (for decls $ \decl -> do case decl of (L _ (DocD _ (DocGroup lev docStr))) -> do- doc <- liftErrMsg (processDocString dflags gre docStr)+ doc <- liftErrMsg (processDocString dflags gre (hsDocString . unLoc $ docStr)) return [[ExportGroup lev "" doc]] (L _ (DocD _ (DocCommentNamed _ docStr))) -> do- doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr)+ doc <- liftErrMsg (processDocStringParas dflags pkgName gre (hsDocString . unLoc $ docStr)) return [[ExportDoc doc]] (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders CollNoDictBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] _ ->- for (getMainDeclBinder (unLoc decl)) $ \nm -> do+ for (getMainDeclBinder emptyOccEnv (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail -> availExportItem is_sig modMap thisMod@@ -1045,7 +1062,7 @@ -> LHsDecl GhcRn -- ^ parent declaration -> Either ErrMsg (LHsDecl GhcRn) extractDecl declMap name decl- | name `elem` getMainDeclBinder (unLoc decl) = pure decl+ | name `elem` getMainDeclBinder emptyOccEnv (unLoc decl) = pure decl | otherwise = case unLoc decl of TyClD _ d@ClassDecl { tcdLName = L _ clsNm@@ -1113,15 +1130,14 @@ , Just rec <- map (getRecConArgs_maybe . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns- , extFieldOcc n == name+ , foExt n == name ] in case matches of [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0) _ -> Left "internal: extractDecl (ClsInstD)" _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) -extractPatternSyn :: HasCallStack- => Name -> Name+extractPatternSyn :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn] -> Either ErrMsg (LSig GhcRn) extractPatternSyn nm t tvs cons =@@ -1142,17 +1158,17 @@ InfixCon arg1 arg2 -> map hsScaledThing [arg1, arg2] ConDeclGADT { con_g_args = con_args' } -> case con_args' of PrefixConGADT args' -> map hsScaledThing args'- RecConGADT (L _ fields) -> cd_fld_type . unLoc <$> fields+ RecConGADT (L _ fields) _ -> cd_fld_type . unLoc <$> fields typ = longArrow args (data_ty con) typ' = case con of- ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)+ ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField cxt typ) _ -> typ- typ'' = noLocA (HsQualTy noExtField Nothing typ')+ typ'' = noLocA (HsQualTy noExtField (noLocA []) typ') in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn- longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs+ longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con@@ -1169,12 +1185,12 @@ extractRecSel nm t tvs (L _ con : rest) = case getRecConArgs_maybe con of Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields ->- pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))+ pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) data_ty (getBangType ty)))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]- matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds- , L l n <- ns, extFieldOcc n == nm ]+ matching_fields flds = [ (locA l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds+ , L l n <- ns, foExt n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con@@ -1200,10 +1216,10 @@ where exportName e@ExportDecl {} = name ++ subs ++ patsyns where subs = map fst (expItemSubDocs e)- patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e)+ patsyns = concatMap (getMainDeclBinder emptyOccEnv . fst) (expItemPats e) name = case unLoc $ expItemDecl e of InstD _ d -> maybeToList $ SrcLoc.lookupSrcSpan (getInstLoc d) instMap- decl -> getMainDeclBinder decl+ decl -> getMainDeclBinder emptyOccEnv decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = []@@ -1220,6 +1236,7 @@ tell ["Cannot find documentation for: $" ++ name] return Nothing search (DocD _ (DocCommentNamed name' doc) : rest)- | name == name' = return (Just doc)+ | name == name' = return (Just (hsDocString . unLoc $ doc))+ | otherwise = search rest search (_other_decl : rest) = search rest
haddock-api/src/Haddock/Interface/Json.hs view
@@ -130,8 +130,10 @@ jsonDoc (DocOrderedList xs) = jsonObject [ ("tag", jsonString "DocOrderedList")- , ("documents", jsonArray (fmap jsonDoc xs))+ , ("items", jsonArray (fmap jsonItem xs)) ]+ where+ jsonItem (index, a) = jsonObject [("document", jsonDoc a), ("seq", jsonInt index)] jsonDoc (DocDefList xys) = jsonObject [ ("tag", jsonString "DocDefList")
haddock-api/src/Haddock/Interface/LexParseRn.hs view
@@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn ( processDocString+ , processDocStringFromString , processDocStringParas , processDocStrings , processModuleHeader@@ -52,12 +53,16 @@ processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) processDocStringParas dflags pkg gre hds =- overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds)+ overDocF (rename dflags gre) $ parseParas dflags pkg (renderHsDocString hds) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) processDocString dflags gre hds =- rename dflags gre $ parseString dflags (unpackHDS hds)+ processDocStringFromString dflags gre (renderHsDocString hds) +processDocStringFromString :: DynFlags -> GlobalRdrEnv -> String -> ErrMsgM (Doc Name)+processDocStringFromString dflags gre hds =+ rename dflags gre $ parseString dflags hds+ processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe HsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags pkgName gre safety mayStr = do@@ -65,7 +70,7 @@ case mayStr of Nothing -> return failure Just hds -> do- let str = unpackHDS hds+ let str = renderHsDocString hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr@@ -84,6 +89,10 @@ where failure = (emptyHaddockModInfo, Nothing) +traverseSnd :: (Traversable t, Applicative f) => (a -> f b) -> t (x, a) -> f (t (x, b))+traverseSnd f = traverse (\(x, a) ->+ (\b -> (x, b)) <$> f a)+ -- | Takes a 'GlobalRdrEnv' which (hopefully) contains all the -- definitions and a parsed comment and we attempt to make sense of -- where the identifiers in the comment point to. We're in effect@@ -146,7 +155,7 @@ DocBold doc -> DocBold <$> rn doc DocMonospaced doc -> DocMonospaced <$> rn doc DocUnorderedList docs -> DocUnorderedList <$> traverse rn docs- DocOrderedList docs -> DocOrderedList <$> traverse rn docs+ DocOrderedList docs -> DocOrderedList <$> traverseSnd rn docs DocDefList list -> DocDefList <$> traverse (\(a, b) -> (,) <$> rn a <*> rn b) list DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x)@@ -167,7 +176,7 @@ -- 'GlobalReaderEnv' during 'rename') in an appropriate doc. Currently -- we simply monospace the identifier in most cases except when the -- identifier is qualified: if the identifier is qualified then we can--- still try to guess and generate anchors accross modules but the+-- still try to guess and generate anchors across modules but the -- users shouldn't rely on this doing the right thing. See tickets -- #253 and #375 on the confusion this causes depending on which -- default we pick in 'rename'.
haddock-api/src/Haddock/Interface/Rename.hs view
@@ -191,8 +191,8 @@ Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning -renameLDocHsSyn :: LHsDocString -> RnM LHsDocString-renameLDocHsSyn = return+renameLDocHsSyn :: Located (WithHsDocIdentifiers HsDocString a) -> RnM (Located (WithHsDocIdentifiers HsDocString b))+renameLDocHsSyn (L l doc) = return (L l (WithHsDocIdentifiers (hsDocString doc) [])) renameDoc :: Traversable t => t (Wrap Name) -> RnM (t (Wrap DocName))@@ -245,9 +245,10 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)-renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u)-renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a)-renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p+renameArrow (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr)+renameArrow (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr))+renameArrow (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr))+renameArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of@@ -258,7 +259,7 @@ , hst_tele = tele', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do- lcontext' <- traverse renameLContext lcontext+ lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) @@ -289,11 +290,11 @@ HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts - HsOpTy _ a (L loc op) b -> do+ HsOpTy _ prom a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b- return (HsOpTy noAnn a' (L loc op') b')+ return (HsOpTy noAnn prom a' (L loc op') b') HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty @@ -316,6 +317,7 @@ HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy _ -> pure (HsWildCardTy noAnn) + renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI) renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do bndrs' <- renameOuterTyVarBndrs bndrs@@ -505,15 +507,15 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars , con_mb_cxt = lcontext, con_args = details , con_doc = mbldoc- , con_forall = forall }) = do+ , con_forall = forall_ }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameH98Details details- mbldoc' <- mapM renameLDocHsSyn mbldoc+ mbldoc' <- mapM (renameLDocHsSyn) mbldoc return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext'- , con_forall = forall -- Remove when #18311 is fixed+ , con_forall = forall_ -- Remove when #18311 is fixed , con_args = details', con_doc = mbldoc' }) renameCon ConDeclGADT { con_names = lnames, con_bndrs = bndrs@@ -548,9 +550,9 @@ renameGADTDetails :: HsConDeclGADTDetails GhcRn -> RnM (HsConDeclGADTDetails DocNameI)-renameGADTDetails (RecConGADT (L l fields)) = do+renameGADTDetails (RecConGADT (L l fields) arr) = do fields' <- mapM renameConDeclFieldField fields- return (RecConGADT (L (locA l) fields'))+ return (RecConGADT (L (locA l) fields') arr) renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
haddock-api/src/Haddock/Interface/Specialize.hs view
@@ -132,9 +132,9 @@ sugarOperators :: HsType GhcRn -> HsType GhcRn-sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)- | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb- | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ prom (L l name))) la)) lb)+ | isSymOcc $ getOccName name' = mkHsOpTy prom la (L l name) lb+ | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) la lb where name' = getName name sugarOperators typ = typ@@ -283,7 +283,7 @@ <*> renameLType lt renameType (HsQualTy x lctxt lt) = HsQualTy x- <$> renameMContext lctxt+ <$> renameLContext lctxt <*> renameLType lt renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name renameType t@(HsStarTy _ _) = pure t@@ -293,8 +293,8 @@ renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt-renameType (HsOpTy x la lop lb) =- HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb+renameType (HsOpTy x prom la lop lb) =+ HsOpTy x prom <$> renameLType la <*> locatedN renameName lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk@@ -311,7 +311,7 @@ renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn)-renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p+renameHsArrow (HsExplicitMult pct p arr) = (\p' -> HsExplicitMult pct p' arr) <$> renameLType p renameHsArrow mult = pure mult @@ -324,11 +324,10 @@ renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType -renameMContext :: Maybe (LHsContext GhcRn) -> Rename (IdP GhcRn) (Maybe (LHsContext GhcRn))-renameMContext Nothing = return Nothing-renameMContext (Just (L l ctxt)) = do+renameLContext :: LHsContext GhcRn -> Rename (IdP GhcRn) (LHsContext GhcRn)+renameLContext (L l ctxt) = do ctxt' <- renameContext ctxt- return (Just (L l ctxt'))+ return (L l ctxt') renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes
haddock-api/src/Haddock/InterfaceFile.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -15,43 +16,71 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile (- InterfaceFile(..), ifUnitId, ifModule,- readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,- writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility+ InterfaceFile(..), PackageInfo(..), ifUnitId, ifModule,+ PackageInterfaces(..), mkPackageInterfaces, ppPackageInfo,+ readInterfaceFile, writeInterfaceFile,+ freshNameCache,+ binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where import Haddock.Types -import Control.Monad-import Control.Monad.IO.Class ( MonadIO(..) )-import Data.Array import Data.IORef-import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map)+import Data.Version import Data.Word+import Text.ParserCombinators.ReadP (readP_to_S) -import GHC.Iface.Binary (getSymtabName, getDictFastString)+import GHC.Iface.Binary (getWithUserData, putSymbolTable)+import GHC.Unit.State import GHC.Utils.Binary import GHC.Data.FastMutInt import GHC.Data.FastString import GHC hiding (NoLink)-import GHC.Driver.Monad (withSession)-import GHC.Driver.Env import GHC.Types.Name.Cache-import GHC.Iface.Env-import GHC.Types.Name import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply import GHC.Types.Unique +import Haddock.Options (Visibility (..))+ data InterfaceFile = InterfaceFile { ifLinkEnv :: LinkEnv,+ -- | Package meta data. Currently it only consist of a package name, which+ -- is not read from the interface file, but inferred from its name.+ --+ -- issue #+ ifPackageInfo :: PackageInfo, ifInstalledIfaces :: [InstalledInterface] } +data PackageInfo = PackageInfo {+ piPackageName :: PackageName,+ piPackageVersion :: Data.Version.Version+} +ppPackageInfo :: PackageInfo -> String+ppPackageInfo (PackageInfo name version) | version == makeVersion []+ = unpackFS (unPackageName name)+ppPackageInfo (PackageInfo name version) = unpackFS (unPackageName name) ++ "-" ++ showVersion version++data PackageInterfaces = PackageInterfaces {+ piPackageInfo :: PackageInfo,+ piVisibility :: Visibility,+ piInstalledInterfaces :: [InstalledInterface]+}++mkPackageInterfaces :: Visibility -> InterfaceFile -> PackageInterfaces+mkPackageInterfaces piVisibility+ InterfaceFile { ifPackageInfo+ , ifInstalledIfaces+ } = + PackageInterfaces { piPackageInfo = ifPackageInfo+ , piVisibility+ , piInstalledInterfaces = ifInstalledIfaces+ }+ ifModule :: InterfaceFile -> Module ifModule if_ = case ifInstalledIfaces if_ of@@ -94,11 +123,11 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,3,0)-binaryInterfaceVersion = 38+#if MIN_VERSION_ghc(9,4,0) && !MIN_VERSION_ghc(9,5,0)+binaryInterfaceVersion = 41 binaryInterfaceVersionCompatibility :: [Word16]-binaryInterfaceVersionCompatibility = [37, binaryInterfaceVersion]+binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] #else #error Unsupported GHC version #endif@@ -138,7 +167,7 @@ let bh = setUserData bh0 $ newWriteState (putName bin_symtab) (putName bin_symtab) (putFastString bin_dict)- put_ bh iface+ putInterfaceFile_ bh iface -- write the symtab pointer at the front of the file symtab_p <- tellBin bh@@ -165,103 +194,31 @@ return () -type NameCacheAccessor m = (m NameCache, NameCache -> m ())---nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m-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 [])-+freshNameCache :: IO NameCache+freshNameCache = initNameCache 'a' -- ??+ [] -- | 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+-- a new empty name cache is used.+readInterfaceFile :: NameCache -> FilePath -> Bool -- ^ Disable version check. Can cause runtime crash.- -> m (Either String InterfaceFile)-readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = 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- | not bypass_checks- , (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)+ -> IO (Either String InterfaceFile)+readInterfaceFile name_cache filename bypass_checks = do+ bh <- readBinMem filename + magic <- get bh+ if magic /= binaryInterfaceMagic+ then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename+ else do+ version <- get bh+ if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility)+ then return . Left $ "Interface file is of wrong version: " ++ filename+ else Right <$> getWithUserData name_cache bh ------------------------------------------------------------------------------- -- * Symbol table@@ -312,56 +269,6 @@ -- indexed by FastString } --putSymbolTable :: BinHandle -> Int -> UniqFM Name (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 = (Unit, 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 Name (Int,Name) -> IO ()-serialiseName bh name _ = do- let modu = nameModule name- put_ bh (moduleUnit modu, moduleName modu, nameOccName name)-- ------------------------------------------------------------------------------- -- * GhcBinary instances -------------------------------------------------------------------------------@@ -371,17 +278,36 @@ put_ bh m = put_ bh (Map.toList m) get bh = fmap (Map.fromList) (get bh) +instance Binary PackageInfo where+ put_ bh PackageInfo { piPackageName, piPackageVersion } = do+ put_ bh (unPackageName piPackageName)+ put_ bh (showVersion piPackageVersion)+ get bh = do+ name <- PackageName <$> get bh+ versionString <- get bh+ let version = case readP_to_S parseVersion versionString of+ [] -> makeVersion []+ vs -> fst (last vs)+ return $ PackageInfo name version instance Binary InterfaceFile where- put_ bh (InterfaceFile env ifaces) = do+ put_ bh (InterfaceFile env info ifaces) = do put_ bh env+ put_ bh info put_ bh ifaces get bh = do env <- get bh+ info <- get bh ifaces <- get bh- return (InterfaceFile env ifaces)+ return (InterfaceFile env info ifaces) ++putInterfaceFile_ :: BinHandle -> InterfaceFile -> IO ()+putInterfaceFile_ bh (InterfaceFile env info ifaces) = do+ put_ bh env+ put_ bh info+ put_ bh ifaces instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap
haddock-api/src/Haddock/Options.hs view
@@ -15,6 +15,7 @@ module Haddock.Options ( parseHaddockOpts, Flag(..),+ Visibility(..), getUsage, optTitle, outputDir,@@ -24,6 +25,7 @@ optSourceCssFile, sourceUrls, wikiUrls,+ baseUrl, optParCount, optDumpInterfaceFile, optShowInterfaceFile,@@ -72,6 +74,7 @@ | Flag_SourceEntityURL String | Flag_SourceLEntityURL String | Flag_WikiBaseURL String+ | Flag_BaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_LaTeX@@ -157,6 +160,8 @@ "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 [] ["base-url"] (ReqArg Flag_BaseURL "URL")+ "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.", 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")@@ -301,6 +306,9 @@ ,optLast [str | Flag_WikiEntityURL str <- flags]) +baseUrl :: [Flag] -> Maybe String+baseUrl flags = optLast [str | Flag_BaseURL str <- flags]+ optDumpInterfaceFile :: [Flag] -> Maybe FilePath optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] @@ -354,18 +362,31 @@ reexportFlags :: [Flag] -> [String] reexportFlags flags = [ option | Flag_Reexport option <- flags ] +data Visibility = Visible | Hidden+ deriving (Eq, Show) -readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)]+readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)] readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] where- parseIfaceOption :: String -> (DocPaths, FilePath)+ parseIfaceOption :: String -> (DocPaths, Visibility, 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)+ (src, ',':rest') ->+ let src' = case src of+ "" -> Nothing+ _ -> Just src+ in+ case break (==',') rest' of+ (visibility, ',':file) | visibility == "hidden" ->+ ((fpath, src'), Hidden, file)+ | otherwise ->+ ((fpath, src'), Visible, file)+ (file, _) ->+ ((fpath, src'), Visible, file)+ (file, _) -> ((fpath, Nothing), Visible, file)+ (file, _) -> (("", Nothing), Visible, file) -- | Like 'listToMaybe' but returns the last element instead of the first.
haddock-api/src/Haddock/Parser.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ViewPatterns #-} -- | -- Module : Haddock.Parser -- Copyright : (c) Mateusz Kowalczyk 2013,@@ -19,7 +18,7 @@ import Haddock.Types import GHC.Driver.Session ( DynFlags )-import GHC.Driver.Config+import GHC.Driver.Config.Parser (initParserOpts) import GHC.Data.FastString ( fsLit ) import GHC.Parser.Lexer ( initParserState, unP, ParseResult(POk, PFailed) ) import GHC.Parser ( parseIdentifier )
haddock-api/src/Haddock/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-}@@ -150,7 +151,7 @@ -- | Warnings for things defined in this module. , ifaceWarningMap :: !WarningMap - -- | Tokenized source code of module (avaliable if Haddock is invoked with+ -- | Tokenized source code of module (available if Haddock is invoked with -- source generation flag). , ifaceHieFile :: !(Maybe FilePath) , ifaceDynFlags :: !DynFlags@@ -319,7 +320,8 @@ type instance IdP DocNameI = DocName instance CollectPass DocNameI where- collectXXPat _ _ ext = noExtCon ext+ collectXXPat _ ext = dataConCantHappen ext+ collectXXHsBindsLR ext = dataConCantHappen ext instance NamedThing DocName where getName (Documented name _) = name@@ -709,8 +711,8 @@ type instance Anno [LocatedA (HsType DocNameI)] = SrcSpanAnnC type instance Anno (HsType DocNameI) = SrcSpanAnnA type instance Anno (DataFamInstDecl DocNameI) = SrcSpanAnnA-type instance Anno (DerivStrategy DocNameI) = SrcSpan-type instance Anno (FieldOcc DocNameI) = SrcSpan+type instance Anno (DerivStrategy DocNameI) = SrcAnn NoEpAnns+type instance Anno (FieldOcc DocNameI) = SrcAnn NoEpAnns type instance Anno (ConDeclField DocNameI) = SrcSpan type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan@@ -720,9 +722,9 @@ type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL type instance Anno (FamilyDecl DocNameI) = SrcSpan type instance Anno (Sig DocNameI) = SrcSpan-type instance Anno (InjectivityAnn DocNameI) = SrcSpan+type instance Anno (InjectivityAnn DocNameI) = SrcAnn NoEpAnns type instance Anno (HsDecl DocNameI) = SrcSpanAnnA-type instance Anno (FamilyResultSig DocNameI) = SrcSpan+type instance Anno (FamilyResultSig DocNameI) = SrcAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA @@ -760,11 +762,11 @@ type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField-type instance XXHsForAllTelescope DocNameI = NoExtCon+type instance XXHsForAllTelescope DocNameI = DataConCantHappen type instance XUserTyVar DocNameI = NoExtField type instance XKindedTyVar DocNameI = NoExtField-type instance XXTyVarBndr DocNameI = NoExtCon+type instance XXTyVarBndr DocNameI = DataConCantHappen type instance XCFieldOcc DocNameI = DocName type instance XXFieldOcc DocNameI = NoExtField@@ -780,7 +782,7 @@ type instance XForeignImport DocNameI = NoExtField type instance XConDeclGADT DocNameI = NoExtField type instance XConDeclH98 DocNameI = NoExtField-type instance XXConDecl DocNameI = NoExtCon+type instance XXConDecl DocNameI = DataConCantHappen type instance XDerivD DocNameI = NoExtField type instance XInstD DocNameI = NoExtField@@ -791,10 +793,10 @@ type instance XNoSig DocNameI = NoExtField type instance XCKindSig DocNameI = NoExtField type instance XTyVarSig DocNameI = NoExtField-type instance XXFamilyResultSig DocNameI = NoExtCon+type instance XXFamilyResultSig DocNameI = DataConCantHappen type instance XCFamEqn DocNameI _ = NoExtField-type instance XXFamEqn DocNameI _ = NoExtCon+type instance XXFamEqn DocNameI _ = DataConCantHappen type instance XCClsInstDecl DocNameI = NoExtField type instance XCDerivDecl DocNameI = NoExtField@@ -811,23 +813,24 @@ type instance XDataDecl DocNameI = NoExtField type instance XSynDecl DocNameI = NoExtField type instance XFamDecl DocNameI = NoExtField-type instance XXFamilyDecl DocNameI = NoExtCon-type instance XXTyClDecl DocNameI = NoExtCon+type instance XXFamilyDecl DocNameI = DataConCantHappen+type instance XXTyClDecl DocNameI = DataConCantHappen type instance XHsWC DocNameI _ = NoExtField type instance XHsOuterExplicit DocNameI _ = NoExtField type instance XHsOuterImplicit DocNameI = NoExtField-type instance XXHsOuterTyVarBndrs DocNameI = NoExtCon+type instance XXHsOuterTyVarBndrs DocNameI = DataConCantHappen type instance XHsSig DocNameI = NoExtField-type instance XXHsSigType DocNameI = NoExtCon+type instance XXHsSigType DocNameI = DataConCantHappen type instance XHsQTvs DocNameI = NoExtField type instance XConDeclField DocNameI = NoExtField-type instance XXConDeclField DocNameI = NoExtCon+type instance XXConDeclField DocNameI = DataConCantHappen -type instance XXPat DocNameI = NoExtCon+type instance XXPat DocNameI = DataConCantHappen+type instance XXHsBindsLR DocNameI a = DataConCantHappen type instance XCInjectivityAnn DocNameI = NoExtField
haddock-api/src/Haddock/Utils/Json.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} -- | Minimal JSON / RFC 7159 support --@@ -12,35 +13,53 @@ , encodeToString , encodeToBuilder , ToJSON(toJSON)++ , Parser(..)+ , Result(..)+ , FromJSON(parseJSON)+ , withObject+ , withArray+ , withString+ , withDouble+ , withBool+ , fromJSON+ , parse+ , parseEither+ , (.:)+ , (.:?)+ , decode+ , decodeWith+ , eitherDecode+ , eitherDecodeWith+ , decodeFile+ , eitherDecodeFile ) where +import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus (..), zipWithM, (>=>))+import qualified Control.Monad as Monad+import qualified Control.Monad.Fail as Fail++import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BB import Data.Char import Data.Int-import Data.String import Data.Word import Data.List (intersperse) import Data.Monoid -import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BB+import GHC.Natural -- TODO: We may want to replace 'String' with 'Text' or 'ByteString' --- | A JSON value represented as a Haskell value.-data Value = Object !Object- | Array [Value]- | String String- | Number !Double- | Bool !Bool- | Null- deriving (Eq, Read, Show)+import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy+import qualified Text.ParserCombinators.Parsec as Parsec --- | A key\/value pair for an 'Object'-type Pair = (String, Value)+import Haddock.Utils.Json.Types+import Haddock.Utils.Json.Parser --- | A JSON \"object\" (key/value map).-type Object = [Pair] infixr 8 .= @@ -48,14 +67,7 @@ (.=) :: ToJSON v => String -> v -> Pair k .= v = (k, toJSON v) --- | Create a 'Value' from a list of name\/value 'Pair's.-object :: [Pair] -> Value-object = Object -instance IsString Value where- fromString = String-- -- | A type that can be converted to JSON. class ToJSON a where -- | Convert a Haskell value to a JSON-friendly intermediate type.@@ -223,3 +235,324 @@ -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF needsEscape c = ord c < 0x20 || c `elem` ['\\','"']++------------------------------------------------------------------------------+-- FromJSON++-- | Elements of a JSON path used to describe the location of an+-- error.+data JSONPathElement+ = Key String+ -- ^ JSON path element of a key into an object,+ -- \"object.key\".+ | Index !Int+ -- ^ JSON path element of an index into an+ -- array, \"array[index]\".+ deriving (Eq, Show, Ord)++type JSONPath = [JSONPathElement]++-- | Failure continuation.+type Failure f r = JSONPath -> String -> f r++-- | Success continuation.+type Success a f r = a -> f r++newtype Parser a = Parser {+ runParser :: forall f r.+ JSONPath+ -> Failure f r+ -> Success a f r+ -> f r+ }++modifyFailure :: (String -> String) -> Parser a -> Parser a+modifyFailure f (Parser p) = Parser $ \path kf ks ->+ p path (\p' m -> kf p' (f m)) ks++prependFailure :: String -> Parser a -> Parser a+prependFailure = modifyFailure . (++)++prependContext :: String -> Parser a -> Parser a+prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")++typeMismatch :: String -> Value -> Parser a+typeMismatch expected actual =+ fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual++instance Monad.Monad Parser where+ m >>= g = Parser $ \path kf ks ->+ runParser m path kf+ (\a -> runParser (g a) path kf ks)+ return = pure++instance Fail.MonadFail Parser where+ fail msg = Parser $ \path kf _ks -> kf (reverse path) msg++instance Functor Parser where+ fmap f m = Parser $ \path kf ks ->+ let ks' a = ks (f a)+ in runParser m path kf ks'++instance Applicative Parser where+ pure a = Parser $ \_path _kf ks -> ks a+ (<*>) = apP++instance Alternative Parser where+ empty = fail "empty"+ (<|>) = mplus++instance MonadPlus Parser where+ mzero = fail "mzero"+ mplus a b = Parser $ \path kf ks ->+ runParser a path (\_ _ -> runParser b path kf ks) ks++instance Semigroup (Parser a) where+ (<>) = mplus++instance Monoid (Parser a) where+ mempty = fail "mempty"+ mappend = (<>)++apP :: Parser (a -> b) -> Parser a -> Parser b+apP d e = do+ b <- d+ b <$> e++(<?>) :: Parser a -> JSONPathElement -> Parser a+p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks++parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a+parseIndexedJSON p idx value = p value <?> Index idx++unexpected :: Value -> Parser a+unexpected actual = fail $ "unexpected " ++ typeOf actual++withObject :: String -> (Object -> Parser a) -> Value -> Parser a+withObject _ f (Object obj) = f obj+withObject name _ v = prependContext name (typeMismatch "Object" v)++withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a+withArray _ f (Array arr) = f arr+withArray name _ v = prependContext name (typeMismatch "Array" v)++withString :: String -> (String -> Parser a) -> Value -> Parser a+withString _ f (String txt) = f txt+withString name _ v = prependContext name (typeMismatch "String" v)++withDouble :: String -> (Double -> Parser a) -> Value -> Parser a+withDouble _ f (Number duble) = f duble+withDouble name _ v = prependContext name (typeMismatch "Number" v)++withBool :: String -> (Bool -> Parser a) -> Value -> Parser a+withBool _ f (Bool arr) = f arr+withBool name _ v = prependContext name (typeMismatch "Boolean" v)++class FromJSON a where+ parseJSON :: Value -> Parser a++ parseJSONList :: Value -> Parser [a]+ parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..])++instance FromJSON Bool where+ parseJSON (Bool b) = pure b+ parseJSON v = typeMismatch "Bool" v++instance FromJSON () where+ parseJSON =+ withArray "()" $ \v ->+ if null v+ then pure ()+ else prependContext "()" $ fail "expected an empty array"++instance FromJSON Char where+ parseJSON = withString "Char" parseChar++ parseJSONList (String s) = pure s+ parseJSONList v = typeMismatch "String" v++parseChar :: String -> Parser Char+parseChar t =+ if length t == 1+ then pure $ head t+ else prependContext "Char" $ fail "expected a string of length 1"++parseRealFloat :: RealFloat a => String -> Value -> Parser a+parseRealFloat _ (Number s) = pure $ realToFrac s+parseRealFloat _ Null = pure (0/0)+parseRealFloat name v = prependContext name (unexpected v)++instance FromJSON Double where+ parseJSON = parseRealFloat "Double"++instance FromJSON Float where+ parseJSON = parseRealFloat "Float"++parseNatural :: Integer -> Parser Natural+parseNatural integer =+ if integer < 0 then+ fail $ "parsing Natural failed, unexpected negative number " <> show integer+ else+ pure $ fromIntegral integer++parseIntegralFromDouble :: Integral a => Double -> Parser a+parseIntegralFromDouble d =+ let r = toRational d+ x = truncate r+ in if toRational x == r+ then pure x+ else fail $ "unexpected floating number " <> show d++parseIntegral :: Integral a => String -> Value -> Parser a+parseIntegral name = withDouble name parseIntegralFromDouble++instance FromJSON Integer where+ parseJSON = parseIntegral "Integer"++instance FromJSON Natural where+ parseJSON = withDouble "Natural"+ (parseIntegralFromDouble >=> parseNatural)++instance FromJSON Int where+ parseJSON = parseIntegral "Int"++instance FromJSON Int8 where+ parseJSON = parseIntegral "Int8"++instance FromJSON Int16 where+ parseJSON = parseIntegral "Int16"++instance FromJSON Int32 where+ parseJSON = parseIntegral "Int32"++instance FromJSON Int64 where+ parseJSON = parseIntegral "Int64"++instance FromJSON Word where+ parseJSON = parseIntegral "Word"++instance FromJSON Word8 where+ parseJSON = parseIntegral "Word8"++instance FromJSON Word16 where+ parseJSON = parseIntegral "Word16"++instance FromJSON Word32 where+ parseJSON = parseIntegral "Word32"++instance FromJSON Word64 where+ parseJSON = parseIntegral "Word64"++instance FromJSON a => FromJSON [a] where+ parseJSON = parseJSONList++data Result a = Error String+ | Success a+ deriving (Eq, Show)++fromJSON :: FromJSON a => Value -> Result a+fromJSON = parse parseJSON++parse :: (a -> Parser b) -> a -> Result b+parse m v = runParser (m v) [] (const Error) Success++parseEither :: (a -> Parser b) -> a -> Either String b+parseEither m v = runParser (m v) [] onError Right+ where onError path msg = Left (formatError path msg)++formatError :: JSONPath -> String -> String+formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg++formatPath :: JSONPath -> String+formatPath path = "$" ++ formatRelativePath path++formatRelativePath :: JSONPath -> String+formatRelativePath path = format "" path+ where+ format :: String -> JSONPath -> String+ format pfx [] = pfx+ format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts+ format pfx (Key key:parts) = format (pfx ++ formatKey key) parts++ formatKey :: String -> String+ formatKey key+ | isIdentifierKey key = "." ++ key+ | otherwise = "['" ++ escapeKey key ++ "']"++ isIdentifierKey :: String -> Bool+ isIdentifierKey [] = False+ isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs++ escapeKey :: String -> String+ escapeKey = concatMap escapeChar++ escapeChar :: Char -> String+ escapeChar '\'' = "\\'"+ escapeChar '\\' = "\\\\"+ escapeChar c = [c]++explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a+explicitParseField p obj key =+ case key `lookup` obj of+ Nothing -> fail $ "key " ++ key ++ " not found"+ Just v -> p v <?> Key key++(.:) :: FromJSON a => Object -> String -> Parser a+(.:) = explicitParseField parseJSON++explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a)+explicitParseFieldMaybe p obj key =+ case key `lookup` obj of+ Nothing -> pure Nothing+ Just v -> Just <$> p v <?> Key key++(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a)+(.:?) = explicitParseFieldMaybe parseJSON+++decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a+decodeWith decoder bsl =+ case Parsec.parse parseJSONValue "<input>" bsl of+ Left _ -> Nothing+ Right json ->+ case decoder json of+ Success a -> Just a+ Error _ -> Nothing++decode :: FromJSON a => BSL.ByteString -> Maybe a+decode = decodeWith fromJSON++eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a+eitherDecodeWith decoder bsl =+ case Parsec.parse parseJSONValue "<input>" bsl of+ Left parsecError -> Left (show parsecError)+ Right json ->+ case decoder json of+ Success a -> Right a+ Error err -> Left err++eitherDecode :: FromJSON a => BSL.ByteString -> Either String a+eitherDecode = eitherDecodeWith fromJSON+++decodeFile :: FromJSON a => FilePath -> IO (Maybe a)+decodeFile filePath = do+ parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath+ case parsecResult of+ Right r ->+ case fromJSON r of+ Success a -> return (Just a)+ Error _ -> return Nothing+ Left _ -> return Nothing+++eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a)+eitherDecodeFile filePath = do+ parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath+ case parsecResult of+ Right r ->+ case fromJSON r of+ Success a -> return (Right a)+ Error err -> return (Left err)+ Left err -> return $ Left (show err)+
+ haddock-api/src/Haddock/Utils/Json/Parser.hs view
@@ -0,0 +1,102 @@+-- | Json "Parsec" parser, based on+-- [json](https://hackage.haskell.org/package/json) package.+--+module Haddock.Utils.Json.Parser+ ( parseJSONValue+ ) where++import Prelude hiding (null)++import Control.Applicative (Alternative (..))+import Control.Monad (MonadPlus (..))+import Data.Char (isHexDigit)+import Data.Functor (($>))+import qualified Data.ByteString.Lazy.Char8 as BSCL+import Numeric+import Text.Parsec.ByteString.Lazy (Parser)+import Text.ParserCombinators.Parsec ((<?>))+import qualified Text.ParserCombinators.Parsec as Parsec++import Haddock.Utils.Json.Types hiding (object)++parseJSONValue :: Parser Value+parseJSONValue = Parsec.spaces *> parseValue++tok :: Parser a -> Parser a+tok p = p <* Parsec.spaces++parseValue :: Parser Value+parseValue =+ parseNull+ <|> Bool <$> parseBoolean+ <|> Array <$> parseArray+ <|> String <$> parseString+ <|> Object <$> parseObject+ <|> Number <$> parseNumber+ <?> "JSON value"++parseNull :: Parser Value+parseNull = tok+ $ Parsec.string "null"+ $> Null++parseBoolean :: Parser Bool+parseBoolean = tok+ $ Parsec.string "true" $> True+ <|> Parsec.string "false" $> False++parseArray :: Parser [Value]+parseArray =+ Parsec.between+ (tok (Parsec.char '['))+ (tok (Parsec.char ']'))+ (parseValue `Parsec.sepBy` tok (Parsec.char ','))++parseString :: Parser String+parseString =+ Parsec.between+ (tok (Parsec.char '"'))+ (tok (Parsec.char '"'))+ (many char)+ where+ char = (Parsec.char '\\' >> escapedChar)+ <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\')++ escapedChar =+ Parsec.char '"' $> '"'+ <|> Parsec.char '\\' $> '\\'+ <|> Parsec.char '/' $> '/'+ <|> Parsec.char 'b' $> '\b'+ <|> Parsec.char 'f' $> '\f'+ <|> Parsec.char 'n' $> '\n'+ <|> Parsec.char 'r' $> '\r'+ <|> Parsec.char 't' $> '\t'+ <|> Parsec.char 'u' *> uni+ <?> "escape character"++ uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)+ where+ check x | code <= max_char = return (toEnum code)+ | otherwise = mzero+ where code = fst $ head $ readHex x+ max_char = fromEnum (maxBound :: Char)++parseObject :: Parser Object+parseObject =+ Parsec.between+ (tok (Parsec.char '{'))+ (tok (Parsec.char '}'))+ (field `Parsec.sepBy` tok (Parsec.char ','))+ where+ field :: Parser (String, Value)+ field = (,)+ <$> parseString+ <* tok (Parsec.char ':')+ <*> parseValue++parseNumber :: Parser Double+parseNumber = tok $ do+ s <- BSCL.unpack <$> Parsec.getInput+ case readSigned readFloat s of+ [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n+ _ -> mzero
+ haddock-api/src/Haddock/Utils/Json/Types.hs view
@@ -0,0 +1,42 @@+module Haddock.Utils.Json.Types+ ( Value(..)+ , typeOf+ , Pair+ , Object+ , object+ ) where++import Data.String++-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+ | Array [Value]+ | String String+ | Number !Double+ | Bool !Bool+ | Null+ deriving (Eq, Read, Show)++typeOf :: Value -> String+typeOf v = case v of+ Object _ -> "Object"+ Array _ -> "Array"+ String _ -> "String"+ Number _ -> "Number"+ Bool _ -> "Boolean"+ Null -> "Null"++-- | A key\/value pair for an 'Object'+type Pair = (String, Value)++-- | A JSON \"object\" (key/value map).+type Object = [Pair]++-- | Create a 'Value' from a list of name\/value 'Pair's.+object :: [Pair] -> Value+object = Object++instance IsString Value where+ fromString = String
haddock-library/src/CompatPrelude.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} -#if !MIN_VERSION_base(4,5,0)+#ifdef __HLINT__+#elif !MIN_VERSION_base(4,5,0) # error This module doesn't provide compat-shims for versions prior to base-4.5 #endif
haddock-library/src/Documentation/Haddock/Markup.hs view
@@ -22,7 +22,7 @@ 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 (DocOrderedList ds) = markupOrderedList m (map (\(index, a) -> (index, markup m a)) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l))
haddock-library/src/Documentation/Haddock/Parser.hs view
@@ -78,7 +78,7 @@ g (DocMonospaced x) = DocMonospaced $ g x g (DocBold x) = DocBold $ g x g (DocUnorderedList x) = DocUnorderedList $ fmap g x- g (DocOrderedList x) = DocOrderedList $ fmap g x+ g (DocOrderedList x) = DocOrderedList $ fmap (\(index, a) -> (index, g a)) x g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x g (DocCodeBlock x) = DocCodeBlock $ g x g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x))@@ -173,11 +173,11 @@ -- Once we have checked for any of these and tried to parse the -- relevant markup, we can assume they are used as regular text. specialChar :: [Char]-specialChar = "_/<@\"&'`# "+specialChar = "_/<@\"&'`#[ " -- | Plain, regular parser for text. Called as one of the last parsers -- to ensure that we have already given a chance to more meaningful parsers--- before capturing their characers.+-- before capturing their characters. string' :: Parser (DocH mod a) string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar) where@@ -361,7 +361,7 @@ firstRow <- parseFirstRow let len = T.length firstRow - -- then we parse all consequtive rows starting and ending with + or |,+ -- then we parse all consecutive rows starting and ending with + or |, -- of the width `len`. restRows <- many (try (parseRestRows len)) @@ -577,10 +577,24 @@ orderedList :: Text -> Parser (DocH mod Identifier) orderedList indent = DocOrderedList <$> p where- p = (paren <|> dot) *> innerList indent p+ p = do+ index <- paren <|> dot+ innerList' indent p index dot = (decimal :: Parser Int) <* "." paren = "(" *> decimal <* ")" +-- | Like 'innerList' but takes the parsed index of the list item+innerList' :: Text -> Parser [(Int, DocH mod Identifier)]+ -> Int+ -> Parser [(Int, DocH mod Identifier)]+innerList' indent item index = do+ c <- takeLine+ (cs, items) <- more indent item+ let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs+ return $ case items of+ Left p -> [(index, contents `docAppend` p)]+ Right i -> (index, contents) : i+ -- | Generic function collecting any further lines belonging to the -- list entry and recursively collecting any further lists in the -- same paragraph. Usually used as@@ -710,7 +724,7 @@ Just (' ',t') -> Just t' _ -> Nothing --- | Parses examples. Examples are a paragraph level entitity (separated by an empty line).+-- | Parses examples. Examples are a paragraph level entity (separated by an empty line). -- Consecutive examples are accepted. examples :: Parser (DocH mod a) examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go)
haddock-library/src/Documentation/Haddock/Parser/Identifier.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-} -- | -- Module : Documentation.Haddock.Parser.Identifier -- Copyright : (c) Alec Theriault 2019,@@ -150,9 +149,9 @@ | otherwise = Nothing -- | Parse all but the last quote off the front of the input- -- PRECONDITION: T.head t == '\''+ -- PRECONDITION: T.head t `elem` ['\'', '`'] quotes :: Text -> (Int, Text)- quotes t = let !n = T.length (T.takeWhile (== '\'') t) - 1+ quotes t = let !n = T.length (T.takeWhile (`elem` ['\'', '`']) t) - 1 in (n, T.drop n t) -- | Parse an operator off the front of the input
haddock-library/src/Documentation/Haddock/Parser/Monad.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Documentation.Haddock.Parser.Monad -- Copyright : (c) Alec Theriault 2018-2019,@@ -40,7 +39,7 @@ import Prelude hiding (takeWhile) import CompatPrelude --- | The only bit of information we really care about truding along with us+-- | The only bit of information we really care about trudging along with us -- through parsing is the version attached to a @\@since@ annotation - if -- the doc even contained one. newtype ParserState = ParserState {
haddock-library/src/Documentation/Haddock/Types.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE CPP, DeriveTraversable #-} -- | -- Module : Documentation.Haddock.Types@@ -124,7 +124,7 @@ | DocMonospaced (DocH mod id) | DocBold (DocH mod id) | DocUnorderedList [DocH mod id]- | DocOrderedList [DocH mod id]+ | DocOrderedList [(Int, DocH mod id)] | DocDefList [(DocH mod id, DocH mod id)] | DocCodeBlock (DocH mod id) | DocHyperlink (Hyperlink (DocH mod id))@@ -154,7 +154,7 @@ bimap f g (DocMonospaced doc) = DocMonospaced (bimap f g doc) bimap f g (DocBold doc) = DocBold (bimap f g doc) bimap f g (DocUnorderedList docs) = DocUnorderedList (map (bimap f g) docs)- bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) docs)+ bimap f g (DocOrderedList docs) = DocOrderedList (map (\(index, a) -> (index, bimap f g a)) docs) bimap f g (DocDefList docs) = DocDefList (map (bimap f g *** bimap f g) docs) bimap f g (DocCodeBlock doc) = DocCodeBlock (bimap f g doc) bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl))@@ -180,7 +180,7 @@ bifoldr f g z (DocMonospaced doc) = bifoldr f g z doc bifoldr f g z (DocBold doc) = bifoldr f g z doc bifoldr f g z (DocUnorderedList docs) = foldr (flip (bifoldr f g)) z docs- bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z docs+ bifoldr f g z (DocOrderedList docs) = foldr (flip (bifoldr f g)) z (map snd docs) bifoldr f g z (DocDefList docs) = foldr (\(l, r) acc -> bifoldr f g (bifoldr f g acc l) r) z docs bifoldr f g z (DocCodeBlock doc) = bifoldr f g z doc bifoldr f g z (DocHeader (Header _ title)) = bifoldr f g z title@@ -201,7 +201,8 @@ bitraverse f g (DocMonospaced doc) = DocMonospaced <$> bitraverse f g doc bitraverse f g (DocBold doc) = DocBold <$> bitraverse f g doc bitraverse f g (DocUnorderedList docs) = DocUnorderedList <$> traverse (bitraverse f g) docs- bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs+ bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverseSnd (bitraverse f g) docs+ where traverseSnd f' = traverse (\(x, a) -> (\b -> (x, b)) <$> f' a) bitraverse f g (DocDefList docs) = DocDefList <$> traverse (bitraverse (bitraverse f g) (bitraverse f g)) docs bitraverse f g (DocCodeBlock doc) = DocCodeBlock <$> bitraverse f g doc bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl)@@ -246,7 +247,7 @@ , markupBold :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a- , markupOrderedList :: [a] -> a+ , markupOrderedList :: [(Int,a)] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a , markupHyperlink :: Hyperlink a -> a
haddock.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.4+cabal-version: 3.0 name: haddock-version: 2.26.0+version: 2.27.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation@@ -23,6 +23,8 @@ without any documentation annotations, Haddock can generate useful documentation from your source code. .+ Documentation for the haddock binary is available at [readthedocs](https://haskell-haddock.readthedocs.io/en/latest/).+ . <<https://cdn.rawgit.com/haskell/haddock/ghc-8.10/doc/cheatsheet/haddocks.svg>> license: BSD-3-Clause license-file: LICENSE@@ -33,7 +35,7 @@ copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple-tested-with: GHC==9.2.*+tested-with: GHC==9.4.* extra-source-files: CHANGES.md@@ -66,7 +68,7 @@ -- haddock typically only supports a single GHC major version build-depends:- base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0 || ^>= 4.16.0.0+ base ^>= 4.13.0.0 || ^>= 4.14.0.0 || ^>= 4.15.0.0 || ^>= 4.16.0.0 || ^>= 4.17.0.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src@@ -81,7 +83,7 @@ xhtml >= 3000.2 && < 3000.3, ghc-boot, ghc-boot-th,- ghc == 9.2.*,+ ghc == 9.4.*, bytestring, parsec, text,@@ -111,6 +113,8 @@ Haddock.Parser Haddock.Utils Haddock.Utils.Json+ Haddock.Utils.Json.Parser+ Haddock.Utils.Json.Types Haddock.Backends.Xhtml Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup@@ -146,7 +150,7 @@ else -- in order for haddock's advertised version number to have proper meaning, -- we pin down to a single haddock-api version.- build-depends: haddock-api == 2.26.0+ build-depends: haddock-api == 2.27.0 test-suite html-test type: exitcode-stdio-1.0
− hoogle-test/ref/Bug873/test.txt
@@ -1,27 +0,0 @@--- Hoogle documentation, generated by Haddock--- See Hoogle, http://www.haskell.org/hoogle/--@package test-@version 0.0.0--module Bug873---- | Application operator. This operator is redundant, since ordinary--- application <tt>(f x)</tt> means the same as <tt>(f <a>$</a> x)</tt>.--- However, <a>$</a> has low, right-associative binding precedence, so it--- sometimes allows parentheses to be omitted; for example:--- --- <pre>--- f $ g $ h x = f (g (h x))--- </pre>--- --- It is also useful in higher-order situations, such as <tt><a>map</a>--- (<a>$</a> 0) xs</tt>, or <tt><a>zipWith</a> (<a>$</a>) fs xs</tt>.--- --- Note that <tt>(<a>$</a>)</tt> is levity-polymorphic in its result--- type, so that <tt>foo <a>$</a> True</tt> where <tt>foo :: Bool ->--- Int#</tt> is well-typed.-($) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b-infixr 0 $-($$) :: (a -> b) -> a -> b-infixr 0 $$
hoogle-test/src/Bug806/Bug806.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Bug806 where
− hoogle-test/src/Bug873/Bug873.hs
@@ -1,6 +0,0 @@-{-# LANGUAGE Haskell2010 #-}-module Bug873 (($), ($$)) where-infixr 0 $$--($$) :: (a -> b) -> a -> b-f $$ x = f x
html-test/ref/Bug1004.html view
@@ -1228,13 +1228,13 @@ ><span class="inst-left" ><span class="instance details-toggle-control details-toggle" data-details-id="i:id:Product:Data:15" ></span- > (<a href="#" title="Data.Typeable"+ > (<a href="#" title="Type.Reflection" >Typeable</a- > a, <a href="#" title="Data.Typeable"+ > a, <a href="#" title="Type.Reflection" >Typeable</a- > f, <a href="#" title="Data.Typeable"+ > f, <a href="#" title="Type.Reflection" >Typeable</a- > g, <a href="#" title="Data.Typeable"+ > g, <a href="#" title="Type.Reflection" >Typeable</a > k, <a href="#" title="Data.Data" >Data</a@@ -1320,7 +1320,7 @@ ><p class="src" ><a href="#" >dataCast1</a- > :: <a href="#" title="Data.Typeable"+ > :: <a href="#" title="Type.Reflection" >Typeable</a > t => (<span class="keyword" >forall</span@@ -1336,7 +1336,7 @@ ><p class="src" ><a href="#" >dataCast2</a- > :: <a href="#" title="Data.Typeable"+ > :: <a href="#" title="Type.Reflection" >Typeable</a > t => (<span class="keyword" >forall</span
html-test/ref/Bug313.html view
@@ -91,15 +91,15 @@ ><p >Some text.</p ><ol- ><li+ ><li value="1" >Item 1</li- ><li+ ><li value="2" ><p >Item 2</p ><pre >Some code</pre ></li- ><li+ ><li value="3" >Item 3</li ></ol ><p@@ -117,15 +117,15 @@ ><p >Some text.</p ><ol- ><li+ ><li value="1" >Item 1</li- ><li+ ><li value="2" ><p >Item 2</p ><pre >Some code</pre ></li- ><li+ ><li value="3" >Item 3</li ></ol ><p
html-test/ref/Bug574.html view
@@ -84,7 +84,7 @@ ></p ><div class="doc" ><p- >Somthing with a spliced type</p+ >Something with a spliced type</p ></div ></div ></div
html-test/ref/BundledPatterns.html view
@@ -58,7 +58,7 @@ >data</span > <a href="#" >Vec</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span@@ -88,7 +88,7 @@ >data</span > <a href="#" >RTree</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span@@ -129,7 +129,7 @@ >data</span > <a id="t:Vec" class="def" >Vec</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span@@ -152,7 +152,7 @@ > subscript starting from 0 and ending at <code ><code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >length</a ></code > - 1</code@@ -291,7 +291,7 @@ >data</span > <a id="t:RTree" class="def" >RTree</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span
html-test/ref/BundledPatterns2.html view
@@ -58,7 +58,7 @@ >data</span > <a href="#" >Vec</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span@@ -90,7 +90,7 @@ >data</span > <a href="#" >RTree</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span@@ -131,7 +131,7 @@ >data</span > <a id="t:Vec" class="def" >Vec</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span@@ -154,7 +154,7 @@ > subscript starting from 0 and ending at <code ><code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >length</a ></code > - 1</code@@ -289,7 +289,7 @@ >data</span > <a id="t:RTree" class="def" >RTree</a- > :: <a href="#" title="GHC.TypeLits"+ > :: <a href="#" title="GHC.TypeNats" >Nat</a > -> * -> * <span class="keyword" >where</span
html-test/ref/ConstructorArgs.html view
@@ -718,7 +718,7 @@ ></p ><div class="doc" ><p- >Not bunded and no argument docs</p+ >Not bundled and no argument docs</p ></div ></div ></div
html-test/ref/FunArgs.html view
@@ -230,7 +230,9 @@ ><td class="src" >:: <span class="keyword" >forall</span- > a (b :: ()) d. d ~ '<a href="#" title="GHC.Tuple"+ > a (b :: ()) d. d <a href="#" title="Data.Type.Equality"+ >~</a+ > '<a href="#" title="GHC.Tuple" >()</a ></td ><td class="doc empty"
html-test/ref/Identifiers.html view
@@ -146,7 +146,7 @@ >++</a ></code >, <code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >elem</a ></code ></li@@ -168,7 +168,7 @@ >, <code >++</code >, <code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >elem</a ></code >, <code@@ -237,7 +237,7 @@ ><li >Unqualified: <code >1 <code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >`elem`</a ></code > [-3..3]</code@@ -245,14 +245,14 @@ ><li >Qualified: <code >1 <code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >`elem`</a ></code > [-3..3]</code ></li ><li >Namespaced: <code- ><a href="#" title="Data.List"+ ><a href="#" title="Data.Foldable" >`elem`</a ></code >, <code
html-test/ref/Instances.html view
@@ -1300,9 +1300,9 @@ >baz</a > :: [c] -> (<span class="keyword" >forall</span- > a. a -> a) -> (b, <span class="keyword"+ > a1. a1 -> a1) -> (b, <span class="keyword" >forall</span- > c0. c0 -> [c]) -> (b, c1) <a href="#" class="selflink"+ > c1. c1 -> [c]) -> (b, c0) <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1310,9 +1310,9 @@ >baz'</a > :: b -> (<span class="keyword" >forall</span- > b. b -> [c]) -> (<span class="keyword"+ > b1. b1 -> [c]) -> (<span class="keyword" >forall</span- > b. b -> [c]) -> [(b, [c])] <a href="#" class="selflink"+ > b1. b1 -> [c]) -> [(b, [c])] <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1320,9 +1320,9 @@ >baz''</a > :: b -> (<span class="keyword" >forall</span- > b. (<span class="keyword"+ > b1. (<span class="keyword" >forall</span- > b. b -> [c]) -> c0) -> <span class="keyword"+ > b2. b2 -> [c]) -> c0) -> <span class="keyword" >forall</span > c1. c1 -> b <a href="#" class="selflink" >#</a@@ -1362,9 +1362,9 @@ >baz</a > :: (a -> b) -> (<span class="keyword" >forall</span- > a0. a0 -> a0) -> (b0, <span class="keyword"+ > a1. a1 -> a1) -> (b0, <span class="keyword" >forall</span- > c. c -> a -> b) -> (b0, c) <a href="#" class="selflink"+ > c1. c1 -> a -> b) -> (b0, c) <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1374,7 +1374,7 @@ >forall</span > b1. b1 -> a -> b) -> (<span class="keyword" >forall</span- > b2. b2 -> a -> b) -> [(b0, a -> b)] <a href="#" class="selflink"+ > b1. b1 -> a -> b) -> [(b0, a -> b)] <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1386,7 +1386,7 @@ >forall</span > b2. b2 -> a -> b) -> c) -> <span class="keyword" >forall</span- > c. c -> b0 <a href="#" class="selflink"+ > c1. c1 -> b0 <a href="#" class="selflink" >#</a ></p ></div@@ -1428,11 +1428,11 @@ >Quux</a > a b c -> (<span class="keyword" >forall</span- > a0. a0 -> a0) -> (b0, <span class="keyword"+ > a1. a1 -> a1) -> (b0, <span class="keyword" >forall</span- > c0. c0 -> <a href="#" title="Instances"+ > c1. c1 -> <a href="#" title="Instances" >Quux</a- > a b c) -> (b0, c1) <a href="#" class="selflink"+ > a b c) -> (b0, c0) <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1444,7 +1444,7 @@ >Quux</a > a b c) -> (<span class="keyword" >forall</span- > b2. b2 -> <a href="#" title="Instances"+ > b1. b1 -> <a href="#" title="Instances" >Quux</a > a b c) -> [(b0, <a href="#" title="Instances" >Quux</a@@ -1500,9 +1500,9 @@ >baz</a > :: (a, b, c) -> (<span class="keyword" >forall</span- > a0. a0 -> a0) -> (b0, <span class="keyword"+ > a1. a1 -> a1) -> (b0, <span class="keyword" >forall</span- > c0. c0 -> (a, b, c)) -> (b0, c1) <a href="#" class="selflink"+ > c1. c1 -> (a, b, c)) -> (b0, c0) <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1512,7 +1512,7 @@ >forall</span > b1. b1 -> (a, b, c)) -> (<span class="keyword" >forall</span- > b2. b2 -> (a, b, c)) -> [(b0, (a, b, c))] <a href="#" class="selflink"+ > b1. b1 -> (a, b, c)) -> [(b0, (a, b, c))] <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1562,9 +1562,9 @@ >baz</a > :: (a, [b], b, a) -> (<span class="keyword" >forall</span- > a0. a0 -> a0) -> (b0, <span class="keyword"+ > a1. a1 -> a1) -> (b0, <span class="keyword" >forall</span- > c. c -> (a, [b], b, a)) -> (b0, c) <a href="#" class="selflink"+ > c1. c1 -> (a, [b], b, a)) -> (b0, c) <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1574,7 +1574,7 @@ >forall</span > b1. b1 -> (a, [b], b, a)) -> (<span class="keyword" >forall</span- > b2. b2 -> (a, [b], b, a)) -> [(b0, (a, [b], b, a))] <a href="#" class="selflink"+ > b1. b1 -> (a, [b], b, a)) -> [(b0, (a, [b], b, a))] <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1586,7 +1586,7 @@ >forall</span > b2. b2 -> (a, [b], b, a)) -> c) -> <span class="keyword" >forall</span- > c. c -> b0 <a href="#" class="selflink"+ > c1. c1 -> b0 <a href="#" class="selflink" >#</a ></p ></div@@ -1844,11 +1844,11 @@ >Quux</a > a b c -> (<span class="keyword" >forall</span- > a0. a0 -> a0) -> (b0, <span class="keyword"+ > a1. a1 -> a1) -> (b0, <span class="keyword" >forall</span- > c0. c0 -> <a href="#" title="Instances"+ > c1. c1 -> <a href="#" title="Instances" >Quux</a- > a b c) -> (b0, c1) <a href="#" class="selflink"+ > a b c) -> (b0, c0) <a href="#" class="selflink" >#</a ></p ><p class="src"@@ -1860,7 +1860,7 @@ >Quux</a > a b c) -> (<span class="keyword" >forall</span- > b2. b2 -> <a href="#" title="Instances"+ > b1. b1 -> <a href="#" title="Instances" >Quux</a > a b c) -> [(b0, <a href="#" title="Instances" >Quux</a
html-test/ref/Nesting.html view
@@ -108,7 +108,7 @@ ><p >easily go back</p ><ol- ><li+ ><li value="1" >some indentation</li ></ol ></li@@ -118,7 +118,7 @@ ></li ></ul ><ol- ><li+ ><li value="1" ><pre >back at the top</pre ></li@@ -285,11 +285,11 @@ ><p >Even more content on a new line.</p ><ol- ><li+ ><li value="1" ><p >Different type of list</p ><ol- ><li+ ><li value="2" >Deeper</li ></ol ><pre class="screen"
html-test/ref/Test.html view
@@ -1884,9 +1884,9 @@ >This is the next item (different kind of bullet)</li ></ul ><ol- ><li+ ><li value="1" >This is an ordered list</li- ><li+ ><li value="2" >This is the next item (different kind of bullet)</li ></ol ><dl
html-test/ref/TypeOperators.html view
@@ -147,7 +147,9 @@ ><p class="src" ><a id="v:f" class="def" >f</a- > :: a ~ b => a -> b <a href="#" class="selflink"+ > :: a <a href="#" title="Data.Type.Equality"+ >~</a+ > b => a -> b <a href="#" class="selflink" >#</a ></p ></div@@ -155,7 +157,11 @@ ><p class="src" ><a id="v:g" class="def" >g</a- > :: (a ~ b, b ~ c) => a -> c <a href="#" class="selflink"+ > :: (a <a href="#" title="Data.Type.Equality"+ >~</a+ > b, b <a href="#" title="Data.Type.Equality"+ >~</a+ > c) => a -> c <a href="#" class="selflink" >#</a ></p ></div
html-test/src/Bug308.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE Haskell2010 #-} -- From 2.14.x onwards we were forgetting to swallow ‘#’ as a special--- character resulting in broken anchors if they accured+-- character resulting in broken anchors if they occurred -- mid-paragraph. Here we check that anchors get generated as -- expected. module Bug308 where
html-test/src/Bug745.hs view
@@ -4,6 +4,6 @@ module Bug574 where -- See https://github.com/haskell/haddock/issues/574 --- | Somthing with a spliced type+-- | Something with a spliced type foo :: Int -> $(let i = [t| Int |] in [t| $i -> $i |]) foo x y = x + y
html-test/src/BundledPatterns2.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms, TypeOperators,- ViewPatterns #-}+{-# LANGUAGE DataKinds, GADTs, KindSignatures, PatternSynonyms #-} module BundledPatterns2 (Vec((:>), Empty), RTree(..)) where import GHC.TypeLits
html-test/src/ConstructorArgs.hs view
@@ -50,7 +50,7 @@ -> Boo -- ^ a 'Boo' pattern pattern Bo x y = Foo x y --- | Not bunded and no argument docs+-- | Not bundled and no argument docs pattern Bo' :: Int -> String -> Boo pattern Bo' x y = Foo x y
html-test/src/DefaultAssociatedTypes.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE DefaultSignatures, TypeFamilies #-}+{-# LANGUAGE TypeFamilies #-} module DefaultAssociatedTypes where
html-test/src/GadtConstructorArgs.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE GADTs, PatternSynonyms #-}+{-# LANGUAGE GADTs #-} module GadtConstructorArgs (Boo(..)) where
html-test/src/Operators.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs #-}+{-# LANGUAGE PatternSynonyms, TypeOperators, TypeFamilies, GADTs #-} {-# LANGUAGE FunctionalDependencies #-} -- | Test operators with or without fixity declarations
html-test/src/QuasiQuote.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-} -- example taken from the GHC documentation module QuasiQuote where
hypsrc-test/Main.hs view
@@ -2,7 +2,7 @@ import Data.Char-import Data.List+import Data.List (isPrefixOf) import Data.Function (on) import System.Environment
hypsrc-test/ref/src/Classes.html view
@@ -194,7 +194,7 @@ ><span class="annottext" >bar :: Int -> Int </span- ><a href="#"+ ><a href="Classes.html#bar" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >bar</span ></a@@ -226,7 +226,7 @@ ><span class="annottext" >baz :: Int -> (Int, Int) </span- ><a href="#"+ ><a href="Classes.html#baz" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >baz</span ></a@@ -327,7 +327,7 @@ ><span class="annottext" >bar :: [a] -> Int </span- ><a href="#"+ ><a href="Classes.html#bar" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >bar</span ></a@@ -342,6 +342,7 @@ ><span class="annot" ><span class="annottext" >[a] -> Int+forall a. [a] -> Int forall (t :: * -> *) a. Foldable t => t a -> Int </span ><span class="hs-identifier hs-var"@@ -359,7 +360,7 @@ ><span class="annottext" >baz :: Int -> ([a], [a]) </span- ><a href="#"+ ><a href="Classes.html#baz" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >baz</span ></a@@ -716,6 +717,7 @@ ><span class="annot" ><span class="annottext" >[Int] -> Int+forall a. Num a => [a] -> a forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a </span ><span class="hs-identifier hs-var"@@ -798,7 +800,7 @@ ><span class="annottext" >norf :: [Int] -> Int </span- ><a href="#"+ ><a href="Classes.html#norf" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >norf</span ></a@@ -813,6 +815,7 @@ ><span class="annot" ><span class="annottext" >[Int] -> Int+forall a. Num a => [a] -> a forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a </span ><span class="hs-identifier hs-var"@@ -870,7 +873,7 @@ ><span class="annottext" >quux :: ([a], [a]) -> [a] </span- ><a href="#"+ ><a href="Classes.html#quux" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >quux</span ></a@@ -1118,7 +1121,7 @@ ><span class="annottext" >plugh :: forall a b. Either a a -> Either b b -> Either (a -> b) (b -> a) </span- ><a href="#"+ ><a href="Classes.html#plugh" ><span class="hs-identifier hs-var hs-var hs-var hs-var" >plugh</span ></a
hypsrc-test/ref/src/Constructors.html view
@@ -1309,6 +1309,7 @@ ><span class="annot" ><span class="annottext" >[Int] -> Int+forall a. Num a => [a] -> a forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a </span ><span class="hs-identifier hs-var"
hypsrc-test/ref/src/LinkingIdentifiers.html view
@@ -14,7 +14,7 @@ ><span id="line-2" ></span ><span class="hs-comment"- >-- Tests that the identifers/operators are properly linked even when:</span+ >-- Tests that the identifiers/operators are properly linked even when:</span ><span > </span
hypsrc-test/ref/src/Operators.html view
@@ -33,11 +33,6 @@ </span ><span id="line-4" ></span- ><span- >-</span- ><span id="line-5"- ></span ><span id="" ><span class="annot" ><a href="Operators.html#%2B%2B%2B"@@ -97,7 +92,7 @@ ><span > </span- ><span id="line-6"+ ><span id="line-5" ></span ><span id="" ><span class="annot"@@ -196,12 +191,12 @@ ><span > </span- ><span id="line-7"+ ><span id="line-6" ></span ><span > </span- ><span id="line-8"+ ><span id="line-7" ></span ><span id="" ><span class="annot"@@ -262,7 +257,7 @@ ><span > </span- ><span id="line-9"+ ><span id="line-8" ></span ><span id="" ><span class="annot"@@ -342,12 +337,12 @@ ><span > </span- ><span id="line-10"+ ><span id="line-9" ></span ><span > </span- ><span id="line-11"+ ><span id="line-10" ></span ><span id="" ><span class="annot"@@ -408,7 +403,7 @@ ><span > </span- ><span id="line-12"+ ><span id="line-11" ></span ><span id="%2A%2A%2A" ><span class="annot"@@ -458,7 +453,7 @@ ><span > </span- ><span id="line-13"+ ><span id="line-12" ></span ><span class="annot" ><a href="Operators.html#%2A%2A%2A"@@ -575,12 +570,12 @@ ><span > </span- ><span id="line-14"+ ><span id="line-13" ></span ><span > </span- ><span id="line-15"+ ><span id="line-14" ></span ><span id="" ><span class="annot"@@ -645,7 +640,7 @@ ><span > </span- ><span id="line-16"+ ><span id="line-15" ></span ><span id="" ><span class="annot"@@ -739,12 +734,12 @@ ><span > </span- ><span id="line-17"+ ><span id="line-16" ></span ><span > </span- ><span id="line-18"+ ><span id="line-17" ></span ><span id="" ><span class="annot"@@ -817,7 +812,7 @@ ><span > </span- ><span id="line-19"+ ><span id="line-18" ></span ><span id="" ><span class="annot"@@ -961,17 +956,12 @@ ><span > </span- ><span id="line-20"- ></span- ><span- >-</span- ><span id="line-21"+ ><span id="line-19" ></span ><span > </span- ><span id="line-22"+ ><span id="line-20" ></span ><span id="" ><span id=""@@ -1054,7 +1044,7 @@ ><span > </span- ><span id="line-23"+ ><span id="line-21" ></span ><span id="" ><span class="annot"@@ -1109,16 +1099,6 @@ ></span ><span > </span- ><span class="annot"- ><span class="annottext"- >((a, b) -> c -> (a, b)) -> (a, b) -> c -> (a, b)-forall a b. (a -> b) -> a -> b-</span- ><span class="hs-operator hs-var"- >$</span- ></span- ><span- > </span ><span class="hs-special" >(</span ><span class="annot"@@ -1148,7 +1128,7 @@ ><span > </span- ><span id="line-24"+ ><span id="line-22" ></span ></pre ></body
hypsrc-test/ref/src/Quasiquoter.html view
@@ -80,8 +80,10 @@ </span ><span id="line-7" ></span+ ><span class="annot" ><span class="hs-comment"- >-- | Quoter for constructing multiline string literals</span+ >-- | Quoter for constructing multiline string literals</span+ ></span ><span > </span@@ -156,6 +158,7 @@ ><span class="annot" ><span class="annottext" >Exp -> Q Exp+forall a. a -> Q a forall (f :: * -> *) a. Applicative f => a -> f a </span ><span class="hs-identifier hs-var"@@ -398,6 +401,7 @@ ><span class="annot" ><span class="annottext" >String -> Q a+forall a. String -> Q a forall (m :: * -> *) a. MonadFail m => String -> m a </span ><span class="hs-identifier hs-var"
hypsrc-test/ref/src/Records.html view
@@ -623,10 +623,10 @@ ><span class="annot" ><span class="annottext" >Int-x :: Int x :: Point -> Int+x :: Int </span- ><a href="#"+ ><a href="Records.html#x" ><span class="hs-identifier hs-var hs-var" >x</span ></a@@ -640,10 +640,10 @@ ><span class="annot" ><span class="annottext" >Int-y :: Int y :: Point -> Int+y :: Int </span- ><a href="#"+ ><a href="Records.html#y" ><span class="hs-identifier hs-var hs-var" >y</span ></a@@ -1301,12 +1301,12 @@ ><span class="annot" ><span class="annottext" >Int-y :: Int-x :: Int-y :: Point -> Int x :: Point -> Int+y :: Point -> Int+x :: Int+y :: Int </span- ><a href="#"+ ><a href="Records.html#x" ><span class="hs-glyph hs-var hs-var hs-var hs-var" >..</span ></a
hypsrc-test/ref/src/UsingQuasiquotes.html view
@@ -78,7 +78,10 @@ ><span > </span ><span class="annot"- ><span class=""+ ><span class="annottext"+ >[Char]+</span+ ><span class="" >[string| foo bar |]</span ></span ><span@@ -94,7 +97,10 @@ ><span > </span ><span class="annot"- ><span class=""+ ><span class="annottext"+ >[Char]+</span+ ><span class="" >[string| some mulitline quasiquote
hypsrc-test/src/LinkingIdentifiers.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Haskell2010 #-}--- Tests that the identifers/operators are properly linked even when:+-- Tests that the identifiers/operators are properly linked even when: -- -- * backquoted, parenthesized, vanilla -- * qualified, not-qualified
hypsrc-test/src/Operators.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE Haskell2010 #-} module Operators where - (+++) :: [a] -> [a] -> [a] a +++ b = a ++ b ++ a @@ -18,6 +17,5 @@ (**/\**) :: [[a]] -> [[a]] -> [[a]] a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b) - (#.#) :: a -> b -> (c -> (a, b))-a #.# b = const $ (a, b)+a #.# b = const (a, b)
latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Haskell2010 #-}-{-# LANGUAGE GADTs, PatternSynonyms #-}+{-# LANGUAGE GADTs #-} module GadtConstructorArgs (Boo(..)) where