diff options
49 files changed, 1055 insertions, 296 deletions
diff --git a/.travis.yml b/.travis.yml index 35ee528d..2bcb301a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,8 @@ # This Travis job script has been generated by a script via # -# runghc make_travis_yml_2.hs 'haddock.cabal' +# make_travis_yml_2.hs 'haddock.cabal' # -# For more information, see https://github.com/haskell-CI/haskell-ci +# For more information, see https://github.com/hvr/multi-ghc-travis # language: c sudo: false @@ -28,66 +28,70 @@ before_cache: matrix: include: - - compiler: "ghc-8.6.1" + - compiler: "ghc-head" + env: GHCHEAD=true # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}} + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-head], sources: [hvr-ghc]}} before_install: - - HC=${CC} - - HCPKG=${HC/ghc/ghc-pkg} - - unset CC - - ROOTDIR=$(pwd) - - mkdir -p $HOME/.local/bin - - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" - - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - - echo $HCNUMVER + - HC=${CC} + - HCPKG=${HC/ghc/ghc-pkg} + - unset CC + - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH + - PKGNAME='haddock' install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - HADDOCK=${HADDOCK-true} - - UNCONSTRAINED=${UNCONSTRAINED-true} - - NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false} - - GHCHEAD=${GHCHEAD-false} - - travis_retry cabal update -v - - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - - rm -fv cabal.project.local - - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - - touch cabal.project.local - - "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | grep -vw -- haddock | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then - (cd "." && autoreconf -i); - fi - - rm -f cabal.project.freeze - - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all - - rm -rf .ghc.environment.* "."/dist - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + - cabal --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - BENCH=${BENCH---enable-benchmarks} + - TEST=${TEST---enable-tests} + - GHCHEAD=${GHCHEAD-false} + - travis_retry cabal update -v + - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config + - rm -fv cabal.project.local + - rm -f cabal.project.freeze + # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage + - | + if $GHCHEAD; then + sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config + for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i "s/allow-newer: /allow-newer: *:$pkg, /" ${HOME}/.cabal/config; done -# Here starts the actual work to be performed for the package under test; -# any command which exits with a non-zero exit code causes the build to fail. -script: - - cat cabal.project || true - - cat cabal.project.local || true - # this builds all libraries and executables (without tests/benchmarks) - - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all + echo 'repository head.hackage' >> ${HOME}/.cabal/config + echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config + echo ' secure: True' >> ${HOME}/.cabal/config + echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config + echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config + echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config + echo ' key-threshold: 3' >> ${HOME}/.cabal.config - # build & run tests, build benchmarks - - cabal new-build -w ${HC} ${TEST} ${BENCH} all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi + grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - # cabal check - - cabal check + cabal new-update head.hackage -v + fi + - travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all + - travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer --constraint 'setup.Cabal installed' all - # Build documentation - - cabal new-haddock -w ${HC} all +# Here starts the actual work to be performed for the package under test; +# any command which exits with a non-zero exit code causes the build to fail. +script: + - if [ -f configure.ac ]; then autoreconf -i; fi + - rm -rf dist/ + - cabal sdist # test that a source-distribution can be generated + - cd dist/ + - SRCTAR=(${PKGNAME}-*.tar.gz) + - SRC_BASENAME="${SRCTAR/%.tar.gz}" + - tar -xvf "./$SRC_BASENAME.tar.gz" + - cd "$SRC_BASENAME/" +## from here on, CWD is inside the extracted source-tarball + - rm -fv cabal.project.local + # this builds all libraries and executables (without tests/benchmarks) + - rm -f cabal.project.freeze + - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --allow-newer --constraint 'setup.Cabal installed' all + # this builds all libraries and executables (including tests/benchmarks) + # - rm -rf ./dist-newstyle - # Build without installed constraints for packages in global-db - - if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi + # build & run tests + - cabal new-build -w ${HC} ${TEST} ${BENCH} --allow-newer --constraint 'setup.Cabal installed' all + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} --allow-newer --constraint 'setup.Cabal installed' all; fi -# REGENDATA ["haddock.cabal"] # EOF @@ -4,6 +4,8 @@ * Fix style switcher (enabled by `--built-in-themes`) (#949) + * Support inline markup in markdown-style links (#875) + ## Changes in version 2.22.0 * Make `--package-version` optional for `--hoogle` (#899) @@ -1,4 +1,4 @@ -# Haddock, a Haskell Documentation Tool [](https://travis-ci.org/haskell/haddock) +# Haddock, a Haskell Documentation Tool [](https://travis-ci.org/haskell/haddock) ## About haddock @@ -57,9 +57,9 @@ and then proceed using your favourite build tool. #### Using [`cabal new-build`](http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html) ```bash -cabal new-build -w ghc-8.6.1 +cabal new-build -w ghc-head # build & run the test suite -cabal new-test -w ghc-8.6.1 all +cabal new-test -w ghc-head all ``` #### Using Cabal sandboxes diff --git a/doc/cheatsheet/haddocks.md b/doc/cheatsheet/haddocks.md index a3464584..5ee285b3 100644 --- a/doc/cheatsheet/haddocks.md +++ b/doc/cheatsheet/haddocks.md @@ -85,7 +85,7 @@ definitions with "[thing]" -- \[ -- f(n) = \Sum_{i=1}^{n} i -- \] - \\ when \(n > 0\) + -- when \(n > 0\) ``` # Headings in Documentation diff --git a/doc/invoking.rst b/doc/invoking.rst index 3e6e667a..c6296089 100644 --- a/doc/invoking.rst +++ b/doc/invoking.rst @@ -27,8 +27,8 @@ considered a bug in the new versions. If you ever get failed parsing message, please report it. You must also specify an option for the output format. Currently only -the :option:`--html` option for HTML and the :option:`--hoogle` option for -outputting Hoogle data are functional. +the :option:`--html` option for HTML, the :option:`--hoogle` option for +outputting Hoogle data, and the :option:`--latex` option are functional. The packaging tool `Cabal <http://www.haskell.org/ghc/docs/latest/html/Cabal/index.html>`__ @@ -124,6 +124,12 @@ The following options are available: Some JavaScript utilities used to implement some of the dynamic features like collapsible sections. +.. option:: --mathjax + + Specify a custom URL for a mathjax-compatible JS script. By default, + this is set to `MathJax + <https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML>`_. + .. option:: --latex Generate documentation in LaTeX format. Several files will be @@ -159,6 +165,35 @@ The following options are available: Generate an index file for the `Hoogle <http://hackage.haskell.org/package/hoogle>`_ search engine. + One text file will be generated into the current directory (or the + specified directory if the :option:`-o` is given). Note that + the :option:`--package-name` is required. + + Since the output is intended to be parsed by Hoogle, some conventions + need to be upheld: + + * Every entity should span exactly one line. :: + + newtype ReaderT r (m :: * -> *) a :: * -> (* -> *) -> * -> * + + The one exception to this rule is classes. The body of a class + is split up with one class member per line, an opening brace on + the line of the header, and a closing brace on a new line after + the class. :: + + class Foo a where { + foo :: a -> a -> Baz a; + type family Baz a; + type Baz a = [(a, a)]; + } + + * Entites that are exported only indirectly (for instance data + constructors visible via a ``ReaderT(..)`` export) have their names + wrapped in square brackets. :: + + [ReaderT] :: (r -> m a) -> ReaderT r m a + [runReaderT] :: ReaderT r m a -> r -> m a + .. option:: --hyperlinked-source @@ -341,6 +376,14 @@ The following options are available: The title should be a plain string (no markup please!). +.. option:: --package-name=<name> + + Specify the name of the package being documented. + +.. option:: --package-version=<version> + + Specify the version of the package being documented. + .. option:: -q <mode> --qual=<mode> @@ -368,6 +411,19 @@ The following options are available: - relative: x, B.y, C.z +.. option:: --since-qual=<mode> + + Specify how ``@since`` annotations are qualified. + + mode should be one of + + - ``always`` (default): always qualify ``@since`` annotations with + a package name and version + + - ``only-external``: only qualify ``@since`` annotations with a + package name and version when they do not come from the current + package + .. option:: -? --help @@ -378,6 +434,21 @@ The following options are available: Output version information and exit. +.. option:: --ghc-version + + Output the version of GHC which Haddock expects to find at :option:-B + and exit. + +.. option:: --print-ghc-path + + Output the path to the GHC (which Haddock computes based on :option:-B) + and exit. + +.. option:: --print-ghc-libdir + + Output the path to the GHC ``lib`` directory (which Haddock computes + based on :option:-B) and exit. + .. option:: -v --verbose @@ -415,6 +486,16 @@ The following options are available: Causes Haddock to behave as if module module has the ``hide`` attribute. (:ref:`module-attrs`). +.. option:: --show <module> + + Causes Haddock to behave as if module module does not have the ``hide`` + attribute. (:ref:`module-attrs`). + +.. option:: --show-all + + Causes Haddock to behave as if no modules have the ``hide`` attribute. + (:ref:`module-attrs`). + .. option:: --show-extensions <module> Causes Haddock to behave as if module module has the @@ -430,10 +511,21 @@ The following options are available: Turn off all warnings. +.. option:: --interface-version + + Prints out the version of the binary Haddock interface files that + this version of Haddock generates. + .. option:: --compatible-interface-versions Prints out space-separated versions of binary Haddock interface - files that this version is compatible with. + files that this version of Haddock is compatible with. + +.. option:: --bypass-interface-version-check + + **DANGEROUS** Causes Haddock to ignore the interface verions of + binary Haddock interface files. This can make Haddock crash during + deserialization of interface files. .. option:: --no-tmp-comp-dir diff --git a/doc/markup.rst b/doc/markup.rst index 4e00f708..9fb0209a 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -8,6 +8,8 @@ will just generate documentation that contains the type signatures, data type declarations, and class declarations exported by each of the modules being processed. +.. _top-level-declaration + Documenting a Top-Level Declaration ----------------------------------- @@ -47,6 +49,8 @@ the following: - A ``class`` declaration, +- An ``instance`` declaration, + - A ``data family`` or ``type family`` declaration, or - A ``data instance`` or ``type instance`` declaration. @@ -106,6 +110,8 @@ signatures, by using either the ``-- |`` or ``-- ^`` annotations: :: -- | This is the documentation for the 'g' method g :: Int -> a +Associated type and data families can also be annotated in this way. + Constructors and Record Fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -166,6 +172,32 @@ would join up documentation of each field and render the result. The reason for this seemingly weird behaviour is the fact that ``someField`` is actually the same (partial) function. +Deriving clauses +~~~~~~~~~~~~~~~~ + +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: :: + + data D a = L a | M + deriving ( Eq -- ^ @since 4.5 + , Ord -- ^ default 'Ord' instance + ) + +This also scales to the various GHC extensions for deriving: :: + + newtype T a = T a + deriving Show -- ^ derivation of 'Show' + deriving stock ( Eq -- ^ stock derivation of 'Eq' + , Foldable -- ^ stock derivation of 'Foldable' + ) + deriving newtype Ord -- ^ newtype derivation of 'Ord' + deriving anyclass Read -- ^ unsafe derivation of 'Read' + deriving ( Eq1 -- ^ deriving 'Eq1' via 'Identity' + , Ord1 -- ^ deriving 'Ord1' via 'Identity' + ) via Identity + Function Arguments ~~~~~~~~~~~~~~~~~~ @@ -175,8 +207,8 @@ Individual arguments to a function may be documented like this: :: -> Float -- ^ The 'Float' argument -> IO () -- ^ The return value -Pattern synonyms and GADT-style data constructors also support this -style of documentation. +Pattern synonyms, GADT-style data constructors, and class methods also +support this style of documentation. .. _module-description: @@ -890,8 +922,14 @@ necessary to escape the single quote when used as an apostrophe: :: Nothing special is needed to hyperlink identifiers which contain apostrophes themselves: to hyperlink ``foo'`` one would simply type -``'foo''``. To hyperlink identifiers written in infix form, simply put -them in quotes as always: ``'`elem`'``. +``'foo''``. Hyperlinking operators works in exactly the same way. + +Note that it is not possible to directly hyperlink an identifier in infix +form or an operator in prefix form. The next best thing to do is to wrap +the whole identifier in monospaced text and put the parentheses/backticks +outside of the identifier, but inside the link: :: + + -- | A prefix operator @('++')@ and an infix identifier @\``elem`\`@. Emphasis, Bold and Monospaced Text ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index a410f436..2a94c5f5 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -44,7 +44,7 @@ library -- this package typically supports only single major versions build-depends: base ^>= 4.12.0 , Cabal ^>= 2.4.0 - , ghc ^>= 8.6 + , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 @@ -169,7 +169,7 @@ test-suite spec Haddock.Backends.Hyperlinker.Types build-depends: Cabal ^>= 2.4 - , ghc ^>= 8.6 + , ghc ^>= 8.7 , ghc-paths ^>= 0.1.0.9 , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 7a2df3a2..2bae60e7 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -161,16 +161,21 @@ haddockWithGhc ghc args = handleTopExceptions $ do Just "YES" -> return $ Flag_OptGhc "-dynamic-too" : flags _ -> return flags + -- bypass the interface version check + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + unless (Flag_NoWarnings `elem` flags) $ do hypSrcWarnings flags forM_ (warnings args) $ \warning -> do hPutStrLn stderr warning + when noChecks $ + hPutStrLn stderr noCheckWarning ghc flags' $ do dflags <- getDynFlags forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do - mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] + mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do putMsg dflags (renderJson (jsonInterfaceFile ifaceFile)) @@ -192,7 +197,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do throwE "No input file(s)." -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). liftIO $ renderStep dflags flags sinceQual qual packages [] @@ -203,6 +208,10 @@ warnings = map format . filter (isPrefixOf "-optghc") where format arg = concat ["Warning: `", arg, "' means `-o ", drop 2 arg, "', did you mean `-", arg, "'?"] +-- | Create a warning about bypassing the interface version check +noCheckWarning :: String +noCheckWarning = "Warning: `--bypass-interface-version-check' can cause " ++ + "Haddock to crash when reading Haddock interface files." withGhc :: [Flag] -> Ghc a -> IO a withGhc flags action = do @@ -220,7 +229,8 @@ readPackagesAndProcessModules :: [Flag] -> [String] -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) + let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags + packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. let ifaceFiles = map snd packages @@ -411,13 +421,14 @@ render dflags flags sinceQual qual ifaces installedIfaces extSrcMap = do readInterfaceFiles :: MonadIO m => NameCacheAccessor m -> [(DocPaths, FilePath)] + -> Bool -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs = do +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) = - readInterfaceFile name_cache_accessor file >>= \case + readInterfaceFile name_cache_accessor file bypass_version_check >>= \case Left err -> liftIO $ do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 5f77c38c..73a200f0 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -36,7 +36,6 @@ import Data.Version import System.Directory import System.FilePath -import System.IO prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" @@ -56,10 +55,7 @@ ppHoogle dflags package version synopsis prologue ifaces odir = do | not (null (versionBranch version)) ] ++ concat [ppModule dflags' i | i <- ifaces, OptHide `notElem` ifaceOptions i] createDirectoryIfMissing True odir - h <- openFile (odir </> filename) WriteMode - hSetEncoding h utf8 - hPutStr h (unlines contents) - hClose h + writeUtf8File (odir </> filename) (unlines contents) ppModule :: DynFlags -> Interface -> [String] ppModule dflags iface = @@ -345,7 +341,7 @@ markupTag dflags = Markup { markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, - markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), + markupHyperlink = \(Hyperlink url mLabel) -> box (TagInline "a") (fromMaybe (str url) mLabel), markupAName = const $ str "", markupProperty = box TagPre . str, markupExample = box TagPre . str . unlines . map exampleToString, diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 248a8a54..8f0c4b67 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker import Haddock.Types +import Haddock.Utils (writeUtf8File) import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Utils @@ -44,7 +45,7 @@ ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface -> IO () ppHyperlinkedModuleSource srcdir pretty srcs iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . html . render' $ tokens + Just tokens -> writeUtf8File path . html . render' $ tokens Nothing -> return () where render' = render (Just srcCssFile) (Just highlightScript) srcs diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index acb2c892..f8494242 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -144,7 +144,7 @@ spanToNewline 0 str@(c:_) | ((lexed, str') : _) <- R.lex str, not (isSpace c) = -- A Haskell line comment then case span (/= '\n') str' of (str'', '\n':rest) -> (lexed ++ str'' ++ "\n", rest) - (_, _) -> (str, "") + (_, _) -> (str, "") -- An actual Haskell token else let (str'', rest) = spanToNewline 0 str' @@ -165,10 +165,10 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) go :: (RealSrcLoc, [T.Token], Bool) -- ^ current position, tokens accumulated, currently in pragma (or not) - + -> (Located L.Token, String) -- ^ next token, its content - + -> (RealSrcLoc, [T.Token], Bool) -- ^ new position, new tokens accumulated, currently in pragma (or not) @@ -179,12 +179,12 @@ ghcToks = reverse . (\(_,ts,_) -> ts) . foldl' go (start, [], False) ) where (next_pos, white) = mkWhitespace pos l - + classifiedTok = [ Token (classify' tok) raw rss | RealSrcSpan rss <- [l] , not (null raw) ] - + classify' | in_prag = const TkPragma | otherwise = classify @@ -378,6 +378,7 @@ classify tok = ITLarrowtail {} -> TkGlyph ITRarrowtail {} -> TkGlyph + ITcomment_line_prag -> TkUnknown ITunknown {} -> TkUnknown ITeof -> TkUnknown diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 613c6deb..69b43eca 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -135,7 +135,7 @@ ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do filename = odir </> (fromMaybe "haddock" packageStr <.> "tex") - writeFile filename (show tex) + writeUtf8File filename (show tex) ppLaTeXModule :: String -> FilePath -> Interface -> IO () @@ -168,7 +168,7 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) + writeUtf8File (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) -- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX @@ -974,7 +974,7 @@ tupleParens _ = parenList sumParens :: [LaTeX] -> LaTeX -sumParens = ubxparens . hsep . punctuate (text " | ") +sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- @@ -1182,7 +1182,7 @@ parLatexMarkup ppId = Markup { markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupHyperlink = \l _ -> markupLink l, + markupHyperlink = \(Hyperlink u l) p -> markupLink u (fmap ($p) l), markupAName = \_ _ -> empty, markupProperty = \p _ -> quote $ verb $ text p, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, @@ -1202,8 +1202,8 @@ parLatexMarkup ppId = Markup { fixString Verb s = s fixString Mono s = latexMonoFilter s - markupLink (Hyperlink url mLabel) = case mLabel of - Just label -> text "\\href" <> braces (text url) <> braces (text label) + markupLink url mLabel = case mLabel of + 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. @@ -1335,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" +ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 46d94b37..db29c7cf 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -293,7 +293,7 @@ ppHtmlContents dflags odir doctitle _maybe_package ppModuleTree pkg qual tree ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html) ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html @@ -436,9 +436,9 @@ ppHtmlIndex odir doctitle _maybe_package themes mapM_ (do_sub_index index) initialChars -- Let's add a single large index as well for those who don't know exactly what they're looking for: let mergedhtml = indexPage False Nothing index - writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) - writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html) where indexPage showLetters ch items = @@ -479,7 +479,7 @@ ppHtmlIndex odir doctitle _maybe_package themes do_sub_index this_ix c = unless (null index_part) $ - writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) where html = indexPage True (Just c) index_part index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] @@ -573,7 +573,7 @@ ppHtmlModule odir doctitle themes ] createDirectoryIfMissing True odir - writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) signatureDocURL :: String signatureDocURL = "https://wiki.haskell.org/Module_signature" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 38aa7b7e..09aabc0c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -62,8 +62,8 @@ parHtmlMarkup qual insertAnchors ppId = Markup { markupHyperlink = \(Hyperlink url mLabel) -> if insertAnchors then anchor ! [href url] - << fromMaybe url mLabel - else toHtml $ fromMaybe url mLabel, + << fromMaybe (toHtml url) mLabel + else fromMaybe (toHtml url) mLabel, markupAName = \aname -> if insertAnchors then namedAnchor aname << "" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index 7fbaec6d..62781fd0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -183,7 +183,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" dcolon, arrow, darrow, forallSymbol :: Bool -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6eee353b..823e288e 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -36,9 +36,10 @@ import TyCon import Type import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey - , tYPETyConKey, liftedRepDataConKey ) +import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName + , unitTy, promotedNilDataCon, promotedConsDataCon ) +import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey + , liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut , splitAtList ) @@ -118,10 +119,11 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType rhs - in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs - , hsib_closed = True } + in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name + , feqn_bndrs = Nothing + -- this must change eventually , feqn_pats = annot_typats , feqn_fixity = Prefix , feqn_rhs = hs_rhs } } @@ -457,9 +459,24 @@ synifyType _ (TyConApp tc tys) ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = + | getName tc == listTyConName, [ty] <- vis_tys = noLoc $ HsListTy noExt (synifyType WithinType ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLoc $ HsExplicitListTy noExt Promoted [] + | tc == promotedConsDataCon + , [ty1, ty2] <- vis_tys + = let hTy = synifyType WithinType ty1 + in case synifyType WithinType ty2 of + tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy + -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy') + | otherwise + -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys @@ -567,6 +584,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k +stripKindSig :: LHsType GhcRn -> LHsType GhcRn +stripKindSig (L _ (HsKindSig _ t _)) = t +stripKindSig t = t + synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls @@ -652,8 +673,8 @@ tcSplitSigmaTyPreserveSynonyms ty = tcSplitForAllTysPreserveSynonyms :: Type -> ([TyVar], Type) tcSplitForAllTysPreserveSynonyms ty = split ty ty [] where - split _ (ForAllTy (TvBndr tv _) ty') tvs = split ty' ty' (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty') tvs = split ty' ty' (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | See Note [Invariant: Never expand type synonyms] tcSplitPhiTyPreserveSynonyms :: Type -> (ThetaType, Type) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 2d72d117..8f7abd16 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -19,6 +19,7 @@ import Haddock.Types import Haddock.Convert import Haddock.GhcUtils +import Control.Applicative ((<|>)) import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) @@ -63,16 +64,24 @@ attachInstances expInfo ifaces instIfaceMap mods = do ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] attach index iface = do - newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap) + + let getInstDoc = findInstDoc iface ifaceMap instIfaceMap + getFixity = findFixity iface ifaceMap instIfaceMap + + newItems <- mapM (attachToExportItem index expInfo getInstDoc getFixity) (ifaceExportItems iface) - let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) + let orphanInstances = attachOrphanInstances expInfo getInstDoc (ifaceInstances iface) return $ iface { ifaceExportItems = newItems , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] -attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = - [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n), Nothing) +attachOrphanInstances + :: ExportInfo + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> [ClsInst] -- ^ a list of orphan instances + -> [DocInstance GhcRn] +attachOrphanInstances expInfo getInstDoc cls_instances = + [ (synifyInstHead i, getInstDoc n, (L (getSrcSpan n) n), Nothing) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys @@ -80,40 +89,40 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = attachToExportItem - :: NameEnv ([ClsInst], [FamInst]) + :: NameEnv ([ClsInst], [FamInst]) -- ^ all instances (that we know of) -> ExportInfo - -> Interface - -> IfaceMap - -> InstIfaceMap + -> (Name -> Maybe (MDoc Name)) -- ^ how to lookup the doc of an instance + -> (Name -> Maybe Fixity) -- ^ how to lookup a fixity -> ExportItem GhcRn -> Ghc (ExportItem GhcRn) -attachToExportItem index expInfo iface ifaceMap instIfaceMap export = +attachToExportItem index expInfo getInstDoc getFixity export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst fam_instances = maybeToList mb_instances >>= snd - fam_insts = [ ( synifyFamInst i opaque - , doc - , spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) + fam_insts = [ ( synFamInst + , getInstDoc n + , spanNameE n synFamInst (L eSpan (tcdName d)) , nameModule_maybe n ) | i <- sortBy (comparing instFam) fam_instances , let n = getName i - , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap , not $ isNameHidden expInfo (fi_fam i) , not $ any (isTypeHidden expInfo) (fi_tys i) , let opaque = isTypeHidden expInfo (fi_rhs i) + , let synFamInst = synifyFamInst i opaque ] - cls_insts = [ ( synifyInstHead i - , instLookup instDocMap n iface ifaceMap instIfaceMap - , spanName n (synifyInstHead i) (L eSpan (tcdName d)) + cls_insts = [ ( synClsInst + , getInstDoc n + , spanName n synClsInst (L eSpan (tcdName d)) , nameModule_maybe n ) | let is = [ (instanceSig i, getName i) | i <- cls_instances ] , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is , not $ isInstanceHidden expInfo cls tys + , let synClsInst = synifyInstHead i ] -- fam_insts but with failing type fams filtered out cleanFamInsts = [ (fi, n, L l r, m) | (Right fi, n, L l (Right r), m) <- fam_insts ] @@ -133,7 +142,7 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export = nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d , n' <- n : (map fst subDocs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , f <- maybeToList (getFixity n') ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns @@ -152,16 +161,20 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export = let L l r = spanName s ok linst in L l (Right r) +-- | Lookup the doc associated with a certain instance +findInstDoc :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe (MDoc Name) +findInstDoc iface ifaceMap instIfaceMap = \name -> + (Map.lookup name . ifaceDocMap $ iface) <|> + (Map.lookup name . ifaceDocMap =<< Map.lookup (nameModule name) ifaceMap) <|> + (Map.lookup name . instDocMap =<< Map.lookup (nameModule name) instIfaceMap) + +-- | Lookup the fixity associated with a certain name +findFixity :: Interface -> IfaceMap -> InstIfaceMap -> Name -> Maybe Fixity +findFixity iface ifaceMap instIfaceMap = \name -> + (Map.lookup name . ifaceFixMap $ iface) <|> + (Map.lookup name . ifaceFixMap =<< Map.lookup (nameModule name) ifaceMap) <|> + (Map.lookup name . instFixMap =<< Map.lookup (nameModule name) instIfaceMap) -instLookup :: (InstalledInterface -> Map.Map Name a) -> Name - -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a -instLookup f name iface ifaceMap instIfaceMap = - case Map.lookup name (f $ toInstalledIface iface) of - res@(Just _) -> res - Nothing -> do - let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap - iface' <- Map.lookup (nameModule name) ifaceMaps - Map.lookup name (f iface') -------------------------------------------------------------------------------- -- Collecting and sorting instances diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index b6913012..59ad4fdf 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -135,7 +135,7 @@ rename dflags gre = rn DocCodeBlock doc -> DocCodeBlock <$> rn doc DocIdentifierUnchecked x -> pure (DocIdentifierUnchecked x) DocModule str -> pure (DocModule str) - DocHyperlink l -> pure (DocHyperlink l) + DocHyperlink (Hyperlink u l) -> DocHyperlink . Hyperlink u <$> traverse rn l DocPic str -> pure (DocPic str) DocMathInline str -> pure (DocMathInline str) DocMathDisplay str -> pure (DocMathDisplay str) diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 1c976410..42281470 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -23,15 +23,15 @@ import GHC hiding (NoLink) import Name import Outputable ( panic ) import RdrName (RdrName(Exact)) -import PrelNames (eqTyCon_RDR) +import TysWiredIn (eqTyCon_RDR) import Control.Applicative +import Control.Arrow ( first ) import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) - renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface renameInterface dflags renamingEnv warnings iface = @@ -92,56 +92,53 @@ renameInterface dflags renamingEnv warnings iface = -------------------------------------------------------------------------------- -- Monad for renaming --- --- The monad does two things for us: it passes around the environment for --- renaming, and it returns a list of names which couldn't be found in --- the environment. -------------------------------------------------------------------------------- +-- | The monad does two things for us: it passes around the environment for +-- renaming, and it returns a list of names which couldn't be found in +-- the environment. newtype RnM a = - RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function - -> (a,[Name]) + RnM { unRn :: (Name -> (Bool, DocName)) + -- Name lookup function. The 'Bool' indicates that if the name + -- was \"found\" in the environment. + + -> (a, [Name] -> [Name]) + -- Value returned, as well as a difference list of the names not + -- found } instance Monad RnM where - (>>=) = thenRn - return = pure + m >>= k = RnM $ \lkp -> let (a, out1) = unRn m lkp + (b, out2) = unRn (k a) lkp + in (b, out1 . out2) instance Functor RnM where - fmap f x = do a <- x; return (f a) + fmap f (RnM lkp) = RnM (first f . lkp) instance Applicative RnM where - pure = returnRn - (<*>) = ap - -returnRn :: a -> RnM a -returnRn a = RnM (const (a,[])) -thenRn :: RnM a -> (a -> RnM b) -> RnM b -m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of - (b,out2) -> (b,out1++out2)) - -getLookupRn :: RnM (Name -> (Bool, DocName)) -getLookupRn = RnM (\lkp -> (lkp,[])) - -outRn :: Name -> RnM () -outRn name = RnM (const ((),[name])) + pure a = RnM (const (a, id)) + mf <*> mx = RnM $ \lkp -> let (f, out1) = unRn mf lkp + (x, out2) = unRn mx lkp + in (f x, out1 . out2) +-- | Look up a 'Name' in the renaming environment. lookupRn :: Name -> RnM DocName -lookupRn name = do - lkp <- getLookupRn +lookupRn name = RnM $ \lkp -> case lkp name of - (False,maps_to) -> do outRn name; return maps_to - (True, maps_to) -> return maps_to - - -runRnFM :: LinkEnv -> RnM a -> (a,[Name]) -runRnFM env rn = unRn rn lkp + (False,maps_to) -> (maps_to, (name :)) + (True, maps_to) -> (maps_to, id) + +-- | Run the renamer action using lookup in a 'LinkEnv' as the lookup function. +-- Returns the renamed value along with a list of `Name`'s that could not be +-- renamed because they weren't in the environment. +runRnFM :: LinkEnv -> RnM a -> (a, [Name]) +runRnFM env rn = let (x, dlist) = unRn rn lkp in (x, dlist []) where - lkp n = case Map.lookup n env of - Nothing -> (False, Undocumented n) - Just mdl -> (True, Documented n mdl) + lkp n | isTyVarName n = (True, Undocumented n) + | otherwise = case Map.lookup n env of + Nothing -> (False, Undocumented n) + Just mdl -> (True, Documented n mdl) -------------------------------------------------------------------------------- @@ -600,13 +597,16 @@ renameTyFamInstEqn eqn rename_ty_fam_eqn :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn) -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI)) - rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = rhs }) + rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = rhs }) = do { tc' <- renameL tc + ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLType pats ; rhs' <- renameLType rhs ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } @@ -620,6 +620,7 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs ; rhs' <- renameLType rhs ; return (L loc (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = Nothing -- this is always Nothing , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } @@ -633,13 +634,16 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) rename_data_fam_eqn :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn) -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI)) - rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats - , feqn_fixity = fixity, feqn_rhs = defn }) + rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs + , feqn_pats = pats, feqn_fixity = fixity + , feqn_rhs = defn }) = do { tc' <- renameL tc + ; bndrs' <- traverse (mapM renameLTyVarBndr) bndrs ; pats' <- mapM renameLType pats ; defn' <- renameDataDefn defn ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tc' + , feqn_bndrs = bndrs' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 30931c26..e9511e3d 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -47,14 +47,13 @@ specialize specs = go spec_map0 -- one by one, we should avoid infinite loops. spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs +{-# SPECIALIZE specialize :: [(Name, HsType GhcRn)] -> HsType GhcRn -> HsType GhcRn #-} -- | Instantiate given binders with corresponding types. -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: Data a - => LHsQTyVars GhcRn -> [HsType GhcRn] - -> a -> a +specializeTyVarBndrs :: LHsQTyVars GhcRn -> [HsType GhcRn] -> HsType GhcRn -> HsType GhcRn specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where @@ -64,11 +63,12 @@ specializeTyVarBndrs bndrs typs = bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" + specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] -> PseudoFamilyDecl GhcRn -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = - decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} + decl {pfdTyVars = map (fmap (specializeTyVarBndrs bndrs typs)) (pfdTyVars decl)} specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index ce6ecc78..e1d8dbe1 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,8 +82,8 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) -binaryInterfaceVersion = 33 +#if (__GLASGOW_HASKELL__ >= 807) && (__GLASGOW_HASKELL__ < 809) +binaryInterfaceVersion = 34 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -190,8 +190,9 @@ readInterfaceFile :: forall m. MonadIO m => NameCacheAccessor m -> FilePath + -> Bool -- ^ Disable version check. Can cause runtime crash. -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename = do +readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do bh0 <- liftIO $ readBinMem filename magic <- liftIO $ get bh0 @@ -200,7 +201,8 @@ readInterfaceFile (get_name_cache, set_name_cache) filename = do case () of _ | magic /= binaryInterfaceMagic -> return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename - | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + | not bypass_checks + , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $ "Interface file is of wrong version: " ++ filename | otherwise -> with_name_cache $ \update_nc -> do @@ -432,7 +434,7 @@ instance Binary Example where result <- get bh return (Example expression result) -instance Binary Hyperlink where +instance Binary a => Binary (Hyperlink a) where put_ bh (Hyperlink url label) = do put_ bh url put_ bh label diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index bdc98406..e314bbd0 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -84,6 +84,7 @@ data Flag | Flag_Version | Flag_CompatibleInterfaceVersions | Flag_InterfaceVersion + | Flag_BypassInterfaceVersonCheck | Flag_UseContents String | Flag_GenContents | Flag_UseIndex String @@ -175,6 +176,8 @@ options backwardsCompat = "output compatible interface file versions and exit", Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) "output interface file version and exit", + Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck) + "bypass the interface file version check (dangerous)", Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") "set verbosity level", Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") @@ -186,7 +189,7 @@ options backwardsCompat = Option [] ["gen-index"] (NoArg Flag_GenIndex) "generate an HTML index from specified\ninterfaces", Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) - "behave as if all modules have the\nignore-exports atribute", + "behave as if all modules have the\nignore-exports attribute", Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["show"] (ReqArg Flag_ShowModule "MODULE") diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 6da45a3b..39df598a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -467,7 +467,7 @@ instance NFData ModuleName where rnf x = seq x () instance NFData id => NFData (Header id) where rnf (Header a b) = a `deepseq` b `deepseq` () -instance NFData Hyperlink where +instance NFData id => NFData (Hyperlink id) where rnf (Hyperlink a b) = a `deepseq` b `deepseq` () instance NFData Picture where diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index c2cdddf7..0ce99fb2 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -33,6 +33,7 @@ module Haddock.Utils ( -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + writeUtf8File, -- * HTML cross reference mapping html_xrefs_ref, html_xrefs_ref', @@ -75,7 +76,7 @@ import Data.List ( isSuffixOf ) import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit -import System.IO ( hPutStr, stderr ) +import System.IO ( hPutStr, hSetEncoding, IOMode(..), stderr, utf8, withFile ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath import Distribution.Verbosity @@ -395,6 +396,15 @@ isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') isDigitChar c = c >= '0' && c <= '9' isAlphaNumChar c = isAlphaChar c || isDigitChar c +-- | Utility to write output to UTF-8 encoded files. +-- +-- The problem with 'writeFile' is that it picks up its 'TextEncoding' from +-- 'getLocaleEncoding', and on some platforms (like Windows) this default +-- encoding isn't enough for the characters we want to write. +writeUtf8File :: FilePath -> String -> IO () +writeUtf8File filepath contents = withFile filepath WriteMode $ \h -> do + hSetEncoding h utf8 + hPutStr h contents ----------------------------------------------------------------------------- -- * HTML cross references diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index 0175b6af..971d8dc7 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,7 @@ +## TBA + + * Support inline markup in markdown-style links (#875) + ## Changes in version 1.7.0 * Make `Documentation.Haddock.Parser.Monad` an internal module diff --git a/haddock-library/fixtures/Fixtures.hs b/haddock-library/fixtures/Fixtures.hs index a4e4321f..72ea8525 100644 --- a/haddock-library/fixtures/Fixtures.hs +++ b/haddock-library/fixtures/Fixtures.hs @@ -146,8 +146,8 @@ instance (ToExpr mod, ToExpr id) => ToExpr (DocH mod id) deriving instance Generic (Header id) instance ToExpr id => ToExpr (Header id) -deriving instance Generic Hyperlink -instance ToExpr Hyperlink +deriving instance Generic (Hyperlink id) +instance ToExpr id => ToExpr (Hyperlink id) deriving instance Generic Picture instance ToExpr Picture diff --git a/haddock-library/fixtures/examples/link.parsed b/haddock-library/fixtures/examples/link.parsed index 0e85338c..781dee87 100644 --- a/haddock-library/fixtures/examples/link.parsed +++ b/haddock-library/fixtures/examples/link.parsed @@ -1,5 +1,5 @@ DocParagraph (DocHyperlink Hyperlink - {hyperlinkLabel = Just "link", + {hyperlinkLabel = Just (DocString "link"), hyperlinkUrl = "http://example.com"}) diff --git a/haddock-library/fixtures/examples/linkInline.parsed b/haddock-library/fixtures/examples/linkInline.parsed index 43470d7b..fe771598 100644 --- a/haddock-library/fixtures/examples/linkInline.parsed +++ b/haddock-library/fixtures/examples/linkInline.parsed @@ -3,4 +3,5 @@ DocParagraph (DocString "Bla ") (DocHyperlink Hyperlink - {hyperlinkLabel = Just "link", hyperlinkUrl = "http://example.com"})) + {hyperlinkLabel = Just (DocString "link"), + hyperlinkUrl = "http://example.com"})) diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.input b/haddock-library/fixtures/examples/linkInlineMarkup.input new file mode 100644 index 00000000..e2f4e405 --- /dev/null +++ b/haddock-library/fixtures/examples/linkInlineMarkup.input @@ -0,0 +1 @@ +Bla [link /emphasized/](http://example.com) diff --git a/haddock-library/fixtures/examples/linkInlineMarkup.parsed b/haddock-library/fixtures/examples/linkInlineMarkup.parsed new file mode 100644 index 00000000..39adab64 --- /dev/null +++ b/haddock-library/fixtures/examples/linkInlineMarkup.parsed @@ -0,0 +1,8 @@ +DocParagraph + (DocAppend + (DocString "Bla ") + (DocHyperlink + Hyperlink + {hyperlinkLabel = Just (DocAppend (DocString "link ") + (DocEmphasis (DocString "emphasized"))), + hyperlinkUrl = "http://example.com"})) diff --git a/haddock-library/fixtures/examples/urlLabel.parsed b/haddock-library/fixtures/examples/urlLabel.parsed index d7e3a76c..58d2a81a 100644 --- a/haddock-library/fixtures/examples/urlLabel.parsed +++ b/haddock-library/fixtures/examples/urlLabel.parsed @@ -1,5 +1,5 @@ DocParagraph (DocHyperlink Hyperlink - {hyperlinkLabel = Just "some link", + {hyperlinkLabel = Just (DocString "some link"), hyperlinkUrl = "http://example.com/"}) diff --git a/haddock-library/src/Documentation/Haddock/Markup.hs b/haddock-library/src/Documentation/Haddock/Markup.hs index da8edcd4..b44fef80 100644 --- a/haddock-library/src/Documentation/Haddock/Markup.hs +++ b/haddock-library/src/Documentation/Haddock/Markup.hs @@ -2,35 +2,38 @@ module Documentation.Haddock.Markup ( markup , idMarkup + , plainMarkup ) where import Documentation.Haddock.Types +import Data.Maybe ( fromMaybe ) + markup :: DocMarkupH mod id a -> DocH mod id -> a -markup m DocEmpty = markupEmpty m -markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) -markup m (DocString s) = markupString m s -markup m (DocParagraph d) = markupParagraph m (markup m d) -markup m (DocIdentifier x) = markupIdentifier m x -markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x -markup m (DocModule mod0) = markupModule m mod0 -markup m (DocWarning d) = markupWarning m (markup m d) -markup m (DocEmphasis d) = markupEmphasis m (markup m d) -markup m (DocBold d) = markupBold m (markup m d) -markup m (DocMonospaced d) = markupMonospaced m (markup m d) -markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) -markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) -markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) -markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocHyperlink l) = markupHyperlink m l -markup m (DocAName ref) = markupAName m ref -markup m (DocPic img) = markupPic m img -markup m (DocMathInline mathjax) = markupMathInline m mathjax -markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax -markup m (DocProperty p) = markupProperty m p -markup m (DocExamples e) = markupExample m e -markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) -markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink (Hyperlink u l)) = markupHyperlink m (Hyperlink u (fmap (markup m) l)) +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocMathInline mathjax) = markupMathInline m mathjax +markup m (DocMathDisplay mathjax) = markupMathDisplay m mathjax +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) +markup m (DocTable (Table h b)) = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b)) markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a) markupPair m (a,b) = (markup m a, markup m b) @@ -63,3 +66,34 @@ idMarkup = Markup { markupHeader = DocHeader, markupTable = DocTable } + +-- | Map a 'DocH' into a best estimate of an alternate string. The idea is to +-- strip away any formatting while preserving as much of the actual text as +-- possible. +plainMarkup :: (mod -> String) -> (id -> String) -> DocMarkupH mod id String +plainMarkup plainMod plainIdent = Markup { + markupEmpty = "", + markupString = id, + markupParagraph = id, + markupAppend = (<>), + markupIdentifier = plainIdent, + markupIdentifierUnchecked = plainMod, + markupModule = id, + markupWarning = id, + markupEmphasis = id, + markupBold = id, + markupMonospaced = id, + markupUnorderedList = const "", + markupOrderedList = const "", + markupDefList = const "", + markupCodeBlock = id, + markupHyperlink = \(Hyperlink url lbl) -> fromMaybe url lbl, + markupAName = id, + markupPic = \(Picture uri title) -> fromMaybe uri title, + markupMathInline = id, + markupMathDisplay = id, + markupProperty = id, + markupExample = const "", + markupHeader = \(Header _ title) -> title, + markupTable = const "" + } diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index d79da40b..f6c12d46 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -33,6 +33,7 @@ import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import qualified Data.Set as Set import Documentation.Haddock.Doc +import Documentation.Haddock.Markup ( markup, plainMarkup ) import Documentation.Haddock.Parser.Monad import Documentation.Haddock.Parser.Util import Documentation.Haddock.Types @@ -107,7 +108,7 @@ overIdentifier f d = g d g (DocOrderedList x) = DocOrderedList $ fmap g x g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x g (DocCodeBlock x) = DocCodeBlock $ g x - g (DocHyperlink x) = DocHyperlink x + g (DocHyperlink (Hyperlink u x)) = DocHyperlink (Hyperlink u (fmap g x)) g (DocPic x) = DocPic x g (DocMathInline x) = DocMathInline x g (DocMathDisplay x) = DocMathDisplay x @@ -301,13 +302,19 @@ mathInline = DocMathInline . T.unpack -- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]" -- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}" mathDisplay :: Parser (DocH mod a) -mathDisplay = DocMathDisplay . T.unpack +mathDisplay = DocMathDisplay . T.unpack <$> ("\\[" *> takeUntil "\\]") -markdownImage :: Parser (DocH mod a) -markdownImage = fromHyperlink <$> ("!" *> linkParser) +-- | Markdown image parser. As per the commonmark reference recommendation, the +-- description text for an image converted to its a plain string representation. +-- +-- >>> parseString "" +-- DocPic (Picture "www.site.com" (Just "some emphasis in a description")) +markdownImage :: Parser (DocH mod Identifier) +markdownImage = DocPic . fromHyperlink <$> ("!" *> linkParser) where - fromHyperlink (Hyperlink url label) = DocPic (Picture url label) + fromHyperlink (Hyperlink u l) = Picture u (fmap (markup stringMarkup) l) + stringMarkup = plainMarkup (const "") (\(l,c,r) -> [l] <> c <> [r]) -- | Paragraph parser, called by 'parseParas'. paragraph :: Parser (DocH mod Identifier) @@ -360,32 +367,34 @@ table = do parseFirstRow :: Parser Text parseFirstRow = do skipHorizontalSpace - -- upper-left corner is + - c <- Parsec.char '+' - cs <- some (Parsec.char '-' <|> Parsec.char '+') + cs <- takeWhile (\c -> c == '-' || c == '+') - -- upper right corner is + too - guard (last cs == '+') + -- upper-left and upper-right corners are `+` + guard (T.length cs >= 2 && + T.head cs == '+' && + T.last cs == '+') -- trailing space skipHorizontalSpace _ <- Parsec.newline - return (T.cons c $ T.pack cs) + return cs parseRestRows :: Int -> Parser Text parseRestRows l = do skipHorizontalSpace + bs <- scan predicate l - c <- Parsec.char '|' <|> Parsec.char '+' - bs <- scan predicate (l - 2) - c2 <- Parsec.char '|' <|> Parsec.char '+' + -- Left and right edges are `|` or `+` + guard (T.length bs >= 2 && + (T.head bs == '|' || T.head bs == '+') && + (T.last bs == '|' || T.last bs == '+')) -- trailing space skipHorizontalSpace _ <- Parsec.newline - return (T.cons c (T.snoc bs c2)) + return bs where predicate n c | n <= 0 = Nothing @@ -662,7 +671,7 @@ nonSpace xs -- Doesn't discard the trailing newline. takeNonEmptyLine :: Parser Text takeNonEmptyLine = do - l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace + l <- takeWhile1 (/= '\n') >>= nonSpace _ <- "\n" pure (l <> "\n") @@ -732,7 +741,7 @@ nonEmptyLine :: Parser Text nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine) takeLine :: Parser Text -takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine) +takeLine = try (takeWhile (/= '\n') <* endOfLine) endOfLine :: Parser () endOfLine = void "\n" <|> Parsec.eof @@ -742,7 +751,7 @@ endOfLine = void "\n" <|> Parsec.eof -- >>> snd <$> parseOnly property "prop> hello world" -- Right (DocProperty "hello world") property :: Parser (DocH mod a) -property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n")) +property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (/= '\n')) -- | -- Paragraph level codeblock. Anything between the two delimiting \@ is parsed @@ -782,22 +791,22 @@ codeblock = | isNewline && isSpace c = Just isNewline | otherwise = Just $ c == '\n' -hyperlink :: Parser (DocH mod a) +hyperlink :: Parser (DocH mod Identifier) hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ] angleBracketLink :: Parser (DocH mod a) angleBracketLink = - DocHyperlink . makeLabeled Hyperlink + DocHyperlink . makeLabeled (\s -> Hyperlink s . fmap DocString) <$> disallowNewline ("<" *> takeUntil ">") -markdownLink :: Parser (DocH mod a) +markdownLink :: Parser (DocH mod Identifier) markdownLink = DocHyperlink <$> linkParser -linkParser :: Parser Hyperlink +linkParser :: Parser (Hyperlink (DocH mod Identifier)) linkParser = flip Hyperlink <$> label <*> (whitespace *> url) where - label :: Parser (Maybe String) - label = Just . decode . T.strip <$> ("[" *> takeUntil "]") + label :: Parser (Maybe (DocH mod Identifier)) + label = Just . parseParagraph . T.strip <$> ("[" *> takeUntil "]") whitespace :: Parser () whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace) @@ -816,14 +825,14 @@ linkParser = flip Hyperlink <$> label <*> (whitespace *> url) autoUrl :: Parser (DocH mod a) autoUrl = mkLink <$> url where - url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace)) + url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (not . isSpace) mkLink :: Text -> DocH mod a mkLink s = case T.unsnoc s of Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x] _ -> DocHyperlink (mkHyperlink s) - mkHyperlink :: Text -> Hyperlink + mkHyperlink :: Text -> Hyperlink (DocH mod a) mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index a5664aa8..8f5bd217 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -9,10 +9,15 @@ module Documentation.Haddock.Parser.Monad where import qualified Text.Parsec.Char as Parsec import qualified Text.Parsec as Parsec +import Text.Parsec.Pos ( updatePosChar ) +import Text.Parsec ( State(..) + , getParserState, setParserState ) import qualified Data.Text as T import Data.Text ( Text ) +import Control.Monad ( mfilter ) +import Data.Functor ( ($>) ) import Data.String ( IsString(..) ) import Data.Bits ( Bits(..) ) import Data.Char ( ord ) @@ -20,7 +25,11 @@ import Data.List ( foldl' ) import Control.Applicative as App import Documentation.Haddock.Types ( Version ) +import Prelude hiding (takeWhile) +-- | The only bit of information we really care about truding along with us +-- through parsing is the version attached to a @\@since@ annotation - if +-- the doc even contained one. newtype ParserState = ParserState { parserStateSince :: Maybe Version } deriving (Eq, Show) @@ -29,7 +38,7 @@ initialParserState :: ParserState initialParserState = ParserState Nothing setSince :: Version -> Parser () -setSince since = Parsec.modifyState (\st -> st {parserStateSince = Just since}) +setSince since = Parsec.modifyState (\st -> st{ parserStateSince = Just since }) type Parser = Parsec.Parsec Text ParserState @@ -44,38 +53,75 @@ parseOnly p t = case Parsec.runParser p' initialParserState "<haddock>" t of -- | Always succeeds, but returns 'Nothing' if at the end of input. Does not -- consume input. +-- +-- Equivalent to @Parsec.optionMaybe . Parsec.lookAhead $ Parsec.anyChar@, but +-- more efficient. peekChar :: Parser (Maybe Char) -peekChar = Parsec.optionMaybe . Parsec.try . Parsec.lookAhead $ Parsec.anyChar +peekChar = headOpt . stateInput <$> getParserState + where headOpt t | T.null t = Nothing + | otherwise = Just (T.head t) +{-# INLINE peekChar #-} -- | Fails if at the end of input. Does not consume input. +-- +-- Equivalent to @Parsec.lookAhead Parsec.anyChar@, but more efficient. peekChar' :: Parser Char -peekChar' = Parsec.lookAhead Parsec.anyChar +peekChar' = headFail . stateInput =<< getParserState + where headFail t | T.null t = Parsec.parserFail "peekChar': reached EOF" + | otherwise = App.pure (T.head t) +{-# INLINE peekChar' #-} -- | Parses the given string. Returns the parsed string. +-- +-- Equivalent to @Parsec.string (T.unpack t) $> t@, but more efficient. string :: Text -> Parser Text -string t = Parsec.string (T.unpack t) *> App.pure t +string t = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + case T.stripPrefix t inp of + Nothing -> Parsec.parserFail "string: Failed to match the input string" + Just inp' -> + let pos' = T.foldl updatePosChar pos t + s' = s{ stateInput = inp', statePos = pos' } + in setParserState s' $> t + +-- | Keep matching characters as long as the predicate function holds (and +-- return them). +-- +-- Equivalent to @fmap T.pack . Parsec.many@, but more efficient. +takeWhile :: (Char -> Bool) -> Parser Text +takeWhile f = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + let (t, inp') = T.span f inp + pos' = T.foldl updatePosChar pos t + s' = s{ stateInput = inp', statePos = pos' } + setParserState s' $> t + + +-- | Like 'takeWhile', but fails if no characters matched. +-- +-- Equivalent to @fmap T.pack . Parsec.many1@, but more efficient. +takeWhile1 :: (Char -> Bool) -> Parser Text +takeWhile1 = mfilter (not . T.null) . takeWhile -- | Scan the input text, accumulating characters as long as the scanning -- function returns true. scan :: (s -> Char -> Maybe s) -- ^ scan function -> s -- ^ initial state -> Parser Text -scan f = fmap T.pack . go - where go s1 = do { cOpt <- peekChar - ; case cOpt >>= f s1 of - Nothing -> pure "" - Just s2 -> (:) <$> Parsec.anyChar <*> go s2 - } - --- | Apply a parser for a character zero or more times and collect the result in --- a string. -takeWhile :: Parser Char -> Parser Text -takeWhile = fmap T.pack . Parsec.many - --- | Apply a parser for a character one or more times and collect the result in --- a string. -takeWhile1 :: Parser Char -> Parser Text -takeWhile1 = fmap T.pack . Parsec.many1 +scan f st = do + s@State{ stateInput = inp, statePos = pos } <- getParserState + go inp st pos 0 $ \inp' pos' n -> + let s' = s{ Parsec.stateInput = inp', Parsec.statePos = pos' } + in setParserState s' $> T.take n inp + where + go inp s !pos !n cont + = case T.uncons inp of + Nothing -> cont inp pos n -- ran out of input + Just (c, inp') -> + case f s c of + Nothing -> cont inp pos n -- scan function failed + Just s' -> go inp' s' (updatePosChar pos c) (n+1) cont + -- | Parse a decimal number. decimal :: Integral a => Parser a diff --git a/haddock-library/src/Documentation/Haddock/Parser/Util.hs b/haddock-library/src/Documentation/Haddock/Parser/Util.hs index ffa91b09..98570c22 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Util.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Util.hs @@ -40,7 +40,7 @@ skipHorizontalSpace = Parsec.skipMany (Parsec.oneOf horizontalSpace) -- | Take leading horizontal space takeHorizontalSpace :: Parser Text -takeHorizontalSpace = takeWhile (Parsec.oneOf horizontalSpace) +takeHorizontalSpace = takeWhile (`elem` horizontalSpace) makeLabeled :: (String -> Maybe String -> a) -> Text -> a makeLabeled f input = case T.break isSpace $ removeEscapes $ T.strip input of diff --git a/haddock-library/src/Documentation/Haddock/Types.hs b/haddock-library/src/Documentation/Haddock/Types.hs index b5dea3d4..f8f7d353 100644 --- a/haddock-library/src/Documentation/Haddock/Types.hs +++ b/haddock-library/src/Documentation/Haddock/Types.hs @@ -65,10 +65,10 @@ overDocF f d = (\x -> d { _doc = x }) <$> f (_doc d) type Version = [Int] type Package = String -data Hyperlink = Hyperlink +data Hyperlink id = Hyperlink { hyperlinkUrl :: String - , hyperlinkLabel :: Maybe String - } deriving (Eq, Show) + , hyperlinkLabel :: Maybe id + } deriving (Eq, Show, Functor, Foldable, Traversable) data Picture = Picture { pictureUri :: String @@ -118,7 +118,7 @@ data DocH mod id | DocOrderedList [DocH mod id] | DocDefList [(DocH mod id, DocH mod id)] | DocCodeBlock (DocH mod id) - | DocHyperlink Hyperlink + | DocHyperlink (Hyperlink (DocH mod id)) | DocPic Picture | DocMathInline String | DocMathDisplay String @@ -147,7 +147,7 @@ instance Bifunctor DocH where bimap f g (DocOrderedList docs) = DocOrderedList (map (bimap f g) 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 _ _ (DocHyperlink hyperlink) = DocHyperlink hyperlink + bimap f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink (Hyperlink url (fmap (bimap f g) lbl)) bimap _ _ (DocPic picture) = DocPic picture bimap _ _ (DocMathInline s) = DocMathInline s bimap _ _ (DocMathDisplay s) = DocMathDisplay s @@ -192,7 +192,7 @@ instance Bitraversable DocH where bitraverse f g (DocOrderedList docs) = DocOrderedList <$> traverse (bitraverse f g) docs 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 _ _ (DocHyperlink hyperlink) = pure (DocHyperlink hyperlink) + bitraverse f g (DocHyperlink (Hyperlink url lbl)) = DocHyperlink <$> (Hyperlink url <$> traverse (bitraverse f g) lbl) bitraverse _ _ (DocPic picture) = pure (DocPic picture) bitraverse _ _ (DocMathInline s) = pure (DocMathInline s) bitraverse _ _ (DocMathDisplay s) = pure (DocMathDisplay s) @@ -227,7 +227,7 @@ data DocMarkupH mod id a = Markup , markupOrderedList :: [a] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a - , markupHyperlink :: Hyperlink -> a + , markupHyperlink :: Hyperlink a -> a , markupAName :: String -> a , markupPic :: Picture -> a , markupMathInline :: String -> a diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 0449c917..6269184a 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -37,7 +37,7 @@ parseParas = overDoc Parse.toRegular . Parse.parseParas Nothing parseString :: String -> Doc String parseString = Parse.toRegular . Parse.parseString -hyperlink :: String -> Maybe String -> Doc String +hyperlink :: String -> Maybe (Doc String) -> Doc String hyperlink url = DocHyperlink . Hyperlink url main :: IO () @@ -202,6 +202,10 @@ spec = do "[some label]( url)" `shouldParseTo` "[some label]( url)" + it "allows inline markup in the label" $ do + "[something /emphasized/](url)" `shouldParseTo` + hyperlink "url" (Just ("something " <> DocEmphasis "emphasized")) + context "when URL is on a separate line" $ do it "allows URL to be on a separate line" $ do "[some label]\n(url)" `shouldParseTo` diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index 942c0587..25c64cfe 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -34,12 +34,12 @@ data CheckResult runAndCheck :: Config c -> IO () runAndCheck cfg = do - runHaddock cfg - checkFiles cfg + crashed <- runHaddock cfg + checkFiles cfg crashed -checkFiles :: Config c -> IO () -checkFiles cfg@(Config { .. }) = do +checkFiles :: Config c -> Bool -> IO () +checkFiles cfg@(Config { .. }) somethingCrashed = do putStrLn "Testing output files..." files <- ignore <$> getDirectoryTree (cfgOutDir cfg) @@ -54,13 +54,14 @@ checkFiles cfg@(Config { .. }) = do Error msg -> putStrLn ("ERROR (" ++ msg ++ ")") >> return Nothing Accepted -> putStrLn "ACCEPTED" >> return Nothing - if null failed - then do - putStrLn "All tests passed!" - exitSuccess - else do - maybeDiff cfg failed - exitFailure + if (null failed && not somethingCrashed) + then do + putStrLn "All tests passed!" + exitSuccess + else do + unless (null failed) $ maybeDiff cfg failed + when somethingCrashed $ putStrLn "Some tests crashed." + exitFailure where ignore = filter (not . dcfgCheckIgnore cfgDirConfig) @@ -72,12 +73,14 @@ maybeDiff cfg@(Config { cfgDiffTool = (Just diff) }) files = do forM_ files $ diffFile cfg diff -runHaddock :: Config c -> IO () +-- | Runs Haddock on all of the test packages, and returns whether 'True' if +-- any of them caused Haddock to crash. +runHaddock :: Config c -> IO Bool runHaddock cfg@(Config { .. }) = do createEmptyDirectory $ cfgOutDir cfg putStrLn "Generating documentation..." - forM_ cfgPackages $ \tpkg -> do + successes <- forM cfgPackages $ \tpkg -> do haddockStdOut <- openFile cfgHaddockStdOut WriteMode let pc = processConfig { pcArgs = concat @@ -87,9 +90,20 @@ runHaddock cfg@(Config { .. }) = do ] , pcEnv = Just $ cfgEnv , pcStdOut = Just $ haddockStdOut + , pcStdErr = Just $ haddockStdOut } - handle <- runProcess' cfgHaddockPath pc - waitForSuccess "Failed to run Haddock on specified test files" handle + + let msg = "Failed to run Haddock on test package '" ++ tpkgName tpkg ++ "'" + succeeded <- waitForSuccess msg stdout =<< runProcess' cfgHaddockPath pc + unless succeeded $ removeDirectoryRecursive (outDir cfgDirConfig tpkg) + + pure succeeded + + let somethingFailed = any not successes + when somethingFailed $ + putStrLn ("Haddock output is at '" ++ cfgHaddockStdOut ++ "'. " ++ + "This file can be set with `--haddock-stdout`.") + pure somethingFailed checkFile :: Config c -> FilePath -> IO CheckResult diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 51032a3a..6447361f 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -196,6 +196,7 @@ loadConfig ccfg dcfg flags files = do cfgHaddockArgs <- liftM concat . sequence $ [ pure ["--no-warnings"] + , pure ["--bypass-interface-version-check"] , pure ["--odir=" ++ dcfgOutDir dcfg] , pure ["--optghc=-w"] , pure ["--optghc=-hide-all-packages"] @@ -223,13 +224,13 @@ printVersions env haddockPath = do { pcEnv = Just env , pcArgs = ["--version"] } - waitForSuccess "Failed to run `haddock --version`" handleHaddock + void $ waitForSuccess "Failed to run `haddock --version`" stderr handleHaddock handleGhc <- runProcess' haddockPath $ processConfig { pcEnv = Just env , pcArgs = ["--ghc-version"] } - waitForSuccess "Failed to run `haddock --ghc-version`" handleGhc + void $ waitForSuccess "Failed to run `haddock --ghc-version`" stderr handleGhc baseDependencies :: FilePath -> IO [String] diff --git a/haddock-test/src/Test/Haddock/Process.hs b/haddock-test/src/Test/Haddock/Process.hs index 52bf9533..a6cab9ac 100644 --- a/haddock-test/src/Test/Haddock/Process.hs +++ b/haddock-test/src/Test/Haddock/Process.hs @@ -40,10 +40,10 @@ runProcess' :: FilePath -> ProcessConfig -> IO ProcessHandle runProcess' path (ProcessConfig { .. }) = runProcess path pcArgs pcWorkDir pcEnv pcStdIn pcStdOut pcStdErr - -waitForSuccess :: String -> ProcessHandle -> IO () -waitForSuccess msg handle = do - result <- waitForProcess handle - unless (result == ExitSuccess) $ do - hPutStrLn stderr $ msg - exitFailure +-- | Wait for a process to finish running. If it ends up failing, print out the +-- error message. +waitForSuccess :: String -> Handle -> ProcessHandle -> IO Bool +waitForSuccess msg out handle = do + succeeded <- fmap (== ExitSuccess) $ waitForProcess handle + unless succeeded $ hPutStrLn out msg + pure succeeded diff --git a/haddock.cabal b/haddock.cabal index 0f99d16b..8285764a 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -78,7 +78,7 @@ executable haddock xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, ghc-boot, - ghc == 8.6.*, + ghc == 8.7.*, bytestring, parsec, text, diff --git a/html-test/ref/Bug865.html b/html-test/ref/Bug865.html new file mode 100644 index 00000000..c86d8ca3 --- /dev/null +++ b/html-test/ref/Bug865.html @@ -0,0 +1,88 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >Bug865</title + ><link href="#" rel="stylesheet" type="text/css" title="NewOcean" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><span class="caption empty" + ></span + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >Bug865</p + ></div + ><div id="synopsis" + ><details id="syn" + ><summary + >Synopsis</summary + ><ul class="details-toggle" data-details-id="syn" + ><li class="src short" + ><a href="#" + >link</a + > :: ()</li + ></ul + ></details + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a id="v:link" class="def" + >link</a + > :: () <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >An emphasized link <a href="#" + >yes <em + >this</em + > is emphasized while this is + <code + >monospaced</code + ></a + >. And here is an image:</p + ><p + ><img src="https://www.haskell.org/static/img/haskell-logo.svg" title="emphasis stripped" + /></p + ></div + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/ref/UnboxedStuff.html b/html-test/ref/UnboxedStuff.html new file mode 100644 index 00000000..133aae6c --- /dev/null +++ b/html-test/ref/UnboxedStuff.html @@ -0,0 +1,202 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >UnboxedStuff</title + ><link href="#" rel="stylesheet" type="text/css" title="NewOcean" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><span class="caption empty" + ></span + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >UnboxedStuff</p + ></div + ><div id="table-of-contents" + ><div id="contents-list" + ><p class="caption" onclick="window.scrollTo(0,0)" + >Contents</p + ><ul + ><li + ><a href="#" + >Unboxed type constructors</a + ></li + ></ul + ></div + ></div + ><div id="synopsis" + ><details id="syn" + ><summary + >Synopsis</summary + ><ul class="details-toggle" data-details-id="syn" + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >X</a + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >Y</a + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >Z</a + ></li + ><li class="src short" + ><a href="#" + >unboxedUnit</a + > :: (# #) -> (# #)</li + ><li class="src short" + ><a href="#" + >unboxedTuple</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + >, <a href="#" title="UnboxedStuff" + >Z</a + > #)</li + ><li class="src short" + ><a href="#" + >unboxedSum</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > | <a href="#" title="UnboxedStuff" + >Z</a + > #)</li + ></ul + ></details + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:X" class="def" + >X</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:Y" class="def" + >Y</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:Z" class="def" + >Z</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><a href="#" id="g:1" + ><h1 + >Unboxed type constructors</h1 + ></a + ><div class="top" + ><p class="src" + ><a id="v:unboxedUnit" class="def" + >unboxedUnit</a + > :: (# #) -> (# #) <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:unboxedTuple" class="def" + >unboxedTuple</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + >, <a href="#" title="UnboxedStuff" + >Y</a + >, <a href="#" title="UnboxedStuff" + >Z</a + > #) <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:unboxedSum" class="def" + >unboxedSum</a + > :: (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > #) -> (# <a href="#" title="UnboxedStuff" + >X</a + > | <a href="#" title="UnboxedStuff" + >Y</a + > | <a href="#" title="UnboxedStuff" + >Z</a + > #) <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/src/Bug865.hs b/html-test/src/Bug865.hs new file mode 100644 index 00000000..71a6add1 --- /dev/null +++ b/html-test/src/Bug865.hs @@ -0,0 +1,9 @@ +module Bug865 where + +-- | An emphasized link [yes /this/ is emphasized while this is +-- @monospaced@](https://www.haskell.org/). And here is an image: +-- +--  +-- +link :: () +link = () diff --git a/html-test/src/UnboxedStuff.hs b/html-test/src/UnboxedStuff.hs new file mode 100644 index 00000000..bd1b1302 --- /dev/null +++ b/html-test/src/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex new file mode 100644 index 00000000..36d5c12b --- /dev/null +++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex @@ -0,0 +1,36 @@ +\haddockmoduleheading{UnboxedStuff} +\label{module:UnboxedStuff} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module UnboxedStuff ( + X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ X +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Y +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Z +\end{tabular}] +\end{haddockdesc} +\section{Unboxed type constructors} +\begin{haddockdesc} +\item[ +unboxedUnit\ ::\ ({\char '43}\ {\char '43})\ ->\ ({\char '43}\ {\char '43}) +] +\item[ +unboxedTuple\ ::\ ({\char '43}\ X,\ Y\ {\char '43})\ ->\ ({\char '43}\ X,\ Y,\ Z\ {\char '43}) +] +\item[ +unboxedSum\ ::\ ({\char '43}\ X\ |\ Y\ {\char '43})\ ->\ ({\char '43}\ X\ |\ Y\ |\ Z\ {\char '43}) +] +\end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/haddock.sty b/latex-test/ref/UnboxedStuff/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/UnboxedStuff/main.tex b/latex-test/ref/UnboxedStuff/main.tex new file mode 100644 index 00000000..e34c5f14 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{UnboxedStuff} +\end{document}
\ No newline at end of file diff --git a/latex-test/src/UnboxedStuff/UnboxedStuff.hs b/latex-test/src/UnboxedStuff/UnboxedStuff.hs new file mode 100644 index 00000000..bd1b1302 --- /dev/null +++ b/latex-test/src/UnboxedStuff/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + |