diff options
73 files changed, 3506 insertions, 1777 deletions
diff --git a/.travis.yml b/.travis.yml index e3e6cd62..681399b9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,8 @@ # This Travis job script has been generated by a script via # -# make_travis_yml_2.hs 'haddock.cabal' +# runghc make_travis_yml_2.hs 'haddock.cabal' # -# For more information, see https://github.com/hvr/multi-ghc-travis +# For more information, see https://github.com/haskell-CI/haskell-ci # language: c sudo: false @@ -24,51 +24,67 @@ before_cache: - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $HOME/.cabal/packages/head.hackage + matrix: include: - - compiler: "ghc-8.4.3" + - compiler: "ghc-8.6.1" # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.3], sources: [hvr-ghc]}} + addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.6.1], sources: [hvr-ghc]}} before_install: - - HC=${CC} - - unset CC - - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH - - PKGNAME='haddock' + - 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 install: - - cabal --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - BENCH=${BENCH---enable-benchmarks} - - TEST=${TEST---enable-tests} - - travis_retry cabal update -v - - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - - rm -fv cabal.project.local - - rm -f cabal.project.freeze - - travis_retry cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 --allow-newer=base,Cabal --constraint 'setup.Cabal installed' all - - travis_retry cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 --allow-newer=base,Cabal --constraint 'setup.Cabal installed' all + - 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) # 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=base,Cabal --constraint 'setup.Cabal installed' all - # this builds all libraries and executables (including tests/benchmarks) - # - rm -rf ./dist-newstyle + - 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 + + # 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 + + # cabal check + - cabal check - # build & run tests - - cabal new-build -w ${HC} ${TEST} ${BENCH} --allow-newer=base,Cabal --constraint 'setup.Cabal installed' all - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} --allow-newer=base,Cabal --constraint 'setup.Cabal installed' all; fi + # 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 +# REGENDATA ["haddock.cabal"] # EOF @@ -1,4 +1,21 @@ -## Changes in version 2.19.1 +## TBA + + * Make `--package-version` optional for `--hoogle` (#899) + +## Changes in version 2.21.0 + + * Overhaul handling of data declarations in XHTML and LaTeX. Adds support for + documenting individual arguments of constructors/patterns (#709) + + * Actually list all fixities for `--hoogle` (#871) + + * Fix broken instance source links (#869) + + * Avoiding line breaks due to ling line in the output of `--hoogle` (#868) + + * Capture docs on type family instances (#867) + +## Changes in version 2.20.0 * Show where instances are defined (#748) @@ -38,11 +55,17 @@ This notably fixes rendering of quasiquotes. * Overhaul Haddock's rendering of kind signatures so that invisible kind - parameters are not printed (#681) + parameters are not printed (#681) (Fixes #544) * Recognise `SPDX-License-Identifier` as alias for `License` in module header parser (#743) + * Remove the response file related utilities, and use the ones that + come with `base` (Trac #13896) + + * Remove the response file related utilities, and use the ones that + come with `base` (Trac #13896) + ## Changes in version 2.18.1 * Synopsis is working again (#599) @@ -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.4.1 +cabal new-build -w ghc-8.6.1 # build & run the test suite -cabal new-test -w ghc-8.4.1 all +cabal new-test -w ghc-8.6.1 all ``` #### Using Cabal sandboxes diff --git a/doc/markup.rst b/doc/markup.rst index edbd45b2..4e00f708 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -39,6 +39,8 @@ the following: - A ``data`` declaration, +- A ``pattern`` declaration, + - A ``newtype`` declaration, - A ``type`` declaration @@ -118,6 +120,15 @@ Constructors are documented like so: :: or like this: :: data T a b + = C1 -- ^ This is the documentation for the 'C1' constructor + a -- ^ This is the documentation for the argument of type 'a' + b -- ^ This is the documentation for the argument of type 'b' + +There is one edge case that is handled differently: only one ``-- ^`` +annotation occuring after the constructor and all its arguments is +applied to the constructor, not its last argument: :: + + data T a b = C1 a b -- ^ This is the documentation for the 'C1' constructor | C2 a b -- ^ This is the documentation for the 'C2' constructor @@ -164,6 +175,9 @@ 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. + .. _module-description: The Module Description diff --git a/driver-test/Main.hs b/driver-test/Main.hs deleted file mode 100644 index d3f636e9..00000000 --- a/driver-test/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - -import Test.Hspec (describe, hspec, Spec) -import qualified ResponseFileSpec (spec) - - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "ResponseFile" ResponseFileSpec.spec diff --git a/driver-test/ResponseFileSpec.hs b/driver-test/ResponseFileSpec.hs deleted file mode 100644 index 997adac4..00000000 --- a/driver-test/ResponseFileSpec.hs +++ /dev/null @@ -1,80 +0,0 @@ -module ResponseFileSpec where - -import Test.Hspec (context, describe, it, shouldBe, Spec) -import ResponseFile (escapeArgs, unescapeArgs) - --- The first two elements are --- 1) a list of 'args' to encode and --- 2) a single string of the encoded args --- The 3rd element is just a description for the tests. -testStrs :: [(([String], String), String)] -testStrs = - [ ((["a simple command line"], - "a\\ simple\\ command\\ line\n"), - "the white-space, end with newline") - - , ((["arg 'foo' is single quoted"], - "arg\\ \\'foo\\'\\ is\\ single\\ quoted\n"), - "the single quotes as well") - - , ((["arg \"bar\" is double quoted"], - "arg\\ \\\"bar\\\"\\ is\\ double\\ quoted\n"), - "the double quotes as well" ) - - , ((["arg \"foo bar\" has embedded whitespace"], - "arg\\ \\\"foo\\ bar\\\"\\ has\\ embedded\\ whitespace\n"), - "the quote-embedded whitespace") - - , ((["arg 'Jack said \\'hi\\'' has single quotes"], - "arg\\ \\'Jack\\ said\\ \\\\\\'hi\\\\\\'\\'\\ has\\ single\\ quotes\n"), - "the escaped single quotes") - - , ((["arg 'Jack said \\\"hi\\\"' has double quotes"], - "arg\\ \\'Jack\\ said\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ double\\ quotes\n"), - "the escaped double quotes") - - , ((["arg 'Jack said\\r\\n\\t \\\"hi\\\"' has other whitespace"], - "arg\\ \\'Jack\\ said\\\\r\\\\n\\\\t\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ \ - \other\\ whitespace\n"), - "the other whitespace") - - , (([ "--prologue=.\\dist\\.\\haddock-prologue3239114604.txt" - , "--title=HaddockNewline-0.1.0.0: This has a\n\ - \newline yo." - , "-BC:\\Program Files\\Haskell Platform\\lib"], - "--prologue=.\\\\dist\\\\.\\\\haddock-prologue3239114604.txt\n\ - \--title=HaddockNewline-0.1.0.0:\\ This\\ has\\ a\\\n\ - \newline\\ yo.\n\ - \-BC:\\\\Program\\ Files\\\\Haskell\\ Platform\\\\lib\n"), - "an actual haddock response file snippet with embedded newlines") - ] - -spec :: Spec -spec = do - describe "escapeArgs" $ do - mapM_ (\((ss1,s2),des) -> do - context ("given " ++ (show ss1)) $ do - it ("should escape " ++ des) $ do - escapeArgs ss1 `shouldBe` s2 - ) testStrs - describe "unescapeArgs" $ do - mapM_ (\((ss1,s2),des) -> do - context ("given " ++ (show s2)) $ do - it ("should unescape " ++ des) $ do - unescapeArgs s2 `shouldBe` ss1 - ) testStrs - describe "unescapeArgs" $ do - context "given unescaped single quotes" $ do - it "should pass-through, without escaping, everything inside" $ do - -- backslash *always* is escaped anywhere it appears - (filter (not . null) $ - unescapeArgs "this\\ is\\ 'not escape\\d \"inside\"'\\ yo\n") - `shouldBe` - ["this is not escaped \"inside\" yo"] - context "given unescaped double quotes" $ do - it "should pass-through, without escaping, everything inside" $ do - -- backslash *always* is escaped anywhere it appears - (filter (not . null) $ - unescapeArgs "this\\ is\\ \"not escape\\d 'inside'\"\\ yo\n") - `shouldBe` - ["this is not escaped 'inside' yo"] diff --git a/driver/Main.hs b/driver/Main.hs index 852f44c7..44df4692 100644 --- a/driver/Main.hs +++ b/driver/Main.hs @@ -1,8 +1,7 @@ module Main where import Documentation.Haddock (haddock) -import ResponseFile (expandResponse) -import System.Environment (getArgs) +import GHC.ResponseFile (getArgsWithResponseFiles) main :: IO () -main = getArgs >>= expandResponse >>= haddock +main = getArgsWithResponseFiles >>= haddock diff --git a/driver/ResponseFile.hs b/driver/ResponseFile.hs deleted file mode 100644 index 253c6004..00000000 --- a/driver/ResponseFile.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module ResponseFile ( - unescapeArgs, - escapeArgs, - expandResponse - ) where - -import Control.Exception -import Data.Char (isSpace) -import Data.Foldable (foldl') -import System.Exit (exitFailure) -import System.IO - - --- | Given a string of concatenated strings, separate each by removing --- a layer of /quoting/ and\/or /escaping/ of certain characters. --- --- These characters are: any whitespace, single quote, double quote, --- and the backslash character. The backslash character always --- escapes (i.e., passes through without further consideration) the --- character which follows. Characters can also be escaped in blocks --- by quoting (i.e., surrounding the blocks with matching pairs of --- either single- or double-quotes which are not themselves escaped). --- --- Any whitespace which appears outside of either of the quoting and --- escaping mechanisms, is interpreted as having been added by this --- special concatenation process to designate where the boundaries --- are between the original, un-concatenated list of strings. These --- added whitespace characters are removed from the output. --- --- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - --- | Given a list of strings, concatenate them into a single string --- with escaping of certain characters, and the addition of a newline --- between each string. The escaping is done by adding a single --- backslash character before any whitespace, single quote, double --- quote, or backslash character, so this escaping character must be --- removed. Unescaped whitespace (in this case, newline) is part --- of this "transport" format to indicate the end of the previous --- string and the start of a new string. --- --- While 'unescapeArgs' allows using quoting (i.e., convenient --- escaping of many characters) by having matching sets of single- or --- double-quotes,'escapeArgs' does not use the quoting mechasnism, --- and thus will always escape any whitespace, quotes, and --- backslashes. --- --- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\"" -escapeArgs :: [String] -> String -escapeArgs = unlines . map escapeArg - --- | Arguments which look like '@foo' will be replaced with the --- contents of file @foo@. A gcc-like syntax for response files arguments --- is expected. This must re-constitute the argument list by doing an --- inverse of the escaping mechanism done by the calling-program side. --- --- We quit if the file is not found or reading somehow fails. --- (A convenience routine for haddock or possibly other clients) -expandResponse :: [String] -> IO [String] -expandResponse = fmap concat . mapM expand - where - expand :: String -> IO [String] - expand ('@':f) = readFileExc f >>= return . unescapeArgs - expand x = return [x] - - readFileExc f = - readFile f `catch` \(e :: IOException) -> do - hPutStrLn stderr $ "Error while expanding response file: " ++ show e - exitFailure - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -escapeArg :: String -> String -escapeArg = reverse . foldl' escape [] - -escape :: String -> Char -> String -escape cs c - | isSpace c - || '\\' == c - || '\'' == c - || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result - | otherwise = c:cs diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index b2d7829c..fa14eb50 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -1,13 +1,13 @@ cabal-version: 2.0 name: haddock-api -version: 2.20.0 +version: 2.21.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries license: BSD3 license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> +maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern @@ -40,11 +40,11 @@ library default-language: Haskell2010 -- this package typically supports only single major versions - build-depends: base ^>= 4.11.0 - , Cabal ^>= 2.2.0 - , ghc ^>= 8.4 + build-depends: base ^>= 4.12.0 + , Cabal ^>= 2.4.0 + , ghc ^>= 8.6 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.6.0 + , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 -- Versions for the dependencies below are transitively pinned by @@ -166,10 +166,10 @@ test-suite spec Haddock.Backends.Hyperlinker.Parser Haddock.Backends.Hyperlinker.Types - build-depends: Cabal ^>= 2.2 - , ghc ^>= 8.4 + build-depends: Cabal ^>= 2.4 + , ghc ^>= 8.6 , ghc-paths ^>= 0.1.0.9 - , haddock-library ^>= 1.6.0 + , haddock-library ^>= 1.7.0 , xhtml ^>= 3000.2.2 , hspec >= 2.4.4 && < 2.6 , QuickCheck ^>= 2.11 diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 1651866a..dbfba0f4 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -76,6 +76,7 @@ import Packages import Panic (handleGhcException) import Module import FastString +import qualified DynamicLoading -------------------------------------------------------------------------------- -- * Exception handling @@ -442,7 +443,10 @@ withGhc' libDir flags ghcActs = runGhc (Just libDir) $ do -- that may need to be re-linked: Haddock doesn't do any -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags'' - ghcActs dynflags'' + hscenv <- GHC.getSession + dynflags''' <- liftIO (DynamicLoading.initializePlugins hscenv dynflags'') + _ <- setSessionDynFlags dynflags''' + ghcActs dynflags''' where -- ignore sublists of flags that start with "+RTS" and end in "-RTS" diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index a89ac2c7..885c608b 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -75,23 +76,22 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a e) = HsForAllTy a (g e) - f (HsQualTy a e) = HsQualTy a (g e) - f (HsBangTy a b) = HsBangTy a (g b) - f (HsAppTy a b) = HsAppTy (g a) (g b) - f (HsFunTy a b) = HsFunTy (g a) (g b) - f (HsListTy a) = HsListTy (g a) - f (HsPArrTy a) = HsPArrTy (g a) - f (HsTupleTy a b) = HsTupleTy a (map g b) - f (HsOpTy a b c) = HsOpTy (g a) b (g c) - f (HsParTy a) = HsParTy (g a) - f (HsKindSig a b) = HsKindSig (g a) b - f (HsDocTy a _) = f $ unL a + f (HsForAllTy x a e) = HsForAllTy x a (g e) + f (HsQualTy x a e) = HsQualTy x a (g e) + f (HsBangTy x a b) = HsBangTy x a (g b) + f (HsAppTy x a b) = HsAppTy x (g a) (g b) + f (HsFunTy x a b) = HsFunTy x (g a) (g b) + f (HsListTy x a) = HsListTy x (g a) + f (HsTupleTy x a b) = HsTupleTy x a (map g b) + f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) + f (HsParTy x a) = HsParTy x (g a) + f (HsKindSig x a b) = HsKindSig x (g a) b + f (HsDocTy _ a _) = f $ unL a f x = x -outHsType :: (SourceTextX a, OutputableBndrId a) +outHsType :: (a ~ GhcPass p, OutputableBndrId a) => DynFlags -> HsType a -> String -outHsType dflags = out dflags . dropHsDocTy +outHsType dflags = out dflags . reparenType . dropHsDocTy dropComment :: String -> String @@ -127,20 +127,20 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl ++ ppFixities where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (TyClD (FamDecl d)) = ppFam dflags d - f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (SigD sig) = ppSig dflags sig + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (TyClD _ (FamDecl _ d)) = ppFam dflags d + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (SigD _ sig) = ppSig dflags sig f _ = [] ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs +ppSigWithDoc dflags (TypeSig _ names sig) subdocs = concatMap mkDocSig names where mkDocSig n = mkSubdoc dflags n subdocs [pp_sig dflags [n] (hsSigWcType sig)] @@ -191,7 +191,7 @@ ppClass dflags decl subdocs = , tcdTyVars = feqn_pats tfe , tcdFixity = feqn_fixity tfe , tcdRhs = feqn_rhs tfe - , tcdFVs = emptyNameSet + , tcdSExt = emptyNameSet } ppFam :: DynFlags -> FamilyDecl GhcRn -> [String] @@ -203,6 +203,7 @@ ppFam dflags decl@(FamilyDecl { fdInfo = info }) -- for Hoogle, so pretend it doesn't have any. ClosedTypeFamily{} -> decl { fdInfo = OpenTypeFamily } _ -> decl +ppFam _ XFamilyDecl {} = panic "ppFam" ppInstance :: DynFlags -> ClsInst -> [String] ppInstance dflags x = @@ -242,17 +243,17 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat - [(concatMap (lookupCon dflags subdocs . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy x y) - apps = foldl1 (\x y -> reL $ HsAppTy x y) + funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -260,20 +261,20 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] -ppCtor dflags _dat subdocs con@ConDeclGADT {} +ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where - f = [typeSig name (hsib_body $ con_type con)] + f = [typeSig name (getGADTConTypeG con)] typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con - +ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index c4a9091f..0ecf7109 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -13,6 +13,7 @@ import Haddock.Backends.Hyperlinker.Types import qualified GHC import qualified SrcLoc +import qualified Outputable as GHC import Control.Applicative import Control.Monad (guard) @@ -79,9 +80,9 @@ variables = everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> + (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of @@ -95,9 +96,9 @@ types = everythingInRenamedSource ty where ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) - (Just ((GHC.L sspan (GHC.HsOpTy l name r)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) -> (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) _ -> empty @@ -112,20 +113,20 @@ binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) - (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ args _ _))) -> + (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) -> pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args _ -> empty patsyn_binds term = case cast term of (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) _ -> empty pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty rec term = case cast term of @@ -133,9 +134,9 @@ binds = everythingInRenamedSource pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -150,16 +151,17 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ _ -> pure . decl $ name - GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.SynDecl _ name _ _ _ -> pure . decl $ name + GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs ++ concatMap tyfam tcdATs + GHC.XTyClDecl {} -> GHC.panic "haddock:decls" fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) - (Just (GHC.PatSynBind (GHC.PSB (GHC.L sspan name) _ _ _ _))) + (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _))) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -168,24 +170,27 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of Just (field :: GHC.ConDeclField GHC.GhcRn) - -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field + -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field Nothing -> empty fix term = case cast term of - Just ((GHC.FixitySig names _) :: GHC.FixitySig GHC.GhcRn) + Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn) -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names + Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) + -> GHC.panic "haddock:decls" Nothing -> empty tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] - sig (GHC.L _ (GHC.TypeSig names _)) = map decl names - sig (GHC.L _ (GHC.PatSynSig names _)) = map decl names - sig (GHC.L _ (GHC.ClassOpSig _ names _)) = map decl names + tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" + sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names + sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names + sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) @@ -199,12 +204,12 @@ imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith t _ vs _fls)) -> + (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingWith _ t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs - (Just (GHC.IEModuleContents m)) -> pure $ modu m + (Just (GHC.IEModuleContents _ m)) -> pure $ modu m _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) var (GHC.L sspan name) = (sspan, RtkVar name) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 456050d1..acb2c892 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -234,6 +234,7 @@ classify tok = ITqualified -> TkKeyword ITthen -> TkKeyword ITtype -> TkKeyword + ITvia -> TkKeyword ITwhere -> TkKeyword ITforall {} -> TkKeyword @@ -284,9 +285,6 @@ classify tok = IToptions_prag {} -> TkPragma ITinclude_prag {} -> TkPragma ITlanguage_prag -> TkPragma - ITvect_prag {} -> TkPragma - ITvect_scalar_prag {} -> TkPragma - ITnovect_prag {} -> TkPragma ITminimal_prag {} -> TkPragma IToverlappable_prag {} -> TkPragma IToverlapping_prag {} -> TkPragma @@ -305,11 +303,11 @@ classify tok = ITrarrow {} -> TkGlyph ITat -> TkGlyph ITtilde -> TkGlyph - ITtildehsh -> TkGlyph ITdarrow {} -> TkGlyph ITminus -> TkGlyph ITbang -> TkGlyph ITdot -> TkOperator + ITstar {} -> TkOperator ITtypeApp -> TkGlyph ITbiglam -> TkGlyph @@ -431,9 +429,6 @@ inPragma False tok = IToptions_prag {} -> True ITinclude_prag {} -> True ITlanguage_prag -> True - ITvect_prag {} -> True - ITvect_scalar_prag {} -> True - ITnovect_prag {} -> True ITminimal_prag {} -> True IToverlappable_prag {} -> True IToverlapping_prag {} -> True diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 38fccf0c..4a3e9d03 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -27,7 +27,7 @@ import GHC import OccName import Name ( nameOccName ) import RdrName ( rdrNameOcc ) -import FastString ( unpackFS, unpackLitString, zString ) +import FastString ( unpackFS ) import Outputable ( panic) import qualified Data.Map as Map @@ -169,23 +169,16 @@ ppLaTeXModule _title odir iface = do body = processExports exports -- - writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) - - -string_txt :: TextDetails -> String -> String -string_txt (Chr c) s = c:s -string_txt (Str s1) s2 = s1 ++ s2 -string_txt (PStr s1) s2 = unpackFS s1 ++ s2 -string_txt (ZStr s1) s2 = zString s1 ++ s2 -string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - + writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 txtPrinter "" tex) +-- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } - = sep (punctuate comma . map ppDocBinder $ declNames decl) <> - case subdocs of - [] -> empty - _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) + = let (leader, names) = declNames decl + in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) exportListItem (ExportNoDecl y []) = ppDocBinder y exportListItem (ExportNoDecl y subs) @@ -215,7 +208,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -249,13 +242,17 @@ ppDocGroup lev doc = sec lev <> braces doc sec _ = text "\\paragraph" -declNames :: LHsDecl DocNameI -> [DocName] +-- | Given a declaration, extract out the names being declared +declNames :: LHsDecl DocNameI + -> ( LaTeX -- ^ to print before each name in an export list + , [DocName] -- ^ names being declared + ) declNames (L _ decl) = case decl of - TyClD d -> [tcdName d] - SigD (TypeSig lnames _ ) -> map unLoc lnames - SigD (PatSynSig lnames _) -> map unLoc lnames - ForD (ForeignImport (L _ n) _ _ _) -> [n] - ForD (ForeignExport (L _ n) _ _ _) -> [n] + TyClD _ d -> (empty, [tcdName d]) + SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) + ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) + ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -278,47 +275,44 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c) -- * Decls ------------------------------------------------------------------------------- - -ppDecl :: LHsDecl DocNameI - -> [(HsDecl DocNameI, DocForDecl DocName)] - -> DocForDecl DocName - -> [DocInstance DocNameI] - -> [(DocName, DocForDecl DocName)] - -> [(DocName, Fixity)] +-- | Pretty print a declaration +ppDecl :: LHsDecl DocNameI -- ^ decl to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ all pattern decls + -> DocForDecl DocName -- ^ documentation for decl + -> [DocInstance DocNameI] -- ^ all instances + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs + -> [(DocName, Fixity)] -- ^ all fixities -> LaTeX -ppDecl (L loc decl) pats (doc, fnArgsDoc) instances subdocs _fixities = case decl of - TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode - TyClD d@(DataDecl {}) - -> ppDataDecl pats instances subdocs loc (Just doc) d unicode - TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode +ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of + TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@(TySynonym {}) +-- TyClD _ d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) - (hsSigWcType t) unicode - SigD (PatSynSig lnames ty) -> - ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor loc (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty + TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD _ d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ _ -> empty + DerivD _ _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False -ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> +ppTyFam :: Bool -> Documentation DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTyFam _ _ _ _ _ = +ppTyFam _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = - ppFunSig loc doc [name] (hsSigType typ) unicode -ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX +ppFor doc (ForeignImport _ (L _ name) typ _) unicode = + ppFunSig doc [name] (hsSigType typ) unicode +ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -328,18 +322,18 @@ ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX +ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars +ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype -ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" +ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- @@ -347,61 +341,98 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI +ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI -> Bool -> LaTeX -ppFunSig loc doc docnames (L _ typ) unicode = - ppTypeOrFunSig loc docnames typ doc +ppFunSig doc docnames (L _ typ) unicode = + ppTypeOrFunSig typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names - , dcolon unicode) + , dcolon unicode + ) unicode where names = map getName docnames -ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] - -> LHsSigType DocNameI - -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) docnames ty unicode - = declWithDoc pref1 (documentationToLaTeX doc) +-- | Pretty-print a pattern synonym +ppLPatSig :: DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsSigType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppLPatSig doc docnames ty unicode + = ppTypeOrFunSig typ doc + ( keyword "pattern" <+> ppTypeSig names typ False + , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) + , dcolon unicode + ) + unicode where - pref1 = hsep [ keyword "pattern" - , hsep $ punctuate comma $ map ppDocBinder docnames - , dcolon unicode - , ppLType unicode (hsSigType ty) - ] - -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI - -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) - -> Bool -> LaTeX -ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) - unicode - | Map.null argDocs = - declWithDoc pref1 (documentationToLaTeX doc) - | otherwise = - declWithDoc pref2 $ Just $ + typ = unLoc (hsSigType ty) + names = map getName docnames + +-- | Pretty-print a type, adding documentation to the whole type and its +-- arguments as needed. +ppTypeOrFunSig :: HsType DocNameI + -> DocForDecl DocName -- ^ documentation + -> ( LaTeX -- ^ first-line (no-argument docs only) + , LaTeX -- ^ first-line (argument docs only) + , LaTeX -- ^ type prefix (argument docs only) + ) + -> Bool -- ^ unicode + -> LaTeX +ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode + | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ - do_args 0 sep0 typ $$ + vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$ text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) + +-- This splits up a type signature along `->` and adds docs (when they exist) +-- to the arguments. The output is a list of (leader/seperator, argument and +-- its doc) +ppSubSigLike :: Bool -- ^ unicode + -> HsType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) + -> LaTeX -- ^ seperator (beginning of first line) + -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) +ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ where - do_largs n leader (L _ t) = do_args n leader t - - arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - - do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX - do_args _n leader (HsForAllTy tvs ltype) - = decltt leader - <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) - <+> ppLType unicode ltype - do_args n leader (HsQualTy lctxt ltype) - = decltt leader - <-> ppLContextNoArrow lctxt unicode <+> nl $$ - do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy lt r) - = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ - do_largs (n+1) (arrow unicode) r - do_args n leader t - = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs + + do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] + do_args _n leader (HsForAllTy _ tvs ltype) + = [ ( decltt leader + , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + ) ] + do_args n leader (HsQualTy _ lctxt ltype) + = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) + : do_largs n (darrow unicode) ltype + + do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + = [ (decltt ldr, latex <+> nl) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let latex = ppSideBySideField subdocs unicode field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + do_args n leader (HsFunTy _ lt r) + = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," + gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" + gadtOpen = text "\\{" ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -483,10 +514,10 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) -ppClassDecl :: [DocInstance DocNameI] -> SrcSpan +ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX -ppClassDecl instances loc doc subdocs +ppClassDecl instances doc subdocs (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ @@ -508,15 +539,15 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc [name] (hsSigWcType typ) unicode - | L _ (TypeSig lnames typ) <- lsigs + vcat [ ppFunSig doc [name] (hsSigWcType typ) unicode + | L _ (TypeSig _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs ] instancesBit = ppDocInstances unicode instances -ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty @@ -565,15 +596,17 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of -- * Data & newtype declarations ------------------------------------------------------------------------------- - -ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] -> - [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool -> - LaTeX -ppDataDecl pats instances subdocs _loc doc dataDecl unicode - - = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) - (if null body then Nothing else Just (vcat body)) +-- | Pretty-print a data declaration +ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, DocForDecl DocName)] -- ^ relevant decl docs + -> Maybe (Documentation DocName) -- ^ this decl's docs + -> TyClDecl DocNameI -- ^ data decl to print + -> Bool -- ^ unicode + -> LaTeX +ppDataDecl pats instances subdocs doc dataDecl unicode = + declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -585,28 +618,26 @@ ppDataDecl pats instances subdocs _loc doc dataDecl unicode (whereBit, leaders) | null cons , null pats = (empty,[]) - | null cons = (decltt (keyword "where"), repeat empty) + | null cons = (text "where", repeat empty) | otherwise = case resTy of - ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (text "where", repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing | otherwise = Just $ + text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" patternBit - | null cons = Nothing + | null pats = Nothing | otherwise = Just $ + text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ - vcat [ hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppDocBinder . unLoc) lnames - , dcolon unicode - , ppLType unicode (hsSigType ty) - ] <-> rDoc (fmap _doc . combineDocumentation . fst $ d) - | (SigD (PatSynSig lnames ty),d) <- pats + vcat [ empty <-> ppSideBySidePat lnames typ d unicode + | (SigD _ (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" @@ -625,62 +656,102 @@ ppConstrHdr forall tvs ctxt unicode False -> empty -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocNameI -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = - leader <-> - case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl +-- | Pretty-print a constructor +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs + -> Bool -- ^ unicode + -> LaTeX -- ^ prefix to decl + -> LConDecl DocNameI -- ^ constructor decl + -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> decltt decl <-> rDoc mbDoc <+> nl + $$ fieldPart + where + -- Find the name of a constructors in the decl (`getConName` always returns + -- a non-empty list) + aConName = unLoc (head (getConNames con)) + + occ = map (nameOccName . getName . unLoc) $ getConNames con + + ppOcc = cat (punctuate comma (map ppBinder occ)) + ppOccInfix = cat (punctuate comma (map ppBinderInfix occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + -- First line of the constructor (no doc, no fields, single-line) + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon args + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppOcc + , hsep (map (ppLParendType unicode) args) + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ <+> ppOcc + + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppLParendType unicode arg1 + , ppOccInfix + , ppLParendType unicode arg2 + ] + + ConDeclGADT{} + | hasArgDocs || not (isEmpty fieldPart) -> ppOcc + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLType unicode (getGADTConType con) + ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" + + fieldPart = case (con, getConArgs con) of + -- Record style GADTs + (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] + + -- Regular record declarations + (_, RecCon (L _ fields)) -> doRecordFields fields + + -- Any GADT or a regular H98 prefix data constructor + (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args + + -- An infix H98 data constructor + (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] + + _ -> empty - where doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - - header_ = ppConstrHdr False tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case getConNames con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = - leader <-> - doGADTCon (hsib_body $ con_type con) + vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl + | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields + ] + $$ + empty <-> tt (text "\\qquad \\}") <+> nl - where - doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode resTy - ) <-> rDoc mbDoc + doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of + ConDeclH98{} -> + [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + [ l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) + ] + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. @@ -688,127 +759,50 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = [] -> panic "empty con_names" (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst -{- old - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L loc con) = - leader <-> - case con_res con of - ResTyH98 -> case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl - - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) - ) <-> rDoc mbDoc - header_ = ppConstrHdr (con_explicit con) tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) - | otherwise = ty - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case con_names con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) --} - +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . 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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst - --- {- --- ppHsFullConstr :: HsConDecl -> LaTeX --- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = --- declWithDoc False doc ( --- hsep ((ppHsConstrHdr tvs ctxt +++ --- ppHsBinder False nm) : map ppHsBangType typeList) --- ) --- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = --- td << vanillaTable << ( --- case doc of --- Nothing -> aboves [hdr, fields_html] --- Just _ -> aboves [hdr, constr_doc, fields_html] --- ) --- --- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) --- --- constr_doc --- | isJust doc = docBox (docToLaTeX (fromJust doc)) --- | otherwise = LaTeX.emptyTable --- --- fields_html = --- td << --- table ! [width "100%", cellpadding 0, cellspacing 8] << ( --- aboves (map ppFullField (concat (map expandField fields))) --- ) --- -} --- --- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX --- ppShortField summary unicode (ConDeclField (L _ name) ltype _) --- = tda [theclass "recfield"] << ( --- ppBinder summary (docNameOcc name) --- <+> dcolon unicode <+> ppLType unicode ltype --- ) --- --- {- --- ppFullField :: HsFieldDecl -> LaTeX --- ppFullField (HsFieldDecl [n] ty doc) --- = declWithDoc False doc ( --- ppHsBinder False n <+> dcolon <+> ppHsBangType ty --- ) --- ppFullField _ = error "ppFullField" --- --- expandField :: HsFieldDecl -> [HsFieldDecl] --- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --- -} + mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst +ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" + + +-- | Pretty-print a bundled pattern synonym +ppSideBySidePat :: [Located DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> Bool -- ^ unicode + -> LaTeX +ppSideBySidePat lnames typ (doc, argDocs) unicode = + decltt decl <-> rDoc mDoc <+> nl + $$ fieldPart + where + hasArgDocs = not $ Map.null argDocs + ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppLType unicode (hsSigType typ) + ] + + fieldPart + | not hasArgDocs = empty + | otherwise = vcat + [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + ] + + patTy = hsSigType typ + + mDoc = fmap _doc $ combineDocumentation doc -- | Print the LHS of a data\/newtype declaration. @@ -824,6 +818,7 @@ ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" + -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- @@ -911,24 +906,6 @@ sumParens = ubxparens . hsep . punctuate (text " | ") -- Stolen from Html and tweaked for LaTeX generation ------------------------------------------------------------------------------- - -pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC -pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX ppLType unicode y = ppType unicode (unLoc y) ppLParendType unicode y = ppParendType unicode (unLoc y) @@ -936,78 +913,70 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX -ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode -ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode -ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode +ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode +ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode ppLKind :: Bool -> LHsKind DocNameI -> LaTeX ppLKind unicode y = ppKind unicode (unLoc y) ppKind :: Bool -> HsKind DocNameI -> LaTeX -ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode +ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX -ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode - - -ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot - , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode - = maybeParen ctxt_prec pREC_FUN $ - sep [ ppLContext ctxt unicode - , ppr_mono_lty pREC_TOP ty unicode ] - -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name -ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" -ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode - = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode +ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX +ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode + + +ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX +ppr_mono_ty (HsForAllTy _ tvs ty) unicode + = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot + , ppr_mono_lty ty unicode ] +ppr_mono_ty (HsQualTy _ ctxt ty) unicode + = sep [ ppLContext ctxt unicode + , ppr_mono_lty ty unicode ] +ppr_mono_ty (HsFunTy _ ty1 ty2) u + = sep [ ppr_mono_lty ty1 u + , arrow u <+> ppr_mono_lty ty2 u ] + +ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name +ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) +ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u) +ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsRecTy {}) _ = text "{..}" +ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode + = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] + +ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode + = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode where ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op occName = nameOccName . getName . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode - -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode - = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty (HsParTy _ ty) unicode + = parens (ppr_mono_lty ty unicode) +-- = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' +ppr_mono_ty (HsDocTy _ ty _) unicode + = ppr_mono_lty ty unicode -ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" +ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u +ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_tylit :: HsTyLit -> Bool -> LaTeX @@ -1017,15 +986,6 @@ ppr_tylit (HsStrTy _ s) _ = text (show s) -- XXX: Do something with Unicode parameter? -ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX -ppr_fun_ty ctxt_prec ty1 ty2 unicode - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode - p2 = ppr_mono_lty pREC_TOP ty2 unicode - in - maybeParen ctxt_prec pREC_FUN $ - sep [p1, arrow unicode <+> p2] - - ------------------------------------------------------------------------------- -- * Names ------------------------------------------------------------------------------- @@ -1036,6 +996,11 @@ ppBinder n | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isInfixName n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] + isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n @@ -1267,12 +1232,12 @@ quote :: LaTeX -> LaTeX quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" -dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX +dcolon, arrow, darrow, forallSymbol, starSymbol :: Bool -> LaTeX dcolon unicode = text (if unicode then "∷" else "::") arrow unicode = text (if unicode then "→" else "->") darrow unicode = text (if unicode then "⇒" else "=>") forallSymbol unicode = text (if unicode then "∀" else "forall") - +starSymbol unicode = text (if unicode then "★" else "*") dot :: LaTeX dot = char '.' @@ -1290,10 +1255,6 @@ ubxparens :: LaTeX -> LaTeX ubxparens h = text "(#" <> h <> text "#)" -pabrackets :: LaTeX -> LaTeX -pabrackets h = text "[:" <> h <> text ":]" - - nl :: LaTeX nl = text "\\\\" diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c9a262a4..6da6a2e8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -667,7 +667,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances processExport summary _ _ pkg qual (ExportGroup lev id0 doc) = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) pkg qual (mkMeta doc) processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 01380c94..cc271fef 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,24 +39,34 @@ import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) - -ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI - -> [(HsDecl DocNameI, DocForDecl DocName)] - -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] - -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode - -> Maybe Package -> Qualification -> Html +import Outputable ( panic ) + +-- | Pretty print a declaration +ppDecl :: Bool -- ^ print summary info only + -> LinksInfo -- ^ link information + -> LHsDecl DocNameI -- ^ declaration to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant pattern synonyms + -> DocForDecl DocName -- ^ documentation for this decl + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls + -> Splice + -> Unicode -- ^ unicode output + -> Maybe Package + -> Qualification + -> Html ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of - TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual - TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual - TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual - TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual - SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames + TyClD _ (FamDecl _ d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode pkg qual + TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual + TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual + TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual + SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode pkg qual - SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - ty fixities splice unicode pkg qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual - InstD _ -> noHtml - DerivD _ -> noHtml + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigType lty) fixities splice unicode pkg qual + ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual + InstD _ _ -> noHtml + DerivD _ _ -> noHtml _ -> error "declaration not supported by ppDecl" @@ -76,21 +86,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode pkg qual = where pp_typ = ppLType unicode qual HideEmptyContexts typ -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocNameI -> - [(DocName, Fixity)] -> - Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice - unicode pkg qual - | summary = pref1 - | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing pkg qual doc +-- | Pretty print a pattern synonym +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> [Located DocName] -- ^ names of patterns in declaration + -> LHsType DocNameI -- ^ type of patterns in declaration + -> [(DocName, Fixity)] + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html +ppLPatSig summary links loc doc lnames typ fixities splice unicode pkg qual = + ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities + (unLoc typ, pp_typ) splice unicode pkg qual (patSigContext typ) where - pref1 = hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames - , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) - ] + pp_typ = ppPatSigType unicode qual typ + ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> @@ -99,7 +106,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) splice unicode pkg qual emptyCtxts = ppTypeOrFunSig summary links loc docnames typ doc ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode - , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames + , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) splice unicode pkg qual emptyCtxts @@ -118,36 +125,72 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode pkg qual emptyCtxts | summary = pref1 | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName pkg qual doc - | otherwise = topDeclElem links loc splice docnames pref2 +++ - subArguments pkg qual (do_args 0 sep typ) +++ docSection curName pkg qual doc + | otherwise = topDeclElem links loc splice docnames pref2 + +++ subArguments pkg qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) + +++ docSection curName pkg qual doc where curName = getName <$> listToMaybe docnames + + +-- This splits up a type signature along `->` and adds docs (when they exist) to +-- the arguments. +-- +-- If one passes in a list of the available subdocs, any top-level `HsRecTy` +-- found will be expanded out into their fields. +ppSubSigLike :: Unicode -> Qualification + -> HsType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when + -- we expand an `HsRecTy`) + -> Html -> HideEmptyContexts -> [SubDecl] +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ + where argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy tvs ltype) + do_args n leader (HsForAllTy _ tvs ltype) = do_largs n leader' ltype where leader' = leader <+> ppForAll tvs unicode qual - do_args n leader (HsQualTy lctxt ltype) + do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy lt r) + do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) + = [ (ldr <+> html, mdoc, subs) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + + do_args n leader (HsFunTy _ lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r + do_args n leader t = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" + gadtOpen = toHtml "{" + + + ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of + case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -186,7 +229,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Maybe Package -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities +ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode pkg qual = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode pkg qual ppFor _ _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -279,12 +322,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ClosedTypeFamily _ -> keyword "where ..." _ -> mempty ) +ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + NoSig _ -> noHtml + KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + XFamilyResultSig _ -> panic "haddock:ppResultSig" ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html @@ -330,6 +375,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) + ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" + ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" @@ -363,6 +410,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode pkg qual = ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) +ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html @@ -477,7 +525,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t [ ppFunSig summary links loc doc names (hsSigType typ) [] splice unicode pkg qual - | L _ (ClassOpSig False lnames typ) <- sigs + | L _ (ClassOpSig _ False lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -525,7 +573,7 @@ ppClassDecl summary links instances fixities loc d subdocs methodBit = subMethods [ ppFunSig summary links loc doc [name] (hsSigType typ) subfixs splice unicode pkg qual - | L _ (ClassOpSig _ lnames typ) <- lsigs + | L _ (ClassOpSig _ _ lnames typ) <- lsigs , name <- map unLoc lnames , let doc = lookupAnySubdoc name subdocs subfixs = [ f | f@(n',_) <- fixities @@ -534,15 +582,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- N.B. taking just the first name is ok. Signatures with multiple names -- are expanded so that each name gets its own signature. - minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of + minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | ClassOpSig _ ns _ <- sigs, L _ n <- ns] + sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (ClassOpSig _ ns _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (ClassOpSig _ _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -645,7 +693,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames typ <- sigs + TypeSig _ lnames typ <- sigs let names = map unLoc lnames L _ rtyp = hsSigWcType typ -- Instance methods signatures are synified and thus don't have a useful @@ -706,21 +754,27 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig lnames typ),_) <- pats + | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> - [(HsDecl DocNameI, DocForDecl DocName)] -> - Splice -> Unicode -> Maybe Package -> Qualification -> Html +-- | Pretty-print a data declaration +ppDataDecl :: Bool -> LinksInfo + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ all decl documentation + -> SrcSpan + -> Documentation DocName -- ^ this decl's documentation + -> TyClDecl DocNameI -- ^ this decl + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> Splice -> Unicode -> Maybe Package -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode pkg qual @@ -733,6 +787,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -749,25 +804,20 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode pkg qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNames (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] patternBit = subPatterns pkg qual - [ (hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames - , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) - ] <+> ppFixities subfixs qual - ,combineDocumentation (fst d), []) - | (SigD (PatSynSig lnames typ),d) <- pats - , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities + [ ppSideBySidePat subfixs unicode qual lnames typ d + | (SigD _ (PatSynSig _ lnames typ), d) <- pats + , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) + (map unLoc lnames)) fixities ] instancesBit = ppInstances links (OriginData docname) instances splice unicode pkg qual - ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where @@ -777,121 +827,183 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- returns three pieces: header, body, footer so that header & footer can be -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) -ppShortConstrParts summary dataInst con unicode qual = case con of - ConDeclH98{} -> case con_details con of - PrefixCon args -> - (header_ unicode qual +++ hsep (ppOcc - : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) - RecCon (L _ fields) -> - (header_ unicode qual +++ ppOcc <+> char '{', - doRecordFields fields, - char '}') - InfixCon arg1 arg2 -> - (header_ unicode qual +++ hsep [ppLParendType unicode qual HideEmptyContexts arg1, - ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], - noHtml, noHtml) - - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) - - where - resTy = hsib_body (con_type con) - - doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) - - header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder summary one - _ -> hsep (punctuate comma (map (ppBinder summary) occ)) +ppShortConstrParts summary dataInst con unicode qual + = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + + -- Prefix constructor, e.g. 'Just a' + PrefixCon args -> + ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + , noHtml + , noHtml + ) - ppOccInfix = case occ of - [one] -> ppBinderInfix summary one - _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon (L _ fields) -> + ( header_ +++ ppOcc <+> char '{' + , shortSubDecls dataInst [ ppShortField summary unicode qual field + | L _ field <- fields + ] + , char '}' + ) - ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) - tyVars = tyvarNames ltvs - lcontext = fromMaybe (noLoc []) (con_cxt con) - context = unLoc lcontext - forall_ = False + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 -> + ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts arg2 + ] + , noHtml + , noHtml + ) + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT {} -> + ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + , noHtml + , noHtml + ) + XConDecl {} -> panic "haddock:ppShortConstrParts" --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode - -> Qualification -> Html -ppConstrHdr forall_ tvs ctxt unicode qual - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual HideEmptyContexts - <+> darrow unicode +++ toHtml " ") where - ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " - | otherwise = noHtml + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) + +-- | Pretty print an expanded constructor ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Maybe Package -> Qualification -> LConDecl DocNameI -> SubDecl + -> Unicode -> Maybe Package -> Qualification + -> LConDecl DocNameI -- ^ constructor declaration to print + -> SubDecl ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con) - = (decl, mbDoc, fieldPart) + = ( decl -- Constructor header (name, fixity) + , mbDoc -- Docs on the whole constructor + , fieldPart -- Information on the fields (or arguments, if they have docs) + ) where - decl = case con of - ConDeclH98{} -> case con_details con of - PrefixCon args -> - hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual HideEmptyContexts) args) - <+> fixity + -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) + aConName = unLoc (head (getConNames con)) - RecCon _ -> header_ +++ ppOcc <+> fixity + fixity = ppFixities fixities qual + occ = map (nameOccName . getName . unLoc) $ getConNames con - InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, - ppOccInfix, - ppLParendType unicode qual HideEmptyContexts arg2] - <+> fixity + ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs - ConDeclGADT{} -> doGADTCon resTy + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon args + | hasArgDocs -> header_ +++ ppOcc <+> fixity + | otherwise -> hsep [ header_ +++ ppOcc + , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) + , fixity + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ +++ ppOcc <+> fixity - resTy = hsib_body (con_type con) + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ +++ ppOcc <+> fixity + | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts arg2 + , fixity + ] + + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT{} + | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , fixity + ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" + + fieldPart = case (con, getConArgs con) of + -- Record style GADTs + (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] + + -- Regular record declarations + (_, RecCon (L _ fields)) -> [ doRecordFields fields ] + + -- Any GADT or a regular H98 prefix data constructor + (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] + + -- An infix H98 data constructor + (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - fieldPart = case getConDetails con of - RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields pkg qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: Located (HsType DocNameI) -> Html - doGADTCon ty = ppOcc <+> dcolon unicode - -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual HideEmptyContexts ty - <+> fixity - - fixity = ppFixities fixities qual - header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder False one - _ -> hsep (punctuate comma (map (ppBinder False) occ)) + doConstrArgsWithDocs args = subFields pkg qual $ case con of + ConDeclH98{} -> + [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + ppSubSigLike unicode qual (unLoc (getGADTConType con)) + argDocs subdocs (dcolon unicode) HideEmptyContexts + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" - ppOccInfix = case occ of - [one] -> ppBinderInfix False one - _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) - forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: Bool -- ^ print explicit foralls + -> [Name] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification -> Html +ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt + where + ppForall + | null tvs || not forall_ = noHtml + | otherwise = forallSymbol unicode + <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + + ppCtxt + | null ctxt = noHtml + | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts + <+> darrow unicode +++ toHtml " " + + +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) +ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = + ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) + | L _ name <- names + , let field = (unLoc . rdrNameFieldOcc) name + ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype , mbDoc @@ -900,13 +1012,49 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = 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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst +ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html -ppShortField summary unicode qual (ConDeclField names ltype _) +ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" + + +-- | Pretty print an expanded pattern (for bundled patterns) +ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification + -> [Located DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> SubDecl +ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = + ( decl + , combineDocumentation doc + , fieldPart + ) + where + hasArgDocs = not $ Map.null argDocs + fixity = ppFixities fixities qual + ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppPatSigType unicode qual (hsSigType typ) + , fixity + ] + + fieldPart + | not hasArgDocs = [] + | otherwise = [ subFields Nothing qual (ppSubSigLike unicode qual (unLoc patTy) + argDocs [] (dcolon unicode) + emptyCtxt) ] + + patTy = hsSigType typ + emptyCtxt = patSigContext patTy -- | Print the LHS of a data\/newtype declaration. @@ -953,129 +1101,112 @@ sumParens = ubxSumList -- * Rendering of HsType -------------------------------------------------------------------------------- - -pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int - -pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC -pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type - -- (as opposed to (ctx1, ctx2) => type) -pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC - -- Used for LH arg of (->) -pREC_OP = 3 :: Int -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = 4 :: Int -- Used for arg of type applicn: - -- always parenthesise unless atomic - -maybeParen :: Int -- Precedence of context - -> Int -- Precedence of top-level operator - -> Html -> Html -- Wrap in parens if (ctxt >= op) -maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p - | otherwise = p - - ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y) ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y) ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html -ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts +ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html -ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts -ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts -ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts +ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts +ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts +ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html -ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = +ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar name kind) = +ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) +ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr" ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html -ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts +ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html -ppPatSigType unicode qual typ = - let emptyCtxts = - if hasNonEmptyContext typ && isFirstContextEmpty typ - then ShowEmptyToplevelContexts - else HideEmptyContexts - in ppLType unicode qual emptyCtxts typ +patSigContext :: LHsType name -> HideEmptyContexts +patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = case unLoc t of - HsForAllTy _ s -> hasNonEmptyContext s - HsQualTy cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True - HsFunTy _ s -> hasNonEmptyContext s + HsForAllTy _ _ s -> hasNonEmptyContext s + HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True + HsFunTy _ _ s -> hasNonEmptyContext s _ -> False isFirstContextEmpty :: LHsType name -> Bool isFirstContextEmpty t = case unLoc t of - HsForAllTy _ s -> isFirstContextEmpty s - HsQualTy cxt _ -> null (unLoc cxt) - HsFunTy _ s -> isFirstContextEmpty s + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ s -> isFirstContextEmpty s _ -> False + +-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in +-- the right 'HideEmptyContext' value) +ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot -ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) +ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts - = maybeParen ctxt_prec pREC_FUN $ - ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts +ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html +ppr_mono_ty (HsForAllTy _ tvs ty) unicode qual emptyCtxts + = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts - = maybeParen ctxt_prec pREC_FUN $ - ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP 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 -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar _ (L _ name)) True _ _ - | getOccString (getName name) == "*" = toHtml "★" +ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _ | getOccString (getName name) == "(->)" = toHtml "(→)" -ppr_mono_ty _ (HsBangTy b ty) u q _ = ppBang b +++ ppLParendType u q HideEmptyContexts ty -ppr_mono_ty _ (HsTyVar _ (L _ name)) _ q _ = ppDocName q Prefix True name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q e = ppr_fun_ty ctxt_prec ty1 ty2 u q e -ppr_mono_ty _ (HsTupleTy con tys) u q _ = tupleParens con (map (ppLType u q HideEmptyContexts) tys) -ppr_mono_ty _ (HsSumTy tys) u q _ = sumParens (map (ppLType u q HideEmptyContexts) tys) -ppr_mono_ty _ (HsKindSig ty kind) u q e = - parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind) -ppr_mono_ty _ (HsListTy ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty _ (HsPArrTy ty) u q _ = pabrackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts) -ppr_mono_ty ctxt_prec (HsIParamTy (L _ n) ty) u q _ = - maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts -ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}" +ppr_mono_ty (HsBangTy _ b ty) u q _ = + ppBang b +++ ppLParendType u q HideEmptyContexts ty +ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ = + ppDocName q Prefix True name +ppr_mono_ty (HsStarTy _ isUni) u _ _ = + toHtml (if u || isUni then "★" else "*") +ppr_mono_ty (HsFunTy _ ty1 ty2) u q e = + hsep [ ppr_mono_lty ty1 u q HideEmptyContexts + , arrow u <+> ppr_mono_lty ty2 u q e + ] +ppr_mono_ty (HsTupleTy _ con tys) u q _ = + tupleParens con (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty (HsSumTy _ tys) u q _ = + sumParens (map (ppLType u q HideEmptyContexts) tys) +ppr_mono_ty (HsKindSig _ ty kind) u q e = + parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts) +ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ = + ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts +ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}" -- Can now legally occur in ConDeclGADT, the output here is to provide a -- placeholder in the signature, which is followed by the field -- declarations. -ppr_mono_ty _ (HsCoreTy {}) _ _ _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys -ppr_mono_ty _ (HsAppsTy {}) _ _ _ = error "ppr_mono_ty HsAppsTy" - -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual _ - = maybeParen ctxt_prec pREC_CTX $ - ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts - -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual _ - = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts] - -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ - = maybeParen ctxt_prec pREC_FUN $ - ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts +ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _ + = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts + , ppr_mono_lty arg_ty 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 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. @@ -1084,24 +1215,17 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode qual _ | otherwise = ppr_op' ppr_op' = ppLDocName qual Infix op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual emptyCtxts --- = parens (ppr_mono_lty pREC_TOP ty) - = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts +ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts + = parens (ppr_mono_lty ty unicode qual emptyCtxts) +-- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts - = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts +ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts + = ppr_mono_lty ty unicode qual emptyCtxts -ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' -ppr_mono_ty _ (HsTyLit n) _ _ _ = ppr_tylit n +ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_' +ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) -ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts - = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts - p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts - in - maybeParen ctxt_prec pREC_FUN $ - hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index a75c4b9a..7fbaec6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -110,7 +110,7 @@ renderToString debug html hsep :: [Html] -> Html hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls +hsep htmls = foldr1 (<+>) htmls -- | Concatenate a series of 'Html' values vertically, with linebreaks in between. vcat :: [Html] -> Html @@ -232,4 +232,4 @@ collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] -- and displays a control. collapseControl :: String -> String -> [HtmlAttr] collapseControl id_ classes = collapseToggle id_ cs - where cs = unwords (words classes ++ ["details-toggle-control"])
\ No newline at end of file + where cs = unwords (words classes ++ ["details-toggle-control"]) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 7595f798..6eee353b 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -36,8 +36,8 @@ import TyCon import Type import TyCoRep import TysPrim ( alphaTyVars ) -import TysWiredIn ( listTyConName, starKindTyConName, unitTy ) -import PrelNames ( hasKey, eqTyConKey, ipClassKey +import TysWiredIn ( listTyConName, liftedTypeKindTyConName, unitTy ) +import PrelNames ( hasKey, eqTyConKey, eqTyConName, ipClassKey , tYPETyConKey, liftedRepDataConKey ) import Unique ( getUnique ) import Util ( chkAppend, compareLength, dropList, filterByList, filterOut @@ -61,14 +61,14 @@ tyThingToLHsDecl t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl d) = return $ noLoc d + extractFamilyDecl (FamDecl _ d) = return $ noLoc d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" @@ -76,7 +76,7 @@ tyThingToLHsDecl t = case t of atFamDecls = map extractFamilyDecl (rights atTyClDecls) tyClErrors = lefts atTyClDecls famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl + in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) @@ -84,7 +84,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -92,20 +92,20 @@ tyThingToLHsDecl t = case t of , tcdATs = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNamesTc } + , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD + -> synifyTyCon Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -118,9 +118,10 @@ 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_vars = map tyVarName tkvs - , hsib_closed = True - , hsib_body = FamEqn { feqn_tycon = name + in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs + , hsib_closed = True } + , hsib_body = FamEqn { feqn_ext = noExt + , feqn_tycon = name , feqn_pats = annot_typats , feqn_fixity = Prefix , feqn_rhs = hs_rhs } } @@ -131,13 +132,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD - $ TyFamInstD + = return $ InstD noExt + $ TyFamInstD noExt $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD + = synifyTyCon (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" @@ -150,25 +151,27 @@ synifyTyCon _coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) + = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_implicit = [] -- No kind polymorphism + in HsQTvs { hsq_ext = + HsQTvsRn { hsq_implicit = [] -- No kind polymorphism + , hsq_dependent = emptyNameSet } , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * - , hsq_dependent = emptyNameSet } + } , tcdFixity = Prefix - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + , tcdDataDefn = HsDataDefn { dd_ext = noExt + , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing - , dd_kindSig = synifyDataTyConReturnKind tc + , dd_kindSig = Just (synifyKindSig (tyConKind tc)) -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } - , tcdDataCusk = False - , tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } synifyTyCon _coax tc | Just flav <- famTyConFlav_maybe tc @@ -189,8 +192,9 @@ synifyTyCon _coax tc -> mkFamDecl DataFamily where resultVar = famTcResVar tc - mkFamDecl i = return $ FamDecl $ - FamilyDecl { fdInfo = i + mkFamDecl i = return $ FamDecl noExt $ + FamilyDecl { fdExt = noExt + , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = Prefix @@ -203,11 +207,11 @@ synifyTyCon _coax tc synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc - = return $ SynDecl { tcdLName = synifyName tc + = return $ SynDecl { tcdSExt = emptyNameSet + , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNamesTc } + , tcdRhs = synifyType WithinType ty } | otherwise = -- (closed) newtype and data let @@ -240,7 +244,8 @@ synifyTyCon coax tc cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = noLoc [] - defn = HsDataDefn { dd_ND = alg_nd + defn = HsDataDefn { dd_ext = noExt + , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = kindSig @@ -250,7 +255,7 @@ synifyTyCon coax tc [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs -- In this module, every TyCon being considered has come from an interface @@ -284,9 +289,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) = synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = - noLoc $ KindSig (synifyKindSig kind) + noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc 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 @@ -304,10 +309,6 @@ synifyDataCon use_gadt_syntax dc = -- con_qvars means a different thing depending on gadt-syntax (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc - qvars = if use_gadt_syntax - then synifyTyVars (univ_tvs ++ ex_tvs) - else synifyTyVars ex_tvs - -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta @@ -316,12 +317,12 @@ synifyDataCon use_gadt_syntax dc = let tySyn = synifyType WithinType ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy bang' tySyn) + bang' -> noLoc $ HsBangTy noExt bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $ - ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -330,45 +331,51 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] (synifyType WithinType res_ty) False -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_names = [name] - , con_type = gadt_ty - , con_doc = Nothing } + ConDeclGADT { con_g_ext = noExt + , con_names = [name] + , con_forall = noLoc True + , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) + , con_mb_cxt = Just ctx + , con_args = hat + , con_res_ty = synifyType WithinType res_ty + , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_name = name - , con_qvars = Just qvars - , con_cxt = Just ctx - , con_details = hat - , con_doc = Nothing } + ConDeclH98 { con_ext = noExt + , con_name = name + , con_forall = noLoc True + , con_ex_tvs = map synifyTyVar ex_tvs + , con_mb_cxt = Just ctx + , con_args = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) +synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) +synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn -synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs - , hsq_dependent = emptyNameSet } +synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] + , hsq_dependent = emptyNameSet } + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) + | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name)) + | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -385,7 +392,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType ki - in noLoc (HsKindSig hs_ty hs_ki) + in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every type variable in the input, @@ -430,7 +437,7 @@ synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) = maybe_sig res_ty where @@ -440,41 +447,46 @@ synifyType _ (TyConApp tc tys) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) + = noLoc (HsTyVar noExt NotPromoted (noLoc liftedTypeKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys - = noLoc $ HsTupleTy (case sort of + = noLoc $ HsTupleTy noExt + (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy (synifyType WithinType ty) + noLoc $ HsListTy noExt (synifyType WithinType ty) -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys - = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + = noLoc $ HsOpTy noExt + (synifyType WithinType ty1) + (noLoc eqTyConName) + (synifyType WithinType ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys - = mk_app_tys (HsOpTy (synifyType WithinType ty1) + = mk_app_tys (HsOpTy noExt + (synifyType WithinType ty1) (noLoc $ getName tc) (synifyType WithinType ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc)) vis_tys where mk_app_tys ty_app ty_args = - foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2) + foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) (noLoc ty_app) (map (synifyType WithinType) $ filterOut isCoercionTy ty_args) @@ -488,7 +500,7 @@ synifyType _ (TyConApp tc tys) | needs_kind_sig = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType full_kind - in noLoc $ HsKindSig ty' full_kind' + in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' needs_kind_sig :: Bool @@ -509,22 +521,24 @@ synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 - in noLoc $ HsAppTy s1 s2 + in noLoc $ HsAppTy noExt s1 s2 synifyType _ (FunTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 - in noLoc $ HsFunTy s1 s2 + in noLoc $ HsFunTy noExt s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms forallty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExt , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_xforall = noExt , hst_body = noLoc sPhi } ImplicitizeForAll -> noLoc sPhi -synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" @@ -537,10 +551,12 @@ synifyPatSynType ps = let -- possible by taking theta = [], as that will print no context at all | otherwise = req_theta sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_body = noLoc s } + sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_xforall = noExt + , hst_body = noLoc s } + sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta + , hst_xqual = noExt + , hst_body = noLoc s } sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau @@ -560,7 +576,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls pure $ mkPseudoFamilyDecl fam } } diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a1009c1f..e7d80969 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -17,6 +18,7 @@ module Haddock.GhcUtils where import Control.Arrow +import Haddock.Types( DocNameI ) import Exception import Outputable @@ -27,6 +29,9 @@ import Module import HscTypes import GHC import Class +import DynFlags + +import HsTypes (HsType(..)) moduleString :: Module -> String @@ -44,57 +49,65 @@ isConSym = isLexConSym . occNameFS getMainDeclBinder :: HsDecl name -> [IdP name] -getMainDeclBinder (TyClD d) = [tcdName d] -getMainDeclBinder (ValD d) = +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl +getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) +getInstLoc (DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l -getInstLoc (TyFamInstD (TyFamInstDecl +getInstLoc (TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l +getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (XInstDecl _) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" + + -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name) -filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p (FixSig (FixitySig ns ty)) = +filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p)) +filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig (FixitySig filtered ty)) -filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty) = + filtered -> Just (FixSig noExt (FixitySig noExt filtered ty)) +filterSigNames _ orig@(MinimalSig _ _ _) = Just orig +filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) -filterSigNames p (ClassOpSig is_default ns ty) = + filtered -> Just (TypeSig noExt filtered ty) +filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig is_default filtered ty) -filterSigNames p (PatSynSig ns ty) = + filtered -> Just (ClassOpSig noExt is_default filtered ty) +filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig filtered ty) -filterSigNames _ _ = Nothing + filtered -> Just (PatSynSig noExt filtered ty) +filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just @@ -104,13 +117,13 @@ sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig ns _) = map unLoc ns -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] -- | Was this signature given by the user? isUserLSig :: LSig name -> Bool @@ -121,16 +134,16 @@ isUserLSig _ = False isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d +isClassD (TyClD _ d) = isClassDecl d isClassD _ = False isValD :: HsDecl a -> Bool -isValD (ValD _) = True +isValD (ValD _ _) = True isValD _ = False declATs :: HsDecl a -> [IdP a] -declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d +declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -148,6 +161,167 @@ nubByName f ns = go emptyNameSet ns where y = f x +-- --------------------------------------------------------------------- + +-- This function is duplicated as getGADTConType and getGADTConTypeG, +-- as I can't get the types to line up otherwise. AZ. + +getGADTConType :: ConDecl DocNameI -> LHsType DocNameI +-- The full type of a GADT data constructor We really only get this in +-- order to pretty-print it, and currently only in Haddock's code. So +-- we are cavalier about locations and extensions, hence the +-- 'undefined's +getGADTConType (ConDeclGADT { con_forall = L _ has_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty }) + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt + , hst_bndrs = hsQTvExplicit qtvs + , hst_body = theta_ty }) + | otherwise = theta_ty + where + theta_ty | Just theta <- mcxt + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) + | otherwise + = tau_ty + + tau_ty = case args of + RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty) + PrefixCon pos_args -> foldr mkFunTy res_ty pos_args + InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + + mkFunTy a b = noLoc (HsFunTy noExt a b) + +getGADTConType (ConDeclH98 {}) = panic "getGADTConType" + -- Should only be called on ConDeclGADT +getGADTConType (XConDecl {}) = panic "getGADTConType" + +-- ------------------------------------- + +getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) +-- The full type of a GADT data constructor We really only get this in +-- order to pretty-print it, and currently only in Haddock's code. So +-- we are cavalier about locations and extensions, hence the +-- 'undefined's +getGADTConTypeG (ConDeclGADT { con_forall = L _ has_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty }) + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt + , hst_bndrs = hsQTvExplicit qtvs + , hst_body = theta_ty }) + | otherwise = theta_ty + where + theta_ty | Just theta <- mcxt + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) + | otherwise + = tau_ty + + tau_ty = case args of + RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty) + PrefixCon pos_args -> foldr mkFunTy res_ty pos_args + InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + + mkFunTy a b = noLoc (HsFunTy noExt a b) + +getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" + -- Should only be called on ConDeclGADT +getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG" + + +------------------------------------------------------------------------------- +-- * Parenthesization +------------------------------------------------------------------------------- + +-- | Precedence level (inside the 'HsType' AST). +data Precedence + = PREC_TOP -- ^ precedence of 'type' production in GHC's parser + + | PREC_CTX -- ^ Used for single contexts, eg. ctx => type + -- (as opposed to (ctx1, ctx2) => type) + + | PREC_FUN -- ^ precedence of 'btype' production in GHC's parser + -- (used for LH arg of (->)) + + | PREC_OP -- ^ arg of any infix operator + -- (we don't keep have fixity info) + + | PREC_CON -- ^ arg of type application: always parenthesize unless atomic + deriving (Eq, Ord) + +-- | Add in extra 'HsParTy' where needed to ensure that what would be printed +-- out using 'ppr' has enough parentheses to be re-parsed properly. +-- +-- We cannot add parens that may be required by fixities because we do not have +-- any fixity information to work with in the first place :(. +reparenTypePrec :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a +reparenTypePrec = go + where + + -- Shorter name for 'reparenType' + go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a + go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) + go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) + go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) + go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind) + go _ (HsListTy x ty) = HsListTy x (reparenLType ty) + go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds) + go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d + go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) + go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) + go p (HsIParamTy x n ty) + = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty) + go p (HsForAllTy x tvs ty) + = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty) + go p (HsQualTy x ctxt ty) + = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) + go p (HsFunTy x ty1 ty2) + = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2) + go p (HsAppTy x fun_ty arg_ty) + = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) + go p (HsOpTy x ty1 op ty2) + = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) + go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed + go _ t@HsTyVar{} = t + go _ t@HsStarTy{} = t + go _ t@HsSpliceTy{} = t + go _ t@HsTyLit{} = t + go _ t@HsWildCardTy{} = t + go _ t@XHsType{} = t + + -- Located variant of 'go' + goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a + goL ctxt_prec = fmap (go ctxt_prec) + + -- Optionally wrap a type in parens + paren :: (XParTy a ~ NoExt) + => Precedence -- Precedence of context + -> Precedence -- Precedence of top-level operator + -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) + paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy NoExt . noLoc + | otherwise = id + + +-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') +reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a +reparenType = reparenTypePrec PREC_TOP + +-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') +reparenLType :: (XParTy a ~ NoExt) => LHsType a -> LHsType a +reparenLType = fmap reparenType + +-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') +reparenTyVar :: (XParTy a ~ NoExt) => HsTyVarBndr a -> HsTyVarBndr a +reparenTyVar (UserTyVar x n) = UserTyVar x n +reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind) +reparenTyVar v@XTyVarBndr{} = v + +-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') +reparenConDeclField :: (XParTy a ~ NoExt) => ConDeclField a -> ConDeclField a +reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d +reparenConDeclField c@XConDeclField{} = c + + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- @@ -179,8 +353,8 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = - case getConDetails con of - RecCon fields -> map (selectorFieldOcc . unL) $ + case con_args con of + RecCon fields -> map (extFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] @@ -190,7 +364,7 @@ instance Parent (TyClDecl GhcRn) where $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -218,7 +392,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration parents :: Name -> HsDecl GhcRn -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] @@ -255,7 +429,10 @@ minimalDef n = do setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags setObjectDir f d = d{ objectDir = Just f} setHiDir f d = d{ hiDir = Just f} -setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } +setStubDir f d = d{ stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f + + diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 7c7f0e75..759d5d03 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface @@ -51,6 +51,7 @@ import System.Directory import System.FilePath import Text.Printf +import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet) import Digraph import DynFlags hiding (verbosity) import Exception @@ -59,7 +60,9 @@ import HscTypes import FastString (unpackFS) import MonadUtils (liftIO) import TcRnTypes (tcg_rdr_env) -import RdrName (plusGlobalRdrEnv) +import Name (nameIsFromExternalPackage, nameOccName) +import OccName (isTcOcc) +import RdrName (unQualOK, gre_name, globalRdrEnvElts) import ErrUtils (withTiming) #if defined(mingw32_HOST_OS) @@ -88,7 +91,7 @@ processModules verbosity modules flags extIfaces = do out verbosity verbose "Creating interfaces..." let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ] - interfaces <- createIfaces0 verbosity modules flags instIfaceMap + (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap let exportedNames = Set.unions $ map (Set.fromList . ifaceExports) $ @@ -97,7 +100,7 @@ processModules verbosity modules flags extIfaces = do out verbosity verbose "Attaching instances..." interfaces' <- {-# SCC attachInstances #-} withTiming getDynFlags "attachInstances" (const ()) $ do - attachInstances (exportedNames, mods) interfaces instIfaceMap + attachInstances (exportedNames, mods) interfaces instIfaceMap ms out verbosity verbose "Building cross-linking environment..." -- Combine the link envs of the external packages into one @@ -121,7 +124,7 @@ processModules verbosity modules flags extIfaces = do -------------------------------------------------------------------------------- -createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet) createIfaces0 verbosity modules flags instIfaceMap = -- Output dir needs to be set before calling depanal since depanal uses it to -- compute output file names that are stored in the DynFlags of the @@ -151,43 +154,51 @@ createIfaces0 verbosity modules flags instIfaceMap = depanal [] False -createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] +createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet) createIfaces verbosity flags instIfaceMap mods = do let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing out verbosity normal "Haddock coverage:" - (ifaces, _) <- foldM f ([], Map.empty) sortedMods - return (reverse ifaces) + (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods + return (reverse ifaces, ms) where - f (ifaces, ifaceMap) modSummary = do + f (ifaces, ifaceMap, !ms) modSummary = do x <- {-# SCC processModule #-} withTiming getDynFlags "processModule" (const ()) $ do processModule verbosity modSummary flags ifaceMap instIfaceMap return $ case x of - Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) - Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. + Just (iface, ms') -> ( iface:ifaces + , Map.insert (ifaceMod iface) iface ifaceMap + , unionModuleSet ms ms' ) + Nothing -> ( ifaces + , ifaceMap + , ms ) -- Boot modules don't generate ifaces. -processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) +processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet)) processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum - -- We need to modify the interactive context's environment so that when - -- Haddock later looks for instances, it also looks in the modules it - -- encountered while typechecking. - -- - -- See https://github.com/haskell/haddock/issues/469. - hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession - let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm - setSession hsc_env{ hsc_IC = old_IC { - ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env - } } - if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msgs) <- {-# SCC createIterface #-} withTiming getDynFlags "createInterface" (const ()) $ do runWriterGhc $ createInterface tm flags modMap instIfaceMap + + -- We need to keep track of which modules were somehow in scope so that when + -- Haddock later looks for instances, it also looks in these modules too. + -- + -- See https://github.com/haskell/haddock/issues/469. + hsc_env <- getSession + let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm + this_pkg = thisPackage (hsc_dflags hsc_env) + !mods = mkModuleSet [ nameModule name + | gre <- globalRdrEnvElts new_rdr_env + , let name = gre_name gre + , nameIsFromExternalPackage this_pkg name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified + liftIO $ mapM_ putStrLn (nub msgs) dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface @@ -221,7 +232,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do unless header $ out verbosity normal " Module header" mapM_ (out verbosity normal . (" " ++)) undocumentedExports interface' <- liftIO $ evaluate interface - return (Just interface') + return (Just (interface', mods)) else return Nothing diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index d0ed1698..2d72d117 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE CPP, MagicHash, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -34,6 +34,7 @@ import FamInstEnv import FastString import GHC import InstEnv +import Module ( ModuleSet, moduleSetElts ) import MonadUtils (liftIO) import Name import NameEnv @@ -51,11 +52,13 @@ type Modules = Set.Set Module type ExportInfo = (ExportedNames, Modules) -- Also attaches fixities -attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] -attachInstances expInfo ifaces instIfaceMap = do - (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) +attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface] +attachInstances expInfo ifaces instIfaceMap mods = do + (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods' mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where + mods' = Just (moduleSetElts mods) + -- TODO: take an IfaceMap as input ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] @@ -86,7 +89,7 @@ attachToExportItem -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index ced7cae5..c4df2090 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -58,10 +58,10 @@ import Packages ( lookupModuleInAllPackages, PackageName(..) ) import Bag import RdrName import TcRnTypes -import FastString ( concatFS, unpackFS ) +import FastString ( unpackFS, fastStringToByteString) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O -import HsDecls ( getConDetails ) +import HsDecls ( getConArgs ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -135,7 +135,7 @@ createInterface tm flags modMap instIfaceMap = do $ map getName instances ++ map getName fam_instances -- Locations of all TH splices - splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) @@ -304,11 +304,11 @@ moduleWarning dflags gre (WarnAll w) = Just <$> parseWarning dflags gre w parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> ErrMsgM (Doc Name) parseWarning dflags gre w = case w of - DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map (sl_fs . unLoc) msg) - WarningTxt _ msg -> format "Warning: " (concatFS $ map (sl_fs . unLoc) msg) + DeprecatedTxt _ msg -> format "Deprecated: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg) + WarningTxt _ msg -> format "Warning: " (foldMap (fastStringToByteString . sl_fs . unLoc) msg) where - format x xs = DocWarning . DocParagraph . DocAppend (DocString x) - <$> processDocString dflags gre (HsDocString xs) + format x bs = DocWarning . DocParagraph . DocAppend (DocString x) + <$> processDocString dflags gre (mkHsDocStringUtf8ByteString bs) ------------------------------------------------------------------------------- @@ -393,7 +393,7 @@ mkMaps dflags pkgName gre instances decls = do m' <- traverse (processDocStringParas dflags pkgName gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (typeDocs decl) + (doc, args) <- declDoc docStrs (declTypeDocs decl) let subs :: [(Name, [HsDocString], Map Int HsDocString)] @@ -419,12 +419,12 @@ mkMaps dflags pkgName gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] names :: SrcSpan -> HsDecl GhcRn -> [Name] - names _ (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names _ (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of -- The CoAx's loc is the whole line, but only for TFs. The -- workaround is to dig into the family instance declaration and -- get the identifier with the right location. - TyFamInstD (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) + TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon (hsib_body d')) _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -449,67 +449,83 @@ subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of - InstD (ClsInstD d) -> do + InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) -> dataSubs (feqn_rhs d) - TyClD d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where - classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) - constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) + constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ] - fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map getConDetails cons - , L _ (ConDeclField ns _ doc) <- (unLoc flds) + fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map getConArgs cons + , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) - | HsIB { hsib_body = L l (HsDocTy _ doc) } + | HsIB { hsib_body = L l (HsDocTy _ _ doc) } <- concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int HsDocString +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map unLoc args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + RecCon _ -> go 1 ret + where + go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (HsBangTy _ _ (L _ (HsDocTy _ _ (L _ ds))) : tys) = M.insert n ds $ go (n+1) tys + go n (_ : tys) = go (n+1) tys + go _ [] = M.empty + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString +declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) +declTypeDocs _ = M.empty + -- | Extract function argument docs from inside types. -typeDocs :: HsDecl GhcRn -> Map Int HsDocString -typeDocs d = - let docs = go 0 in - case d of - SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) - SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty)) - SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) - ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) - TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) - _ -> M.empty +typeDocs :: HsType GhcRn -> Map Int HsDocString +typeDocs = go 0 where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ (L _ doc)) = M.singleton n doc + go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc go _ _ = M.empty - -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ + docs = mkDecls tcdDocs (DocD noExt) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ + sigs = mkDecls tcdSigs (SigD noExt) class_ + ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ -- | The top-level declarations of a module that we care about, @@ -521,26 +537,26 @@ topDecls = -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig ns f) <- hs_fixds group_, + | L _ (FixitySig _ ns f) <- hs_fixds group_, L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ + mkDecls hs_derivds (DerivD noExt) group_ ++ + mkDecls hs_defds (DefD noExt) group_ ++ + mkDecls hs_fords (ForD noExt) group_ ++ + mkDecls hs_docs (DocD noExt) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExt) group_ where - typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs + typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" - valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds valbinds _ = error "expected ValBindsOut" @@ -566,14 +582,14 @@ sortByLoc = sortBy (comparing getLoc) filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where - isHandled (ForD (ForeignImport {})) = True + isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True - isHandled (SigD d) = isUserLSig (reL d) - isHandled (ValD _) = True + isHandled (SigD _ d) = isUserLSig (reL d) + isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs - isHandled (DocD _) = True + isHandled (DocD {}) = True isHandled _ = False -- | Go through all class declarations and filter their sub-declarations @@ -581,8 +597,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where - filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } + filterClass (TyClD x c) = + TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -601,10 +617,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD (DocCommentNext str)) : ds) + go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -647,22 +663,22 @@ mkExportItems allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do + lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre docStr return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr, _) = liftErrMsg $ do + lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] - lookupExport (IEDocNamed str, _) = liftErrMsg $ + lookupExport (IEDocNamed _ str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags pkgName gre docStr return [ExportDoc doc] - lookupExport (IEModuleContents (L _ mod_name), _) + lookupExport (IEModuleContents _ (L _ mod_name), _) -- only consider exporting a module if we are sure we -- are really exporting the whole module and not some -- subset. We also look through module aliases here. @@ -699,7 +715,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let t = availName avail r <- findDecl avail case r of - ([L l (ValD _)], (doc, _)) -> do + ([L l (ValD _ _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] @@ -724,17 +740,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. - L loc (SigD sig) -> + L loc (SigD _ sig) -> -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. - let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig + let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD cl@ClassDecl{}) -> do + L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -997,13 +1013,13 @@ fullModuleContents is_sig modMap pkgName thisMod semMod warnings gre exportedNam let availEnv = availsToNameEnv (nubAvails avails) (concat . concat) `fmap` (for decls $ \decl -> do case decl of - (L _ (DocD (DocGroup lev docStr))) -> do + (L _ (DocD _ (DocGroup lev docStr))) -> do doc <- liftErrMsg (processDocString dflags gre docStr) return [[ExportGroup lev "" doc]] - (L _ (DocD (DocCommentNamed _ docStr))) -> do + (L _ (DocD _ (DocCommentNamed _ docStr))) -> do doc <- liftErrMsg (processDocStringParas dflags pkgName gre docStr) return [[ExportDoc doc]] - (L _ (ValD valDecl)) + (L _ (ValD _ valDecl)) | name:_ <- collectHsBindBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> return [] @@ -1028,12 +1044,12 @@ extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of - TyClD d@ClassDecl {} -> + TyClD _ d@ClassDecl {} -> let matchesMethod = [ lsig | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig + , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig ] @@ -1048,8 +1064,8 @@ extractDecl declMap name decl in case (matchesMethod, matchesAssociatedType) of ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) - (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + in L pos (SigD noExt sig) + (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap @@ -1058,23 +1074,23 @@ extractDecl declMap name decl O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) - TyClD d@DataDecl {} -> + TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name - then SigD <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) - else SigD <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) - TyClD FamDecl {} + then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_pats = tys , feqn_rhs = defn }}))) -> if isDataConName name - then SigD <$> extractPatternSyn name n tys (dd_cons defn) - else SigD <$> extractRecSel name n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) + then SigD noExt <$> extractPatternSyn name n tys (dd_cons defn) + else SigD noExt <$> extractRecSel name n tys (dd_cons defn) + InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) | isDataConName name -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_rhs = dd @@ -1083,19 +1099,19 @@ extractDecl declMap name decl , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd)) ] in case matches of - [d0] -> extractDecl declMap name (noLoc (InstD (DataFamInstD d0))) + [d0] -> extractDecl declMap name (noLoc (InstD noExt (DataFamInstD noExt d0))) _ -> error "internal: extractDecl (ClsInstD)" | otherwise -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , selectorFieldOcc n == name + , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" @@ -1111,42 +1127,42 @@ extractPatternSyn nm t tvs cons = extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConDetails con of + case getConArgs con of PrefixCon args' -> args' RecCon (L _ fields) -> cd_fld_type . unLoc <$> fields InfixCon arg1 arg2 -> [arg1, arg2] typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) _ -> typ - typ'' = noLoc (HsQualTy (noLoc []) typ') - in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + typ'' = noLoc (HsQualTy noExt (noLoc []) typ') + in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') - longArrow :: [LHsType name] -> LHsType name -> LHsType name - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs data_ty con - | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + | ConDeclGADT{} <- con = con_res_ty con + | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = - case getConDetails con of - RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) + case getConArgs con of + RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> + L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt 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, selectorFieldOcc n == nm ] + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds + , L l n <- ns, extFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty - | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + | ConDeclGADT{} <- con = con_res_ty con + | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] @@ -1166,8 +1182,8 @@ mkVisibleNames (_, _, _, instMap) exports opts where subs = map fst (expItemSubDocs e) patsyns = concatMap (getMainDeclBinder . fst) (expItemPats e) name = case unLoc $ expItemDecl e of - InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap - decl -> getMainDeclBinder decl + InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1211,7 +1227,7 @@ findNamedDoc name = search search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search (DocD (DocCommentNamed name' doc) : rest) + search (DocD _ (DocCommentNamed name' doc) : rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs index 5d3cf2a6..87face7c 100644 --- a/haddock-api/src/Haddock/Interface/LexParseRn.hs +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wwarn #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn @@ -18,11 +19,14 @@ module Haddock.Interface.LexParseRn , processModuleHeader ) where +import Avail +import Control.Arrow +import Control.Monad import Data.List +import Data.Ord import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (languageExtensions) import qualified GHC.LanguageExtensions as LangExt -import FastString import GHC import Haddock.Interface.ParseModuleHeader import Haddock.Parser @@ -44,14 +48,13 @@ processDocStrings dflags pkg gre strs = do MetaDoc { _meta = Meta Nothing Nothing, _doc = DocEmpty } -> pure Nothing x -> pure (Just x) -processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString - -> ErrMsgM (MDoc Name) -processDocStringParas dflags pkg gre (HsDocString fs) = - overDocF (rename dflags gre) $ parseParas dflags pkg (unpackFS fs) +processDocStringParas :: DynFlags -> Maybe Package -> GlobalRdrEnv -> HsDocString -> ErrMsgM (MDoc Name) +processDocStringParas dflags pkg gre hds = + overDocF (rename dflags gre) $ parseParas dflags pkg (unpackHDS hds) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Doc Name) -processDocString dflags gre (HsDocString fs) = - rename dflags gre $ parseString dflags (unpackFS fs) +processDocString dflags gre hds = + rename dflags gre $ parseString dflags (unpackHDS hds) processModuleHeader :: DynFlags -> Maybe Package -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) @@ -59,8 +62,8 @@ processModuleHeader dflags pkgName gre safety mayStr = do (hmi, doc) <- case mayStr of Nothing -> return failure - Just (L _ (HsDocString fs)) -> do - let str = unpackFS fs + Just (L _ hds) -> do + let str = unpackHDS hds (hmi, doc) = parseModuleHeader dflags pkgName str !descr <- case hmi_description hmi of Just hmi_descr -> Just <$> rename dflags gre hmi_descr @@ -96,11 +99,9 @@ rename dflags gre = rn -- Generate the choices for the possible kind of thing this -- is. let choices = dataTcOccs x - -- Try to look up all the names in the GlobalRdrEnv that match - -- the names. - let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices - case names of + -- Lookup any GlobalRdrElts that match the choices. + case concatMap (\c -> lookupGRE_RdrName c gre) choices of -- We found no names in the env so we start guessing. [] -> case choices of @@ -119,12 +120,10 @@ rename dflags gre = rn -- There is only one name in the environment that matches so -- use it. - [a] -> pure (DocIdentifier a) + [a] -> pure (DocIdentifier (gre_name a)) - -- But when there are multiple names available, default to - -- type constructors: somewhat awfully GHC returns the - -- values in the list positionally. - a:b:_ -> ambiguous dflags x (if isTyConName a then a else b) names + -- There are multiple names available. + gres -> ambiguous dflags x gres DocWarning doc -> DocWarning <$> rn doc DocEmphasis doc -> DocEmphasis <$> rn doc @@ -165,20 +164,38 @@ outOfScope dflags x = Exact name -> warnAndMonospace name -- Shouldn't happen since x is out of scope where warnAndMonospace a = do - tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope."] + tell ["Warning: '" ++ showPpr dflags a ++ "' is out of scope.\n" ++ + " If you qualify the identifier, haddock can try to link it\n" ++ + " it anyway."] pure (monospaced a) monospaced a = DocMonospaced (DocString (showPpr dflags a)) --- | Warn about an ambiguous identifier. -ambiguous :: DynFlags -> RdrName -> Name -> [Name] -> ErrMsgM (Doc Name) -ambiguous dflags x dflt names = do - tell [msg] +-- | Handle ambiguous identifiers. +-- +-- Prefers local names primarily and type constructors or class names secondarily. +-- +-- Emits a warning if the 'GlobalRdrElts's don't belong to the same type or class. +ambiguous :: DynFlags + -> RdrName + -> [GlobalRdrElt] -- ^ More than one @gre@s sharing the same `RdrName` above. + -> ErrMsgM (Doc Name) +ambiguous dflags x gres = do + let noChildren = map availName (gresToAvailInfo gres) + dflt = maximumBy (comparing (isLocalName &&& isTyConName)) noChildren + msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ + concatMap (\n -> " * " ++ defnLoc n ++ "\n") (map gre_name gres) ++ + " You may be able to disambiguate the identifier by qualifying it or\n" ++ + " by hiding some imports.\n" ++ + " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + -- TODO: Once we have a syntax for namespace qualification (#667) we may also + -- want to emit a warning when an identifier is a data constructor for a type + -- of the same name, but not the only constructor. + -- For example, for @data D = C | D@, someone may want to reference the @D@ + -- constructor. + when (length noChildren > 1) $ tell [msg] pure (DocIdentifier dflt) where - msg = "Warning: " ++ x_str ++ " is ambiguous. It is defined\n" ++ - concatMap (\n -> " * " ++ defnLoc n ++ "\n") names ++ - " You may be able to disambiguate the identifier by qualifying it or\n" ++ - " by hiding some imports.\n" ++ - " Defaulting to " ++ x_str ++ " defined " ++ defnLoc dflt + isLocalName (nameSrcLoc -> RealSrcLoc {}) = True + isLocalName _ = False x_str = '\'' : showPpr dflags x ++ "'" defnLoc = showSDoc dflags . pprNameDefnLoc diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index b2d0e1e1..1c976410 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -21,6 +21,7 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name +import Outputable ( panic ) import RdrName (RdrName(Exact)) import PrelNames (eqTyCon_RDR) @@ -197,14 +198,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) -renameFamilyResultSig (L loc NoSig) - = return (L loc NoSig) -renameFamilyResultSig (L loc (KindSig ki)) +renameFamilyResultSig (L loc (NoSig _)) + = return (L loc (NoSig noExt)) +renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig ki')) } -renameFamilyResultSig (L loc (TyVarSig bndr)) + ; return (L loc (KindSig noExt ki')) } +renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig bndr')) } + ; return (L loc (TyVarSig noExt bndr')) } +renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig" renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -221,61 +223,60 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype - HsAppTy a b -> do + HsStarTy _ isUni -> return (HsStarTy NoExt isUni) + + HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy a' b') + return (HsAppTy NoExt a' b') - HsFunTy a b -> do + HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy a' b') + return (HsFunTy NoExt a' b') - HsListTy ty -> return . HsListTy =<< renameLType ty - HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) - HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsSumTy ts -> HsSumTy <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts - HsOpTy a (L loc op) b -> do + HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (L loc op') b') + return (HsOpTy NoExt a' (L loc op') b') - HsParTy ty -> return . HsParTy =<< renameLType ty + HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty - HsKindSig ty k -> do + HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig ty' k') + return (HsKindSig NoExt ty' k') - HsDocTy ty doc -> do + HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy ty' doc') + return (HsDocTy NoExt ty' doc') - HsTyLit x -> return (HsTyLit x) + HsTyLit _ x -> return (HsTyLit NoExt x) - HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a - HsCoreTy a -> pure (HsCoreTy a) + HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a + (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsSpliceTy s _ -> renameHsSpliceTy s + HsSpliceTy _ s -> renameHsSpliceTy s HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a - HsAppsTy _ -> error "renameType: HsAppsTy" -- | Rename splices, but _only_ those that turn out to be for types. -- I think this is actually safe for our possible inputs: @@ -284,32 +285,34 @@ renameType t = case t of -- * the input is typechecked, and only 'HsSplicedTy' should get through that -- renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI) -renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t -renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy" +renameHsSpliceTy (HsSpliced _ _ (HsSplicedTy t)) = renameType t +renameHsSpliceTy (HsSpliced _ _ _) = error "renameHsSpliceTy: not an HsSplicedTy" renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) -renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) +renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } - -- This is rather bogus, but I'm not sure what else to do + ; return (HsQTvs { hsq_ext = noExt + , hsq_explicit = tvs' }) } +renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars" renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) -renameLTyVarBndr (L loc (UserTyVar (L l n))) +renameLTyVarBndr (L loc (UserTyVar x (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) + ; return (L loc (UserTyVar x (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar (L lv n') kind')) } + ; return (L loc (KindedTyVar x (L lv n') kind')) } +renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) -renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo +renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do @@ -340,21 +343,21 @@ renamePats = mapM renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of - TyClD d -> do + TyClD _ d -> do d' <- renameTyClD d - return (TyClD d') - SigD s -> do + return (TyClD noExt d') + SigD _ s -> do s' <- renameSig s - return (SigD s') - ForD d -> do + return (SigD noExt s') + ForD _ d -> do d' <- renameForD d - return (ForD d') - InstD d -> do + return (ForD noExt d') + InstD _ d -> do d' <- renameInstD d - return (InstD d') - DerivD d -> do + return (InstD noExt d') + DerivD _ d -> do d' <- renameDerivD d - return (DerivD d') + return (DerivD noExt d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) @@ -365,19 +368,21 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFam = decl' }) + return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames }) + return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdRhs = rhs' }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -392,7 +397,8 @@ renameTyClD d = case d of return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt }) + XTyClDecl _ -> panic "haddock:renameTyClD" where renameLFunDep (L loc (xs, ys)) = do @@ -413,11 +419,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) +renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl" renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -443,107 +450,129 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + return (HsDataDefn { dd_ext = noExt + , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) +renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn" renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) -renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details +renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars + , con_mb_cxt = lcontext, con_args = details , con_doc = mbldoc }) = do lname' <- renameL lname - ltyvars' <- traverse renameLHsQTyVars ltyvars + ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_doc = mbldoc' }) + return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars' + , con_mb_cxt = lcontext' + , con_args = details', con_doc = mbldoc' }) - where - renameDetails (RecCon (L l fields)) = do - fields' <- mapM renameConDeclFieldField fields - return (RecCon (L l fields')) - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') - -renameCon decl@(ConDeclGADT { con_names = lnames - , con_type = lty +renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars + , con_mb_cxt = lcontext, con_args = details + , con_res_ty = res_ty , con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - lty' <- renameLSigType lty + ltyvars' <- renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext + details' <- renameDetails details + res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames' - , con_type = lty', con_doc = mbldoc' }) + return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars' + , con_mb_cxt = lcontext', con_args = details' + , con_res_ty = res_ty', con_doc = mbldoc' }) +renameCon (XConDecl _) = panic "haddock:renameCon" + +renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) +renameDetails (RecCon (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon (L l fields')) +renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps +renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) -renameConDeclFieldField (L l (ConDeclField names t doc)) = do +renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField names' t' doc') + return $ L l (ConDeclField noExt names' t' doc') +renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField" renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) -renameLFieldOcc (L l (FieldOcc lbl sel)) = do +renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel - return $ L l (FieldOcc lbl sel') + return $ L l (FieldOcc sel' lbl) +renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of - TypeSig lnames ltype -> do + TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig lnames' ltype') - ClassOpSig is_default lnames sig_ty -> do + return (TypeSig noExt lnames' ltype') + ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig is_default lnames' ltype') - PatSynSig lnames sig_ty -> do + return (ClassOpSig noExt is_default lnames' ltype') + PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig lnames' sig_ty' - FixSig (FixitySig lnames fixity) -> do + return $ PatSynSig noExt lnames' sig_ty' + FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames - return $ FixSig (FixitySig lnames' fixity) - MinimalSig src (L l s) -> do + return $ FixSig noExt (FixitySig noExt lnames' fixity) + MinimalSig _ src (L l s) -> do s' <- traverse renameL s - return $ MinimalSig src (L l s') + return $ MinimalSig noExt src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) -renameForD (ForeignImport lname ltype co x) = do +renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignImport lname' ltype' co x) -renameForD (ForeignExport lname ltype co x) = do + return (ForeignImport noExt lname' ltype' x) +renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignExport lname' ltype' co x) + return (ForeignExport noExt lname' ltype' x) +renameForD (XForeignDecl _) = panic "haddock:renameForD" renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_inst = d' }) + return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' }) +renameInstD (XInstDecl _) = panic "haddock:renameInstD" renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do - ty' <- renameLSigType ty - return (DerivDecl { deriv_type = ty' - , deriv_strategy = strat + ty' <- renameLSigWcType ty + strat' <- mapM (mapM renameDerivStrategy) strat + return (DerivDecl { deriv_ext = noExt + , deriv_type = ty' + , deriv_strategy = strat' , deriv_overlap_mode = omode }) +renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" + +renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) +renameDerivStrategy StockStrategy = pure StockStrategy +renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy +renameDerivStrategy NewtypeStrategy = pure NewtypeStrategy +renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -552,10 +581,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) +renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD" renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -575,10 +605,12 @@ renameTyFamInstEqn eqn = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } + rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn" renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs @@ -586,10 +618,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs - ; return (L loc (FamEqn { feqn_tycon = tc' + ; return (L loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } +renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn" renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) @@ -604,10 +638,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; defn' <- renameDataDefn defn - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } + rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD" renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -615,8 +651,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder }) } + , hsib_ext = noExt }) } +renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit" renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -624,7 +660,8 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder }) } + , hswc_ext = noExt }) } +renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc" renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n, m) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index a54aad90..30931c26 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -28,20 +28,18 @@ import Data.Set (Set) import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => [(IdP name, HsType name)] -> a -> a +specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a specialize specs = go spec_map0 where - go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x - go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map + go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x + go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map strip_kind_sig :: HsType name -> HsType name - strip_kind_sig (HsKindSig (L _ t) _) = t + strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ - specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name - specialize_ty_var spec_map (HsTyVar _ (L _ name')) + specialize_ty_var :: Map Name (HsType GhcRn) -> HsType GhcRn -> HsType GhcRn + specialize_ty_var spec_map (HsTyVar _ _ (L _ name')) | Just t <- Map.lookup name' spec_map = t specialize_ty_var _ typ = typ @@ -54,35 +52,33 @@ specialize specs = go spec_map0 -- -- 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 :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => LHsQTyVars name -> [HsType name] +specializeTyVarBndrs :: Data a + => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar (L _ name)) = name - bname (KindedTyVar (L _ name) _) = name + bname (UserTyVar _ (L _ name)) = name + bname (KindedTyVar _ (L _ name) _) = name + bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" -specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name +specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> PseudoFamilyDecl GhcRn + -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> Sig name - -> Sig name -specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) +specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> Sig GhcRn + -> Sig GhcRn +specializeSig bndrs typs (TypeSig _ lnames typ) = + TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where - true_type :: HsType name + true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) - typ' :: HsType name + typ' :: HsType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig @@ -90,8 +86,7 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => InstHead name -> InstHead name +specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } where @@ -110,27 +105,26 @@ specializeInstHead ihd = ihd -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> HsType name +sugar :: HsType GhcRn -> HsType GhcRn sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing (IdP name) => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp +sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp where name' = getName name strName = occNameString . nameOccName $ name' sugarLists typ = typ -sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name +sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ = aux [] typ where - aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp - aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy _ (L _ typ')) = aux apps typ' + aux apps (HsTyVar _ _ (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -140,10 +134,10 @@ sugarTuples typ = aux _ _ = typ -sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) +sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ @@ -208,15 +202,14 @@ setInternalOccName occ name = -- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> Set Name +freeVariables :: HsType GhcRn -> Set Name freeVariables = everythingWithState Set.empty Set.union query where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy bndrs _) -> + query term ctx = case cast term :: Maybe (HsType GhcRn) of + Just (HsForAllTy _ bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar _ (L _ name)) + Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) @@ -231,8 +224,7 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: (Eq (IdP name), DataId name, SetName (IdP name)) - => Set Name-> HsType name -> HsType name +rename :: Set Name -> HsType GhcRn -> HsType GhcRn rename fv typ = evalState (renameType typ) env where env = RenameEnv @@ -252,63 +244,56 @@ data RenameEnv name = RenameEnv } -renameType :: (Eq (IdP name), SetName (IdP name)) - => HsType name -> Rename (IdP name) (HsType name) -renameType (HsForAllTy bndrs lt) = - HsForAllTy +renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) +renameType (HsForAllTy x bndrs lt) = + HsForAllTy x <$> mapM (located renameBinder) bndrs <*> renameLType lt -renameType (HsQualTy lctxt lt) = - HsQualTy +renameType (HsQualTy x lctxt lt) = + HsQualTy x <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name -renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la -renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr -renameType (HsListTy lt) = HsListTy <$> renameLType lt -renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt -renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt -renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt -renameType (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb -renameType (HsParTy lt) = HsParTy <$> renameLType lt -renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt -renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb -renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType t@(HsStarTy _ _) = pure t +renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la +renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +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 <*> located 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 renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc -renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt -renameType t@(HsRecTy _) = pure t -renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ip ph ltys) = - HsExplicitListTy ip ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t +renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc +renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt +renameType t@(HsRecTy _ _) = pure t +renameType t@(XHsType (NHsCoreTy _)) = pure t +renameType (HsExplicitListTy x ip ltys) = + HsExplicitListTy x ip <$> renameLTypes ltys +renameType (HsExplicitTupleTy x ltys) = + HsExplicitTupleTy x <$> renameLTypes ltys +renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) -renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" -renameLType :: (Eq (IdP name), SetName (IdP name)) - => LHsType name -> Rename (IdP name) (LHsType name) +renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType -renameLTypes :: (Eq (IdP name), SetName (IdP name)) - => [LHsType name] -> Rename (IdP name) [LHsType name] +renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType -renameContext :: (Eq (IdP name), SetName (IdP name)) - => HsContext name -> Rename (IdP name) (HsContext name) +renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: (Eq (IdP name), SetName (IdP name)) - => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) -renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname -renameBinder (KindedTyVar lname lkind) = - KindedTyVar <$> located renameName lname <*> located renameType lkind - +renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) +renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname +renameBinder (KindedTyVar x lname lkind) = + KindedTyVar x <$> located renameName lname <*> located renameType lkind +renameBinder (XTyVarBndr _) = error "haddock:renameBinder" -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -363,5 +348,6 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar name) = unLoc name -tyVarName (KindedTyVar (L _ name) _) = name +tyVarName (UserTyVar _ name) = unLoc name +tyVarName (KindedTyVar _ (L _ name) _) = name +tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index d5bbce2c..ce6ecc78 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) +#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) binaryInterfaceVersion = 33 binaryInterfaceVersionCompatibility :: [Word16] diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 5ef5a7b9..6da45a3b 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -39,8 +39,6 @@ import BasicTypes (Fixity(..)) import GHC hiding (NoLink) import DynFlags (Language) import qualified GHC.LanguageExtensions as LangExt -import Coercion -import NameSet import OccName import Outputable import Control.Applicative (Applicative(..)) @@ -348,7 +346,7 @@ data InstType name | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (SourceTextX a, OutputableBndrId a) +instance (a ~ GhcPass p,OutputableBndrId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx @@ -373,7 +371,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl } -mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name +mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName @@ -381,11 +379,13 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl , pfdKindSig = fdResultSig } where - mkType (KindedTyVar (L loc name) lkind) = - HsKindSig tvar lkind + mkType (KindedTyVar _ (L loc name) lkind) = + HsKindSig NoExt tvar lkind where - tvar = L loc (HsTyVar NotPromoted (L loc name)) - mkType (UserTyVar name) = HsTyVar NotPromoted name + tvar = L loc (HsTyVar NoExt NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name + mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" +mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl" -- | An instance head that may have documentation and a source location. @@ -669,14 +669,76 @@ instance MonadIO ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocNameI NameSet = PlaceHolder -type instance PostRn DocNameI Fixity = PlaceHolder -type instance PostRn DocNameI Bool = PlaceHolder -type instance PostRn DocNameI Name = DocName -type instance PostRn DocNameI (Located Name) = Located DocName -type instance PostRn DocNameI [Name] = PlaceHolder -type instance PostRn DocNameI DocName = DocName - -type instance PostTc DocNameI Kind = PlaceHolder -type instance PostTc DocNameI Type = PlaceHolder -type instance PostTc DocNameI Coercion = PlaceHolder +type instance XForAllTy DocNameI = NoExt +type instance XQualTy DocNameI = NoExt +type instance XTyVar DocNameI = NoExt +type instance XStarTy DocNameI = NoExt +type instance XAppTy DocNameI = NoExt +type instance XFunTy DocNameI = NoExt +type instance XListTy DocNameI = NoExt +type instance XTupleTy DocNameI = NoExt +type instance XSumTy DocNameI = NoExt +type instance XOpTy DocNameI = NoExt +type instance XParTy DocNameI = NoExt +type instance XIParamTy DocNameI = NoExt +type instance XKindSig DocNameI = NoExt +type instance XSpliceTy DocNameI = NoExt +type instance XDocTy DocNameI = NoExt +type instance XBangTy DocNameI = NoExt +type instance XRecTy DocNameI = NoExt +type instance XExplicitListTy DocNameI = NoExt +type instance XExplicitTupleTy DocNameI = NoExt +type instance XTyLit DocNameI = NoExt +type instance XWildCardTy DocNameI = HsWildCardInfo +type instance XXType DocNameI = NewHsTypeX + +type instance XUserTyVar DocNameI = NoExt +type instance XKindedTyVar DocNameI = NoExt +type instance XXTyVarBndr DocNameI = NoExt + +type instance XCFieldOcc DocNameI = DocName +type instance XXFieldOcc DocNameI = NoExt + +type instance XFixitySig DocNameI = NoExt +type instance XFixSig DocNameI = NoExt +type instance XPatSynSig DocNameI = NoExt +type instance XClassOpSig DocNameI = NoExt +type instance XTypeSig DocNameI = NoExt +type instance XMinimalSig DocNameI = NoExt + +type instance XForeignExport DocNameI = NoExt +type instance XForeignImport DocNameI = NoExt +type instance XConDeclGADT DocNameI = NoExt +type instance XConDeclH98 DocNameI = NoExt + +type instance XDerivD DocNameI = NoExt +type instance XInstD DocNameI = NoExt +type instance XForD DocNameI = NoExt +type instance XSigD DocNameI = NoExt +type instance XTyClD DocNameI = NoExt + +type instance XNoSig DocNameI = NoExt +type instance XCKindSig DocNameI = NoExt +type instance XTyVarSig DocNameI = NoExt + +type instance XCFamEqn DocNameI _ _ = NoExt + +type instance XCClsInstDecl DocNameI = NoExt +type instance XCDerivDecl DocNameI = NoExt +type instance XViaStrategy DocNameI = LHsSigType DocNameI +type instance XDataFamInstD DocNameI = NoExt +type instance XTyFamInstD DocNameI = NoExt +type instance XClsInstD DocNameI = NoExt +type instance XCHsDataDefn DocNameI = NoExt +type instance XCFamilyDecl DocNameI = NoExt +type instance XClassDecl DocNameI = NoExt +type instance XDataDecl DocNameI = NoExt +type instance XSynDecl DocNameI = NoExt +type instance XFamDecl DocNameI = NoExt + +type instance XHsIB DocNameI _ = NoExt +type instance XHsWC DocNameI _ = NoExt + +type instance XHsQTvs DocNameI = NoExt +type instance XConDeclField DocNameI = NoExt + diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 84f58ab8..c2cdddf7 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -62,8 +62,8 @@ import Haddock.GhcUtils import GHC import Name -import NameSet ( emptyNameSet ) -import HsTypes (selectorFieldOcc) +import HsTypes (extFieldOcc) +import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -131,16 +131,19 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) - = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) + = L loc (HsForAllTy { hst_xforall = noExt + , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) + = L loc (HsQualTy { hst_xqual = noExt + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + = L loc (HsQualTy { hst_xqual = noExt + , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) add_ctxt (L loc preds) = L loc (extra_pred : preds) @@ -149,7 +152,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -159,10 +162,10 @@ lHsQTyVarsToTypes tvs restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl @@ -175,42 +178,28 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case getConDetails h98d of + case con_args d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where - h98d = h98ConDecl d - h98ConDecl c@ConDeclH98{} = c - h98ConDecl c@ConDeclGADT{} = c' - where - (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl GhcRn - c' = ConDeclH98 - { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_implicit = mempty - , hsq_explicit = tvs - , hsq_dependent = emptyNameSet } - , con_cxt = Just cxt - , con_details = details - , con_doc = con_doc c - } - field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField fs _ _)) - = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ t _ <- flds ] + field_avail (L _ (ConDeclField _ fs _ _)) + = all (\f -> extFieldOcc (unLoc f) `elem` names) fs + field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail" + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing @@ -221,13 +210,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsQTyVars Name +emptyHsQTvs :: LHsQTyVars GhcRn -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] - , hsq_dependent = error "haddock:emptyHsQTvs" } +emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_dependent = error "haddock:emptyHsQTvs" } + , hsq_explicit = [] } -------------------------------------------------------------------------------- diff --git a/haddock-library/CHANGES.md b/haddock-library/CHANGES.md index e41b8087..0175b6af 100644 --- a/haddock-library/CHANGES.md +++ b/haddock-library/CHANGES.md @@ -1,3 +1,11 @@ +## Changes in version 1.7.0 + + * Make `Documentation.Haddock.Parser.Monad` an internal module + +## Changes in version 1.6.1 + + * Replace `attoparsec` with `parsec` (#799) + ## Changes in version 1.6.0 * `MetaDoc` stores package name for since annotations diff --git a/haddock-library/haddock-library.cabal b/haddock-library/haddock-library.cabal index eb961041..0b4405b9 100644 --- a/haddock-library/haddock-library.cabal +++ b/haddock-library/haddock-library.cabal @@ -1,16 +1,16 @@ cabal-version: 2.0 name: haddock-library -version: 1.6.0 +version: 1.7.0 synopsis: Library exposing some functionality of Haddock. description: Haddock is a documentation-generation tool for Haskell libraries. These modules expose some functionality of it without pulling in the GHC dependency. Please note that the API is likely to change so specify upper bounds in your - project if you can't release often. For interacting with Haddock - itself, see the ‘haddock’ package. + project. For interacting with Haddock + itself, see the [haddock package](https://hackage.haskell.org/package/haddock). license: BSD3 license-files: LICENSE -maintainer: Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> +maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues category: Documentation @@ -22,9 +22,9 @@ library default-language: Haskell2010 build-depends: - base >= 4.5 && < 4.12 + base >= 4.5 && < 4.13 , bytestring >= 0.9.2.1 && < 0.11 - , containers >= 0.4.2.1 && < 0.6 + , containers >= 0.4.2.1 && < 0.7 , transformers >= 0.3.0 && < 0.6 , text >= 1.2.3.0 && < 1.3 , parsec >= 3.1.13.0 && < 3.2 @@ -35,14 +35,14 @@ library Documentation.Haddock.Doc Documentation.Haddock.Markup Documentation.Haddock.Parser - Documentation.Haddock.Parser.Monad Documentation.Haddock.Types Documentation.Haddock.Utf8 other-modules: Documentation.Haddock.Parser.Util + Documentation.Haddock.Parser.Monad - ghc-options: -funbox-strict-fields -Wall -fwarn-tabs -O2 + ghc-options: -funbox-strict-fields -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances @@ -71,10 +71,10 @@ test-suite spec Documentation.Haddock.Utf8Spec build-depends: - base >= 4.5 && < 4.12 + base >= 4.5 && < 4.13 , base-compat >= 0.9.3 && < 0.11 , bytestring >= 0.9.2.1 && < 0.11 - , containers >= 0.4.2.1 && < 0.6 + , containers >= 0.4.2.1 && < 0.7 , transformers >= 0.3.0 && < 0.6 , hspec >= 2.4.4 && < 2.6 , QuickCheck ^>= 2.11 @@ -91,8 +91,9 @@ test-suite fixtures main-is: Fixtures.hs ghc-options: -Wall -O0 hs-source-dirs: fixtures + buildable: False build-depends: - base >= 4.5 && < 4.12 + base >= 4.5 && < 4.13 , base-compat >= 0.9.3 && < 0.11 , directory ^>= 1.3.0.2 , filepath ^>= 1.4.1.2 diff --git a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs index 585c76bb..a5664aa8 100644 --- a/haddock-library/src/Documentation/Haddock/Parser/Monad.hs +++ b/haddock-library/src/Documentation/Haddock/Parser/Monad.hs @@ -17,6 +17,7 @@ import Data.String ( IsString(..) ) import Data.Bits ( Bits(..) ) import Data.Char ( ord ) import Data.List ( foldl' ) +import Control.Applicative as App import Documentation.Haddock.Types ( Version ) @@ -52,7 +53,7 @@ peekChar' = Parsec.lookAhead Parsec.anyChar -- | Parses the given string. Returns the parsed string. string :: Text -> Parser Text -string t = Parsec.string (T.unpack t) *> pure t +string t = Parsec.string (T.unpack t) *> App.pure t -- | Scan the input text, accumulating characters as long as the scanning -- function returns true. diff --git a/haddock-test/haddock-test.cabal b/haddock-test/haddock-test.cabal index 6b6c9fd8..48314600 100644 --- a/haddock-test/haddock-test.cabal +++ b/haddock-test/haddock-test.cabal @@ -16,7 +16,7 @@ library default-language: Haskell2010 ghc-options: -Wall hs-source-dirs: src - build-depends: base >= 4.3 && < 4.12, bytestring, directory, process, filepath, Cabal, xml, xhtml, syb + build-depends: base >= 4.3 && < 4.13, bytestring, directory, process, filepath, Cabal, xml, xhtml, syb exposed-modules: Test.Haddock diff --git a/haddock-test/src/Test/Haddock.hs b/haddock-test/src/Test/Haddock.hs index f372f773..942c0587 100644 --- a/haddock-test/src/Test/Haddock.hs +++ b/haddock-test/src/Test/Haddock.hs @@ -158,7 +158,9 @@ maybeAcceptFile :: Config c -> FilePath -> CheckResult -> IO CheckResult maybeAcceptFile cfg file result | cfgAccept cfg && result `elem` [NoRef, Fail] = do Just out <- readOut cfg file - writeFile (refFile dcfg file) $ ccfgDump ccfg out + let ref = refFile dcfg file + createDirectoryIfMissing True (takeDirectory ref) + writeFile ref $ ccfgDump ccfg out pure Accepted where dcfg = cfgDirConfig cfg diff --git a/haddock-test/src/Test/Haddock/Config.hs b/haddock-test/src/Test/Haddock/Config.hs index 8b395b6c..51032a3a 100644 --- a/haddock-test/src/Test/Haddock/Config.hs +++ b/haddock-test/src/Test/Haddock/Config.hs @@ -15,8 +15,9 @@ import Control.Monad import qualified Data.List as List import Data.Maybe +import Distribution.Text +import Distribution.Types.PackageName import Distribution.InstalledPackageInfo -import Distribution.Package import Distribution.Simple.Compiler hiding (Flag) import Distribution.Simple.GHC import Distribution.Simple.PackageIndex @@ -256,15 +257,44 @@ baseDependencies ghcPath = do concat `fmap` mapM (getDependency pkgIndex) pkgs where getDependency pkgIndex name = case ifaces pkgIndex name of - [] -> do - hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name + [] -> do + hPutStrLn stderr $ "Couldn't find base test dependency: " ++ name + exitFailure + + (unit, ifaceOpt, htmlOpt) : alts -> do + when (not . null $ alts) $ + hPutStr stderr $ unlines + [ "Multiple options found for base test dependency: " ++ name + , "Choosing the first of these, which has unit id: " ++ unit + ] + + case (ifaceOpt, htmlOpt) of + (Nothing, _) -> do + hPutStr stderr $ + "No '.haddock' file found for base test dependency: " ++ name exitFailure - (ifArg:_) -> pure ["--optghc=-package" ++ name, ifArg] + + (Just iface, Nothing) -> do + hPutStrLn stderr $ + "No HTML directory found for base test dependency: " ++ name + pure [ "--optghc=-package" ++ name + , "--read-interface=" ++ iface + ] + + (Just iface, Just html) -> + pure [ "--optghc=-package" ++ name + , "--read-interface=" ++ html ++ "," ++ iface + ] + ifaces pkgIndex name = do pkg <- join $ snd <$> lookupPackageName pkgIndex (mkPackageName name) - iface <$> haddockInterfaces pkg <*> haddockHTMLs pkg - iface file html = "--read-interface=" ++ html ++ "," ++ file + let unitId = display (installedUnitId pkg) + ifaceOpt = listToMaybe (haddockInterfaces pkg) + htmlDirOpt = listToMaybe (haddockHTMLs pkg) + + pure (unitId, ifaceOpt, htmlDirOpt) + defaultDiffTool :: IO (Maybe FilePath) defaultDiffTool = diff --git a/haddock-test/src/Test/Haddock/Xhtml.hs b/haddock-test/src/Test/Haddock/Xhtml.hs index 69361f7c..8bfc973f 100644 --- a/haddock-test/src/Test/Haddock/Xhtml.hs +++ b/haddock-test/src/Test/Haddock/Xhtml.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} - +{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Haddock.Xhtml ( Xml(..) @@ -22,7 +22,6 @@ newtype Xml = Xml } deriving Eq --- TODO: Find a way to avoid warning about orphan instances. deriving instance Eq Element deriving instance Eq Content deriving instance Eq CData diff --git a/haddock.cabal b/haddock.cabal index 7401cdc7..1c84562d 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: haddock -version: 2.20.0 +version: 2.21.0 synopsis: A documentation-generation tool for Haskell libraries description: This is Haddock, a tool for automatically generating documentation @@ -23,17 +23,17 @@ description: without any documentation annotations, Haddock can generate useful documentation from your source code. . - <<https://cdn.rawgit.com/haskell/haddock/master/doc/cheatsheet/haddocks.svg>> + <<https://cdn.rawgit.com/haskell/haddock/ghc-8.6/doc/cheatsheet/haddocks.svg>> license: BSD3 license-file: LICENSE author: Simon Marlow, David Waern -maintainer: Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> +maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> homepage: http://www.haskell.org/haddock/ bug-reports: https://github.com/haskell/haddock/issues copyright: (c) Simon Marlow, David Waern category: Documentation build-type: Simple -tested-with: GHC==8.4.* +tested-with: GHC==8.6.* extra-source-files: CHANGES.md @@ -42,7 +42,6 @@ extra-source-files: doc/README.md doc/*.rst doc/conf.py - driver-test/*.hs haddock-api/src/haddock.sh html-test/src/*.hs html-test/ref/*.html @@ -65,7 +64,7 @@ executable haddock -- haddock typically only supports a single GHC major version build-depends: - base ^>= 4.11.0 + base ^>= 4.12.0 if flag(in-ghc-tree) hs-source-dirs: haddock-api/src, haddock-library/src @@ -79,15 +78,13 @@ executable haddock xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, ghc-boot, - ghc == 8.4.*, + ghc == 8.6.*, bytestring, parsec, text, transformers other-modules: - ResponseFile, - Documentation.Haddock.Parser Documentation.Haddock.Parser.Monad Documentation.Haddock.Types @@ -136,7 +133,7 @@ executable haddock Haddock.GhcUtils Haddock.Syb Haddock.Convert - + Paths_haddock autogen-modules: @@ -145,21 +142,7 @@ executable haddock 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.20.0 - - other-modules: - ResponseFile - -test-suite driver-test - type: exitcode-stdio-1.0 - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: driver-test, driver - other-modules: - ResponseFile - ResponseFileSpec - - build-depends: base, hspec + build-depends: haddock-api == 2.21.0 test-suite html-test type: exitcode-stdio-1.0 diff --git a/hoogle-test/ref/Bug722/test.txt b/hoogle-test/ref/Bug722/test.txt index 96f3747b..2f44ed8f 100644 --- a/hoogle-test/ref/Bug722/test.txt +++ b/hoogle-test/ref/Bug722/test.txt @@ -8,7 +8,7 @@ module Bug722 class Foo a (!@#) :: Foo a => a -> a -> a infixl 4 !@# -type family &* :: * -> * -> * +type family (&*) :: * -> * -> * infixr 3 &* data a :-& b (:^&) :: a -> b -> (:-&) a b diff --git a/hoogle-test/ref/Bug873/test.txt b/hoogle-test/ref/Bug873/test.txt new file mode 100644 index 00000000..19100212 --- /dev/null +++ b/hoogle-test/ref/Bug873/test.txt @@ -0,0 +1,26 @@ +-- 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>($)</tt> is levity-polymorphic in its result type, so +-- that foo $ True where foo :: Bool -> Int# is well-typed +($) :: () => (a -> b) -> a -> b +infixr 0 $ +($$) :: (a -> b) -> a -> b +infixr 0 $$ diff --git a/hoogle-test/ref/type-sigs/test.txt b/hoogle-test/ref/type-sigs/test.txt index ec5f5043..1209279c 100644 --- a/hoogle-test/ref/type-sigs/test.txt +++ b/hoogle-test/ref/type-sigs/test.txt @@ -6,11 +6,11 @@ module ReaderT newtype ReaderT r m a -ReaderT :: r -> m a -> ReaderT r m a +ReaderT :: (r -> m a) -> ReaderT r m a [runReaderT] :: ReaderT r m a -> r -> m a module ReaderTReexport newtype ReaderT r m a -ReaderT :: r -> m a -> ReaderT r m a +ReaderT :: (r -> m a) -> ReaderT r m a [runReaderT] :: ReaderT r m a -> r -> m a runReaderT :: ReaderT r m a -> r -> m a diff --git a/hoogle-test/src/Bug873/Bug873.hs b/hoogle-test/src/Bug873/Bug873.hs new file mode 100644 index 00000000..3a9a5383 --- /dev/null +++ b/hoogle-test/src/Bug873/Bug873.hs @@ -0,0 +1,5 @@ +module Bug873 (($), ($$)) where +infixr 0 $$ + +($$) :: (a -> b) -> a -> b +f $$ x = f x diff --git a/html-test/ref/Bug294.html b/html-test/ref/Bug294.html index 0548646b..790c1894 100644 --- a/html-test/ref/Bug294.html +++ b/html-test/ref/Bug294.html @@ -171,9 +171,9 @@ ><p class="src" ><a id="v:gadtField" class="def" >gadtField</a - > :: ({..} -> GADT <a href="#" title="Bug294" + > :: GADT <a href="#" title="Bug294" >A</a - >) -> <a href="#" title="Bug294" + > -> <a href="#" title="Bug294" >A</a > <a href="#" class="selflink" >#</a @@ -185,9 +185,7 @@ >data family</span > <a id="t:TP" class="def" >TP</a - > t :: <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > t :: * <a href="#" class="selflink" >#</a ></p ><div class="subs instances" @@ -247,9 +245,7 @@ >data family</span > <a id="t:DP" class="def" >DP</a - > t :: <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > t :: * <a href="#" class="selflink" >#</a ></p ><div class="subs instances" @@ -309,9 +305,7 @@ >data family</span > <a id="t:TO-39-" class="def" >TO'</a - > t :: <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > t :: * <a href="#" class="selflink" >#</a ></p ><div class="subs instances" diff --git a/html-test/ref/Bug310.html b/html-test/ref/Bug310.html index 47da5387..8fef21a6 100644 --- a/html-test/ref/Bug310.html +++ b/html-test/ref/Bug310.html @@ -99,4 +99,4 @@ ></div ></body ></html -> +>
\ No newline at end of file diff --git a/html-test/ref/Bug548.html b/html-test/ref/Bug548.html index b32f8c8c..b690b8ad 100644 --- a/html-test/ref/Bug548.html +++ b/html-test/ref/Bug548.html @@ -48,11 +48,11 @@ > <a id="t:WrappedArrow" class="def" >WrappedArrow</a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a >) b c <a href="#" class="selflink" >#</a ></p @@ -103,9 +103,9 @@ > (<a href="#" title="Bug548" >WrappedArrow</a > a b :: <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span ></td ><td class="doc empty" @@ -131,7 +131,7 @@ > (<a href="#" title="Bug548" >WrappedArrow</a > a b) :: k -> <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -427,9 +427,9 @@ > (<a href="#" title="Bug548" >WrappedArrow</a > a b c) :: <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -477,13 +477,17 @@ > (<a href="#" title="Bug548" >WrappedArrow</a > a b :: <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span ></td - ><td class="doc empty" - ></td + ><td class="doc" + ><p + ><em + >Since: base-4.7.0.0</em + ></p + ></td ></tr ><tr ><td colspan="2" @@ -502,9 +506,9 @@ > (<a href="#" title="Bug548" >WrappedArrow</a > a b :: <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a >) = <a href="#" title="GHC.Generics" >D1</a > (<a href="#" title="GHC.Generics" @@ -523,7 +527,7 @@ >S1</a > (<a href="#" title="GHC.Generics" >MetaSel</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Just</a > "unwrapArrow") <a href="#" title="GHC.Generics" >NoSourceUnpackedness</a @@ -550,8 +554,12 @@ >WrappedArrow</a > a b c)</span ></td - ><td class="doc empty" - ></td + ><td class="doc" + ><p + ><em + >Since: base-4.7.0.0</em + ></p + ></td ></tr ><tr ><td colspan="2" @@ -587,7 +595,7 @@ >S1</a > (<a href="#" title="GHC.Generics" >MetaSel</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Just</a > "unwrapArrow") <a href="#" title="GHC.Generics" >NoSourceUnpackedness</a @@ -611,4 +619,4 @@ ></div ></body ></html -> +>
\ No newline at end of file diff --git a/html-test/ref/Bug574.html b/html-test/ref/Bug574.html new file mode 100644 index 00000000..ed0a5e15 --- /dev/null +++ b/html-test/ref/Bug574.html @@ -0,0 +1,86 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug574</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >Bug574</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="#" + >foo</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.Int" + >Int</a + ></li + ></ul + ></details + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a id="v:foo" class="def" + >foo</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.Int" + >Int</a + > <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >Somthing with a spliced type</p + ></div + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/ref/Bug85.html b/html-test/ref/Bug85.html index 4b704c5f..bf7e1465 100644 --- a/html-test/ref/Bug85.html +++ b/html-test/ref/Bug85.html @@ -47,15 +47,7 @@ >data</span > <a id="t:Foo" class="def" >Foo</a - > :: (<a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - >) -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > :: (* -> *) -> * -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a @@ -83,9 +75,7 @@ >data</span > <a id="t:Baz" class="def" >Baz</a - > :: <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > :: * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a diff --git a/html-test/ref/BundledPatterns.html b/html-test/ref/BundledPatterns.html index 7febd35f..e9c77612 100644 --- a/html-test/ref/BundledPatterns.html +++ b/html-test/ref/BundledPatterns.html @@ -50,11 +50,7 @@ >Vec</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span ><ul class="subs" ><li @@ -84,11 +80,7 @@ >RTree</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span ><ul class="subs" ><li @@ -129,11 +121,7 @@ >Vec</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a @@ -295,11 +283,7 @@ >RTree</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a diff --git a/html-test/ref/BundledPatterns2.html b/html-test/ref/BundledPatterns2.html index 9e791c65..2f456728 100644 --- a/html-test/ref/BundledPatterns2.html +++ b/html-test/ref/BundledPatterns2.html @@ -50,11 +50,7 @@ >Vec</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span ><ul class="subs" ><li @@ -86,11 +82,7 @@ >RTree</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span ><ul class="subs" ><li @@ -131,11 +123,7 @@ >Vec</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a @@ -293,11 +281,7 @@ >RTree</a > :: <a href="#" title="GHC.TypeNats" >Nat</a - > -> <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > -> * -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a diff --git a/html-test/ref/ConstructorArgs.html b/html-test/ref/ConstructorArgs.html new file mode 100644 index 00000000..9aad9c86 --- /dev/null +++ b/html-test/ref/ConstructorArgs.html @@ -0,0 +1,720 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >ConstructorArgs</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >ConstructorArgs</p + ></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="#" + >Foo</a + ><ul class="subs" + ><li + >= <a href="#" + >Rec</a + > { <ul class="subs" + ><li + ><a href="#" + >x</a + > :: <a href="#" title="Data.String" + >String</a + ></li + ><li + ><a href="#" + >y</a + > :: <a href="#" title="Data.String" + >String</a + ></li + ></ul + > }</li + ><li + >| <a href="#" + >Baz</a + > <a href="#" title="Data.Int" + >Int</a + > <a href="#" title="Data.String" + >String</a + ></li + ><li + >| <a href="#" + >Boa</a + > !<a href="#" title="Data.Int" + >Int</a + > !<a href="#" title="Data.String" + >String</a + ></li + ><li + >| <a href="#" title="Data.Int" + >Int</a + > <a href="#" + >:|</a + > <a href="#" title="Data.String" + >String</a + ></li + ><li + >| <a href="#" title="Data.Int" + >Int</a + > <a href="#" + >:*</a + > <a href="#" title="Data.String" + >String</a + ></li + ></ul + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="#" + >Boo</a + > <span class="keyword" + >where</span + ><ul class="subs" + ><li + ><a href="#" + >Foo</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.String" + >String</a + > -> <a href="#" title="ConstructorArgs" + >Boo</a + ></li + ><li + ><a href="#" + >Foa</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="ConstructorArgs" + >Boo</a + ></li + ><li + ><span class="keyword" + >pattern</span + > <a href="#" + >Fo</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.String" + >String</a + > -> <a href="#" title="ConstructorArgs" + >Boo</a + ></li + ><li + ><span class="keyword" + >pattern</span + > <a href="#" + >Fo'</a + > :: <a href="#" title="ConstructorArgs" + >Boo</a + ></li + ></ul + ></li + ><li class="src short" + ><span class="keyword" + >pattern</span + > <a href="#" + >Bo</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.String" + >String</a + > -> <a href="#" title="ConstructorArgs" + >Boo</a + ></li + ><li class="src short" + ><span class="keyword" + >pattern</span + > <a href="#" + >Bo'</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.String" + >String</a + > -> <a href="#" title="ConstructorArgs" + >Boo</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:Foo" class="def" + >Foo</a + > <span class="fixity" + >infixr 1</span + ><span class="rightedge" + ></span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a id="v:Rec" class="def" + >Rec</a + ></td + ><td class="doc" + ><p + >doc on a record</p + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + ><a id="v:x" class="def" + >x</a + > :: <a href="#" title="Data.String" + >String</a + ></dfn + ><div class="doc" + ><p + >doc on the <code + ><a href="#" title="Data.String" + >String</a + ></code + > field of <code + ><a href="#" title="ConstructorArgs" + >Rec</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + ><a id="v:y" class="def" + >y</a + > :: <a href="#" title="Data.String" + >String</a + ></dfn + ><div class="doc" + ><p + >doc on the <code + ><a href="#" title="Data.String" + >String</a + ></code + > field of <code + ><a href="#" title="ConstructorArgs" + >Rec</a + ></code + ></p + ></div + ></li + ></ul + ></div + ></td + ></tr + ><tr + ><td class="src" + ><a id="v:Baz" class="def" + >Baz</a + > <a href="#" title="Data.Int" + >Int</a + > <a href="#" title="Data.String" + >String</a + ></td + ><td class="doc" + ><p + >old prefix doc style</p + ></td + ></tr + ><tr + ><td class="src" + ><a id="v:Boa" class="def" + >Boa</a + > <span class="fixity" + >infixr 2</span + ><span class="rightedge" + ></span + ></td + ><td class="doc" + ><p + >doc on the <code + ><a href="#" title="ConstructorArgs" + >Boa</a + ></code + > constrictor</p + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + >!<a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >doc on the <code + ><a href="#" title="Data.Int" + >Int</a + ></code + > field of <code + ><a href="#" title="ConstructorArgs" + >Boa</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >!<a href="#" title="Data.String" + >String</a + ></dfn + ><div class="doc" + ><p + >doc on the <code + ><a href="#" title="Data.String" + >String</a + ></code + > field of <code + ><a href="#" title="ConstructorArgs" + >Boa</a + ></code + ></p + ></div + ></li + ></ul + ></div + ></td + ></tr + ><tr + ><td class="src" + ><a href="#" title="Data.Int" + >Int</a + > <a id="v::-124-" class="def" + >:|</a + > <a href="#" title="Data.String" + >String</a + ></td + ><td class="doc" + ><p + >old infix doc style</p + ></td + ></tr + ><tr + ><td class="src" + ><a id="v::-42-" class="def" + >(:*)</a + > <span class="fixity" + >infixr 3</span + ><span class="rightedge" + ></span + ></td + ><td class="doc" + ><p + >doc on the <code + ><a href="#" title="ConstructorArgs" + >:*</a + ></code + > constructor</p + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + ><a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >doc on the <code + ><a href="#" title="Data.Int" + >Int</a + ></code + > field of the <code + ><a href="#" title="ConstructorArgs" + >:*</a + ></code + > constructor</p + ></div + ></li + ><li + ><dfn class="src" + ><a href="#" title="Data.String" + >String</a + ></dfn + ><div class="doc" + ><p + >doc on the <code + ><a href="#" title="Data.String" + >String</a + ></code + > field of the <code + ><a href="#" title="ConstructorArgs" + >:*</a + ></code + > constructor</p + ></div + ></li + ></ul + ></div + ></td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:Boo" class="def" + >Boo</a + > <span class="keyword" + >where</span + > <span class="fixity" + >infixr 4</span + ><span class="rightedge" + ></span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a id="v:Foo" class="def" + >Foo</a + > <span class="fixity" + >infixr 1</span + ><span class="rightedge" + ></span + ></td + ><td class="doc" + ><p + >Info about a <code + ><a href="#" title="ConstructorArgs" + >Foo</a + ></code + ></p + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + >:: <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + ><code + ><a href="#" title="Data.Int" + >Int</a + ></code + > field of <code + ><a href="#" title="ConstructorArgs" + >Foo</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >-> <a href="#" title="Data.String" + >String</a + ></dfn + ><div class="doc" + ><p + ><code + ><a href="#" title="Data.String" + >String</a + ></code + > field of <code + ><a href="#" title="ConstructorArgs" + >Foo</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >-> <a href="#" title="ConstructorArgs" + >Boo</a + ></dfn + ><div class="doc" + ><p + >Make a <code + ><a href="#" title="ConstructorArgs" + >Boo</a + ></code + ></p + ></div + ></li + ></ul + ></div + ></td + ></tr + ><tr + ><td class="src" + ><a id="v:Foa" class="def" + >Foa</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="ConstructorArgs" + >Boo</a + ></td + ><td class="doc" + ><p + >no argument docs GADT</p + ></td + ></tr + ></table + ></div + ><div class="subs bundled-patterns" + ><p class="caption" + >Bundled Patterns</p + ><table + ><tr + ><td class="src" + ><span class="keyword" + >pattern</span + > <a id="v:Fo" class="def" + >Fo</a + > <span class="fixity" + >infixr 5</span + ><span class="rightedge" + ></span + ></td + ><td class="doc" + ><p + >Info about bundled <code + ><a href="#" title="ConstructorArgs" + >Fo</a + ></code + ></p + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + >:: <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >an <code + ><a href="#" title="Data.Int" + >Int</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >-> <a href="#" title="Data.String" + >String</a + ></dfn + ><div class="doc" + ><p + >a <code + ><a href="#" title="Data.String" + >String</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >-> <a href="#" title="ConstructorArgs" + >Boo</a + ></dfn + ><div class="doc" + ><p + >a <code + ><a href="#" title="ConstructorArgs" + >Boo</a + ></code + ></p + ></div + ></li + ></ul + ></div + ></td + ></tr + ><tr + ><td class="src" + ><span class="keyword" + >pattern</span + > <a id="v:Fo-39-" class="def" + >Fo'</a + > :: <a href="#" title="ConstructorArgs" + >Boo</a + ></td + ><td class="doc" + ><p + >Bundled and no argument docs</p + ></td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:Bo" class="def" + >Bo</a + > <span class="fixity" + >infixr 6</span + ><span class="rightedge" + ></span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs arguments" + ><p class="caption" + >Arguments</p + ><table + ><tr + ><td class="src" + >:: <a href="#" title="Data.Int" + >Int</a + ></td + ><td class="doc" + ><p + >an <code + ><a href="#" title="Data.Int" + >Int</a + ></code + ></p + ></td + ></tr + ><tr + ><td class="src" + >-> <a href="#" title="Data.String" + >String</a + ></td + ><td class="doc" + ><p + >a <code + ><a href="#" title="Data.String" + >String</a + ></code + ></p + ></td + ></tr + ><tr + ><td class="src" + >-> <a href="#" title="ConstructorArgs" + >Boo</a + ></td + ><td class="doc" + ><p + >a <code + ><a href="#" title="ConstructorArgs" + >Boo</a + ></code + > pattern</p + ></td + ></tr + ></table + ></div + ><div class="doc" + ><p + >Info about not-bundled <code + ><a href="#" title="ConstructorArgs" + >Bo</a + ></code + ></p + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >pattern</span + > <a id="v:Bo-39-" class="def" + >Bo'</a + > :: <a href="#" title="Data.Int" + >Int</a + > -> <a href="#" title="Data.String" + >String</a + > -> <a href="#" title="ConstructorArgs" + >Boo</a + > <a href="#" class="selflink" + >#</a + ></p + ><div class="doc" + ><p + >Not bunded and no argument docs</p + ></div + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/ref/ConstructorPatternExport.html b/html-test/ref/ConstructorPatternExport.html index 4e062e34..6f091de7 100644 --- a/html-test/ref/ConstructorPatternExport.html +++ b/html-test/ref/ConstructorPatternExport.html @@ -97,13 +97,9 @@ >pattern</span > <a id="v:MyGADTCons" class="def" >MyGADTCons</a - > :: () => <span class="keyword" - >forall</span - > a. <a href="#" title="Data.Eq" - >Eq</a - > a => a -> <a href="#" title="Data.Int" + > :: a -> <a href="#" title="Data.Int" >Int</a - > -> MyGADT (<a href="#" title="Data.Maybe" + > -> MyGADT (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.String" >String</a diff --git a/html-test/ref/DeprecatedTypeFamily.html b/html-test/ref/DeprecatedTypeFamily.html index fd13e48a..dab7683d 100644 --- a/html-test/ref/DeprecatedTypeFamily.html +++ b/html-test/ref/DeprecatedTypeFamily.html @@ -48,21 +48,13 @@ >data family</span > <a href="#" >SomeTypeFamily</a - > k :: <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - ></li + > k :: * -> *</li ><li class="src short" ><span class="keyword" >data family</span > <a href="#" >SomeOtherTypeFamily</a - > k :: <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - ></li + > k :: * -> *</li ></ul ></details ></div @@ -75,11 +67,7 @@ >data family</span > <a id="t:SomeTypeFamily" class="def" >SomeTypeFamily</a - > k :: <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > k :: * -> * <a href="#" class="selflink" >#</a ></p ><div class="doc" @@ -97,11 +85,7 @@ >data family</span > <a id="t:SomeOtherTypeFamily" class="def" >SomeOtherTypeFamily</a - > k :: <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > k :: * -> * <a href="#" class="selflink" >#</a ></p ><div class="doc" diff --git a/html-test/ref/GADTRecords.html b/html-test/ref/GADTRecords.html index 7fb5c4d6..5f6141db 100644 --- a/html-test/ref/GADTRecords.html +++ b/html-test/ref/GADTRecords.html @@ -136,12 +136,6 @@ ><td class="src" ><a id="v:C3" class="def" >C3</a - > :: {..} -> <a href="#" title="GADTRecords" - >H1</a - > <a href="#" title="Data.Int" - >Int</a - > <a href="#" title="Data.Int" - >Int</a ></td ><td class="doc empty" ></td @@ -154,7 +148,7 @@ ><ul ><li ><dfn class="src" - ><a id="v:field" class="def" + >:: { <a id="v:field" class="def" >field</a > :: <a href="#" title="Data.Int" >Int</a @@ -164,6 +158,18 @@ >hello docs</p ></div ></li + ><li + ><dfn class="src" + >} -> <a href="#" title="GADTRecords" + >H1</a + > <a href="#" title="Data.Int" + >Int</a + > <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc empty" + ></div + ></li ></ul ></div ></td @@ -172,11 +178,7 @@ ><td class="src" ><a id="v:C4" class="def" >C4</a - > :: {..} -> <a href="#" title="GADTRecords" - >H1</a - > <a href="#" title="Data.Int" - >Int</a - > a</td + ></td ><td class="doc empty" ></td ></tr @@ -188,7 +190,7 @@ ><ul ><li ><dfn class="src" - ><a id="v:field2" class="def" + >:: { <a id="v:field2" class="def" >field2</a > :: a</dfn ><div class="doc" @@ -196,6 +198,16 @@ >hello2 docs</p ></div ></li + ><li + ><dfn class="src" + >} -> <a href="#" title="GADTRecords" + >H1</a + > <a href="#" title="Data.Int" + >Int</a + > a</dfn + ><div class="doc empty" + ></div + ></li ></ul ></div ></td diff --git a/html-test/ref/GadtConstructorArgs.html b/html-test/ref/GadtConstructorArgs.html new file mode 100644 index 00000000..7497de83 --- /dev/null +++ b/html-test/ref/GadtConstructorArgs.html @@ -0,0 +1,192 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >GadtConstructorArgs</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >GadtConstructorArgs</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a id="t:Boo" class="def" + >Boo</a + > <span class="keyword" + >where</span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a id="v:Fot" class="def" + >Fot</a + ></td + ><td class="doc empty" + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + >:: { <a id="v:x" class="def" + >x</a + > :: <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >an <code + ><a href="#" title="GadtConstructorArgs" + >x</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >, <a id="v:y" class="def" + >y</a + > :: <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >a <code + ><a href="#" title="GadtConstructorArgs" + >y</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >} -> <a href="#" title="GadtConstructorArgs" + >Boo</a + ></dfn + ><div class="doc empty" + ></div + ></li + ></ul + ></div + ></td + ></tr + ><tr + ><td class="src" + ><a id="v:Fob" class="def" + >Fob</a + ></td + ><td class="doc" + ><p + >Record GADT with docs</p + ></td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><ul + ><li + ><dfn class="src" + >:: { <a id="v:w" class="def" + >w</a + > :: <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >a <code + ><a href="#" title="GadtConstructorArgs" + >w</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >, <a id="v:z" class="def" + >z</a + > :: <a href="#" title="Data.Int" + >Int</a + ></dfn + ><div class="doc" + ><p + >a <code + ><a href="#" title="GadtConstructorArgs" + >z</a + ></code + ></p + ></div + ></li + ><li + ><dfn class="src" + >} -> <a href="#" title="GadtConstructorArgs" + >Boo</a + ></dfn + ><div class="doc" + ><p + >a <code + ><a href="#" title="GadtConstructorArgs" + >Boo</a + ></code + ></p + ></div + ></li + ></ul + ></div + ></td + ></tr + ></table + ></div + ></div + ></div + ></div + ><div id="footer" + ></div + ></body + ></html +>
\ No newline at end of file diff --git a/html-test/ref/Hash.html b/html-test/ref/Hash.html index 517428fa..8fd04bb4 100644 --- a/html-test/ref/Hash.html +++ b/html-test/ref/Hash.html @@ -115,7 +115,7 @@ >Hash</a > key => key -> <a href="#" title="System.IO" >IO</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > val)</li ><li class="src short" @@ -223,7 +223,7 @@ >Hash</a > key => key -> <a href="#" title="System.IO" >IO</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > val) <a href="#" class="selflink" >#</a @@ -232,13 +232,13 @@ ><p >Looks up a key in the hash table, returns <code ><code - ><a href="#" title="Data.Maybe" + ><a href="#" title="GHC.Maybe" >Just</a ></code > val</code > if the key was found, or <code - ><a href="#" title="Data.Maybe" + ><a href="#" title="GHC.Maybe" >Nothing</a ></code > otherwise.</p diff --git a/html-test/ref/Instances.html b/html-test/ref/Instances.html index 1b4f276f..a23f9eb9 100644 --- a/html-test/ref/Instances.html +++ b/html-test/ref/Instances.html @@ -234,7 +234,7 @@ ></span > <a href="#" title="Instances" >Foo</a - > <a href="#" title="Data.Maybe" + > <a href="#" title="GHC.Maybe" >Maybe</a ></span > <a href="#" class="selflink" @@ -258,11 +258,11 @@ ><p class="src" ><a href="#" >foo</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Int" >Int</a - > -> a -> <a href="#" title="Data.Maybe" + > -> a -> <a href="#" title="GHC.Maybe" >Maybe</a > a <a href="#" class="selflink" >#</a @@ -270,15 +270,15 @@ ><p class="src" ><a href="#" >foo'</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > a) -> <a href="#" title="Data.Int" >Int</a - > -> <a href="#" title="Data.Maybe" + > -> <a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Int" >Int</a @@ -587,9 +587,9 @@ > <a href="#" title="Instances" >Foo</a > ((->) a :: <a href="#" title="Data.Kind" - >*</a + >Type</a > -> <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span > <a href="#" class="selflink" >#</a @@ -620,11 +620,11 @@ ><p class="src" ><a href="#" >foo'</a - > :: (a -> a -> a0) -> <a href="#" title="Data.Int" + > :: (a -> (a -> a0)) -> <a href="#" title="Data.Int" >Int</a - > -> a -> a -> <a href="#" title="Data.Int" + > -> a -> (a -> <a href="#" title="Data.Int" >Int</a - > <a href="#" class="selflink" + >) <a href="#" class="selflink" >#</a ></p ></div @@ -696,7 +696,7 @@ ></span > <a href="#" title="Instances" >Bar</a - > <a href="#" title="Data.Maybe" + > <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a @@ -722,11 +722,11 @@ ><p class="src" ><a href="#" >bar</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a - > -> <a href="#" title="Data.Maybe" + > -> <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a @@ -738,17 +738,17 @@ ><p class="src" ><a href="#" >bar'</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a - >) -> <a href="#" title="Data.Maybe" + >) -> <a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > b)) <a href="#" class="selflink" >#</a @@ -756,17 +756,17 @@ ><p class="src" ><a href="#" >bar0</a - > :: (<a href="#" title="Data.Maybe" + > :: (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a - >, <a href="#" title="Data.Maybe" + >, <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a - >) -> (<a href="#" title="Data.Maybe" + >) -> (<a href="#" title="GHC.Maybe" >Maybe</a - > b, <a href="#" title="Data.Maybe" + > b, <a href="#" title="GHC.Maybe" >Maybe</a > c) <a href="#" class="selflink" >#</a @@ -774,17 +774,17 @@ ><p class="src" ><a href="#" >bar1</a - > :: (<a href="#" title="Data.Maybe" + > :: (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a - >, <a href="#" title="Data.Maybe" + >, <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a - >) -> (<a href="#" title="Data.Maybe" + >) -> (<a href="#" title="GHC.Maybe" >Maybe</a - > b, <a href="#" title="Data.Maybe" + > b, <a href="#" title="GHC.Maybe" >Maybe</a > c) <a href="#" class="selflink" >#</a @@ -800,7 +800,7 @@ ></span > <a href="#" title="Instances" >Bar</a - > <a href="#" title="Data.Maybe" + > <a href="#" title="GHC.Maybe" >Maybe</a > [a]</span > <a href="#" class="selflink" @@ -824,9 +824,9 @@ ><p class="src" ><a href="#" >bar</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a - > [a] -> <a href="#" title="Data.Maybe" + > [a] -> <a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Data.Bool" >Bool</a @@ -836,15 +836,15 @@ ><p class="src" ><a href="#" >bar'</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a - > [a]) -> <a href="#" title="Data.Maybe" + > [a]) -> <a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > b)) <a href="#" class="selflink" >#</a @@ -852,13 +852,13 @@ ><p class="src" ><a href="#" >bar0</a - > :: (<a href="#" title="Data.Maybe" + > :: (<a href="#" title="GHC.Maybe" >Maybe</a - > [a], <a href="#" title="Data.Maybe" + > [a], <a href="#" title="GHC.Maybe" >Maybe</a - > [a]) -> (<a href="#" title="Data.Maybe" + > [a]) -> (<a href="#" title="GHC.Maybe" >Maybe</a - > b, <a href="#" title="Data.Maybe" + > b, <a href="#" title="GHC.Maybe" >Maybe</a > c) <a href="#" class="selflink" >#</a @@ -866,13 +866,13 @@ ><p class="src" ><a href="#" >bar1</a - > :: (<a href="#" title="Data.Maybe" + > :: (<a href="#" title="GHC.Maybe" >Maybe</a - > [a], <a href="#" title="Data.Maybe" + > [a], <a href="#" title="GHC.Maybe" >Maybe</a - > [a]) -> (<a href="#" title="Data.Maybe" + > [a]) -> (<a href="#" title="GHC.Maybe" >Maybe</a - > b, <a href="#" title="Data.Maybe" + > b, <a href="#" title="GHC.Maybe" >Maybe</a > c) <a href="#" class="selflink" >#</a @@ -2023,7 +2023,7 @@ > c <a href="#" title="Data.Bool" >Bool</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -2035,7 +2035,7 @@ > <a href="#" title="Data.Int" >Int</a > c :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -2097,7 +2097,7 @@ > <a href="#" title="Instances" >Plugh</a > [a] c [b] :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -2107,7 +2107,7 @@ > <a href="#" title="Instances" >Thud</a > [a] c :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p diff --git a/html-test/ref/Operators.html b/html-test/ref/Operators.html index 26b7e7f0..d01038a3 100644 --- a/html-test/ref/Operators.html +++ b/html-test/ref/Operators.html @@ -136,9 +136,7 @@ >type</span > a <a href="#" ><><</a - > b :: <a href="#" title="Data.Kind" - >*</a - ></li + > b :: *</li ><li ><span class="keyword" >data</span @@ -400,9 +398,7 @@ >type</span > a <a id="t:-60--62--60-" class="def" ><><</a - > b :: <a href="#" title="Data.Kind" - >*</a - > <span class="fixity" + > b :: * <span class="fixity" >infixl 2</span ><span class="rightedge" ></span diff --git a/html-test/ref/PatternSyns.html b/html-test/ref/PatternSyns.html index ff6144cf..19c1fecf 100644 --- a/html-test/ref/PatternSyns.html +++ b/html-test/ref/PatternSyns.html @@ -120,9 +120,7 @@ ><li class="src short" ><span class="keyword" >data</span - > (a :: <a href="#" title="Data.Kind" - >*</a - >) <a href="#" + > (a :: *) <a href="#" >><</a > b = <a href="#" >Empty</a @@ -311,9 +309,7 @@ ><p class="src" ><span class="keyword" >data</span - > (a :: <a href="#" title="Data.Kind" - >*</a - >) <a id="t:-62--60-" class="def" + > (a :: *) <a id="t:-62--60-" class="def" >><</a > b <a href="#" class="selflink" >#</a diff --git a/html-test/ref/PromotedTypes.html b/html-test/ref/PromotedTypes.html index 0ec1adcc..712dde5c 100644 --- a/html-test/ref/PromotedTypes.html +++ b/html-test/ref/PromotedTypes.html @@ -81,11 +81,7 @@ >data</span > <a id="t:Pattern" class="def" >Pattern</a - > :: [<a href="#" title="Data.Kind" - >*</a - >] -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > :: [*] -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a @@ -108,7 +104,7 @@ ><td class="src" ><a id="v:Cons" class="def" >Cons</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a > h -> <a href="#" title="PromotedTypes" >Pattern</a @@ -129,11 +125,7 @@ >RevPattern</a > :: <a href="#" title="PromotedTypes" >RevList</a - > <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > * -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a @@ -158,7 +150,7 @@ ><td class="src" ><a id="v:RevCons" class="def" >RevCons</a - > :: <a href="#" title="Data.Maybe" + > :: <a href="#" title="GHC.Maybe" >Maybe</a > h -> <a href="#" title="PromotedTypes" >RevPattern</a @@ -179,13 +171,7 @@ >data</span > <a id="t:Tuple" class="def" >Tuple</a - > :: (<a href="#" title="Data.Kind" - >*</a - >, <a href="#" title="Data.Kind" - >*</a - >) -> <a href="#" title="Data.Kind" - >*</a - > <span class="keyword" + > :: (*, *) -> * <span class="keyword" >where</span > <a href="#" class="selflink" >#</a diff --git a/html-test/ref/QuantifiedConstraints.html b/html-test/ref/QuantifiedConstraints.html new file mode 100644 index 00000000..fa2c18ec --- /dev/null +++ b/html-test/ref/QuantifiedConstraints.html @@ -0,0 +1,100 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >QuantifiedConstraints</title + ><link href="#" rel="stylesheet" type="text/css" title="Ocean" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.0/MathJax.js?config=TeX-AMS-MML_HTMLorMML" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ><p class="caption empty" + ></p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe</td + ></tr + ></table + ><p class="caption" + >QuantifiedConstraints</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a id="t:Foo" class="def" + >Foo</a + > a <span class="keyword" + >where</span + > <a href="#" class="selflink" + >#</a + ></p + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a id="v:fooed" class="def" + >fooed</a + > :: a <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ><div class="top" + ><p class="src" + ><a id="v:needsParensAroundContext" class="def" + >needsParensAroundContext</a + > :: (<span class="keyword" + >forall</span + > x. <a href="#" title="QuantifiedConstraints" + >Foo</a + > (f x)) => f <a href="#" title="Data.Int" + >Int</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:needsNoParensAroundContext" class="def" + >needsNoParensAroundContext</a + > :: <a href="#" title="QuantifiedConstraints" + >Foo</a + > (f <a href="#" title="Data.Int" + >Int</a + >) => f <a href="#" title="Data.Int" + >Int</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/ref/SpuriousSuperclassConstraints.html b/html-test/ref/SpuriousSuperclassConstraints.html index cd80ed34..47dfd6cd 100644 --- a/html-test/ref/SpuriousSuperclassConstraints.html +++ b/html-test/ref/SpuriousSuperclassConstraints.html @@ -73,11 +73,7 @@ Fix spurious superclass constraints bug.</pre >data</span > <a id="t:SomeType" class="def" >SomeType</a - > (f :: <a href="#" title="Data.Kind" - >*</a - > -> <a href="#" title="Data.Kind" - >*</a - >) a <a href="#" class="selflink" + > (f :: * -> *) a <a href="#" class="selflink" >#</a ></p ><div class="subs instances" diff --git a/html-test/ref/Test.html b/html-test/ref/Test.html index 26481afe..ce180a19 100644 --- a/html-test/ref/Test.html +++ b/html-test/ref/Test.html @@ -167,7 +167,7 @@ >A</a > <a href="#" title="Data.Int" >Int</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Prelude" >Float</a @@ -712,7 +712,7 @@ >A</a > <a href="#" title="Data.Int" >Int</a - > (<a href="#" title="Data.Maybe" + > (<a href="#" title="GHC.Maybe" >Maybe</a > <a href="#" title="Prelude" >Float</a diff --git a/html-test/ref/TypeFamilies.html b/html-test/ref/TypeFamilies.html index 1fe20c4b..9a4945dd 100644 --- a/html-test/ref/TypeFamilies.html +++ b/html-test/ref/TypeFamilies.html @@ -110,9 +110,7 @@ >data family</span > <a href="#" >Bat</a - > (a :: k) :: <a href="#" title="Data.Kind" - >*</a - ></li + > (a :: k) :: *</li ><li class="src short" ><span class="keyword" >class</span @@ -126,17 +124,13 @@ >data</span > <a href="#" >AssocD</a - > a :: <a href="#" title="Data.Kind" - >*</a - ></li + > a :: *</li ><li ><span class="keyword" >type</span > <a href="#" >AssocT</a - > a :: <a href="#" title="Data.Kind" - >*</a - ></li + > a :: *</li ></ul ></li ><li class="src short" @@ -287,7 +281,7 @@ > <a href="#" title="TypeFamilies" >X</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -299,7 +293,7 @@ > <a href="#" title="TypeFamilies" >X</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -502,7 +496,7 @@ > <a href="#" title="TypeFamilies" >X</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a >)</div ></details ></td @@ -627,7 +621,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span > <a href="#" class="selflink" >#</a @@ -652,7 +646,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >) = <a href="#" title="TypeFamilies" >X</a ></div @@ -719,7 +713,7 @@ > <a href="#" title="TypeFamilies" >Y</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -731,7 +725,7 @@ > <a href="#" title="TypeFamilies" >Y</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -987,7 +981,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span > <a href="#" class="selflink" >#</a @@ -1012,7 +1006,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >) = a</div ></details ></td @@ -1103,7 +1097,13 @@ ><li class="inst" ><a id="v:BatZ1" class="def" >BatZ1</a - > :: <a href="#" title="TypeFamilies" + > :: <span class="keyword" + >forall</span + > (z :: <a href="#" title="TypeFamilies" + >Z</a + >). <a href="#" title="TypeFamilies" + >Z</a + > -> <a href="#" title="TypeFamilies" >Bat</a > <a href="#" title="TypeFamilies" >ZA</a @@ -1111,7 +1111,11 @@ ><li class="inst" ><a id="v:BatZ2" class="def" >BatZ2</a - > :: <a href="#" title="TypeFamilies" + > :: <span class="keyword" + >forall</span + > (z :: <a href="#" title="TypeFamilies" + >Z</a + >). {..} -> <a href="#" title="TypeFamilies" >Bat</a > <a href="#" title="TypeFamilies" >ZB</a @@ -1319,9 +1323,7 @@ >data family</span > <a id="t:Bat" class="def" >Bat</a - > (a :: k) :: <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > (a :: k) :: * <a href="#" class="selflink" >#</a ></p ><div class="doc" @@ -1375,7 +1377,13 @@ ><li class="inst" ><a id="v:BatZ1" class="def" >BatZ1</a - > :: <a href="#" title="TypeFamilies" + > :: <span class="keyword" + >forall</span + > (z :: <a href="#" title="TypeFamilies" + >Z</a + >). <a href="#" title="TypeFamilies" + >Z</a + > -> <a href="#" title="TypeFamilies" >Bat</a > <a href="#" title="TypeFamilies" >ZA</a @@ -1383,7 +1391,11 @@ ><li class="inst" ><a id="v:BatZ2" class="def" >BatZ2</a - > :: <a href="#" title="TypeFamilies" + > :: <span class="keyword" + >forall</span + > (z :: <a href="#" title="TypeFamilies" + >Z</a + >). {..} -> <a href="#" title="TypeFamilies" >Bat</a > <a href="#" title="TypeFamilies" >ZB</a @@ -1528,9 +1540,7 @@ >data</span > <a id="t:AssocD" class="def" >AssocD</a - > a :: <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > a :: * <a href="#" class="selflink" >#</a ></p ><div class="doc" @@ -1542,9 +1552,7 @@ >type</span > <a id="t:AssocT" class="def" >AssocT</a - > a :: <a href="#" title="Data.Kind" - >*</a - > <a href="#" class="selflink" + > a :: * <a href="#" class="selflink" >#</a ></p ><div class="doc" @@ -1595,7 +1603,7 @@ > <a href="#" title="TypeFamilies" >Y</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1607,7 +1615,7 @@ > <a href="#" title="TypeFamilies" >Y</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1653,7 +1661,7 @@ > <a href="#" title="TypeFamilies" >X</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1665,7 +1673,7 @@ > <a href="#" title="TypeFamilies" >X</a > :: <a href="#" title="Data.Kind" - >*</a + >Type</a > <a href="#" class="selflink" >#</a ></p @@ -1791,7 +1799,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span > <a href="#" class="selflink" >#</a @@ -1816,7 +1824,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >) = a</div ></details ></td @@ -1833,7 +1841,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >)</span > <a href="#" class="selflink" >#</a @@ -1858,7 +1866,7 @@ > <a href="#" title="TypeFamilies" ><></a > (a :: <a href="#" title="Data.Kind" - >*</a + >Type</a >) = <a href="#" title="TypeFamilies" >X</a ></div diff --git a/html-test/src/Bug745.hs b/html-test/src/Bug745.hs new file mode 100644 index 00000000..f26562c1 --- /dev/null +++ b/html-test/src/Bug745.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module Bug574 where +-- See https://github.com/haskell/haddock/issues/574 + +-- | Somthing with a spliced type +foo :: Int -> $(let i = [t| Int |] in [t| $i -> $i |]) +foo x y = x + y diff --git a/html-test/src/ConstructorArgs.hs b/html-test/src/ConstructorArgs.hs new file mode 100644 index 00000000..6b0da711 --- /dev/null +++ b/html-test/src/ConstructorArgs.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module ConstructorArgs (Foo(..), Boo(Foo, Foa, Fo, Fo'), pattern Bo, pattern Bo') where + +data Foo + = Rec -- ^ doc on a record + { x :: String -- ^ doc on the `String` field of `Rec` + , y :: String -- ^ doc on the `String` field of `Rec` + } + | Baz Int String -- ^ old prefix doc style + | Boa -- ^ doc on the `Boa` constrictor + !Int -- ^ doc on the `Int` field of `Boa` + !String -- ^ doc on the `String` field of `Boa` + | Int :| String -- ^ old infix doc style + | Int -- ^ doc on the `Int` field of the `:*` constructor + :* -- ^ doc on the `:*` constructor + String -- ^ doc on the `String` field of the `:*` constructor + +infixr 1 `Foo` +infixr 2 `Boa` +infixr 3 :* + +data Boo where + -- | Info about a 'Foo' + Foo :: Int -- ^ `Int` field of `Foo` + -> String -- ^ `String` field of `Foo` + -> Boo -- ^ Make a `Boo` + + -- | no argument docs GADT + Foa :: Int -> Boo + +infixr 4 `Boo` + +-- | Info about bundled 'Fo' +pattern Fo :: Int -- ^ an 'Int' + -> String -- ^ a 'String' + -> Boo -- ^ a 'Boo' +pattern Fo x y = Foo x y + +-- | Bundled and no argument docs +pattern Fo' :: Boo +pattern Fo' = Foo 1 "hi" + +infixr 5 `Fo` + +-- | Info about not-bundled 'Bo' +pattern Bo :: Int -- ^ an 'Int' + -> String -- ^ a 'String' + -> Boo -- ^ a 'Boo' pattern +pattern Bo x y = Foo x y + +-- | Not bunded and no argument docs +pattern Bo' :: Int -> String -> Boo +pattern Bo' x y = Foo x y + +infixr 6 `Bo` diff --git a/html-test/src/GadtConstructorArgs.hs b/html-test/src/GadtConstructorArgs.hs new file mode 100644 index 00000000..79ffb4d3 --- /dev/null +++ b/html-test/src/GadtConstructorArgs.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module GadtConstructorArgs (Boo(..)) where + +data Boo where + Fot :: { x :: Int -- ^ an 'x' + , y :: Int -- ^ a 'y' + } -> Boo + + -- | Record GADT with docs + Fob :: { w :: Int -- ^ a 'w' + , z :: Int -- ^ a 'z' + } -> Boo -- ^ a 'Boo' diff --git a/html-test/src/QuantifiedConstraints.hs b/html-test/src/QuantifiedConstraints.hs new file mode 100644 index 00000000..82dd81e5 --- /dev/null +++ b/html-test/src/QuantifiedConstraints.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuantifiedConstraints #-} +module QuantifiedConstraints where + +class Foo a where + fooed :: a + +needsParensAroundContext :: (forall x. Foo (f x)) => f Int +needsParensAroundContext = fooed + +needsNoParensAroundContext :: Foo (f Int) => f Int +needsNoParensAroundContext = fooed diff --git a/latex-test/ref/ConstructorArgs/ConstructorArgs.tex b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex new file mode 100644 index 00000000..44304f47 --- /dev/null +++ b/latex-test/ref/ConstructorArgs/ConstructorArgs.tex @@ -0,0 +1,69 @@ +\haddockmoduleheading{ConstructorArgs} +\label{module:ConstructorArgs} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module ConstructorArgs ( + Foo((:|), Rec, Baz, Boa, (:*), x, y), Boo(Foo, Foa, Fo, Fo'), pattern Bo, + pattern Bo' + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Foo +\end{tabular}]\haddockbegindoc +\enspace \emph{Constructors}\par +\haddockbeginconstrs +\haddockdecltt{=} & \haddockdecltt{Rec} & doc on a record \\ + & \haddocktt{\qquad \{} \haddockdecltt{x :: String} & doc on the \haddockid{String} field of \haddockid{Rec} \\ + & \haddocktt{\qquad ,} \haddockdecltt{y :: String} & doc on the \haddockid{String} field of \haddockid{Rec} \\ & \haddocktt{\qquad \}} \\ +\haddockdecltt{|} & \haddockdecltt{Baz Int String} & old prefix doc style \\ +\haddockdecltt{|} & \haddockdecltt{Boa} & doc on the \haddockid{Boa} constrictor \\ + & \qquad \haddockdecltt{!Int} & doc on the \haddockid{Int} field of \haddockid{Boa} \\ + & \qquad \haddockdecltt{!String} & doc on the \haddockid{String} field of \haddockid{Boa} \\ +\haddockdecltt{|} & \haddockdecltt{Int :| String} & old infix doc style \\ +\haddockdecltt{|} & \haddockdecltt{(:*)} & doc on the \haddockid{:*} constructor \\ + & \qquad \haddockdecltt{Int} & doc on the \haddockid{Int} field of the \haddockid{:*} constructor \\ + & \qquad \haddockdecltt{String} & doc on the \haddockid{String} field of the \haddockid{:*} constructor \\ +\end{tabulary}\par +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Boo\ where +\end{tabular}]\haddockbegindoc +\enspace \emph{Constructors}\par +\haddockbeginconstrs +& \haddockdecltt{Foo} & Info about a \haddockid{Foo} \\ + & \qquad \haddockdecltt{::} \enspace \haddockdecltt{Int} & \haddockid{Int} field of \haddockid{Foo} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{String} & \haddockid{String} field of \haddockid{Foo} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{Boo} & Make a \haddockid{Boo} \\ +& \haddockdecltt{Foa :: Int -> Boo} & no argument docs GADT \\ +\end{tabulary}\par +\enspace \emph{Bundled Patterns}\par +\haddockbeginconstrs +& \haddockdecltt{pattern Fo} & Info about bundled \haddockid{Fo} \\ + & \qquad \haddockdecltt{::} \enspace \haddockdecltt{Int} & an \haddockid{Int} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{String} & a \haddockid{String} \\ + & \qquad \haddockdecltt{->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ +& \haddockdecltt{pattern Fo' :: Boo} & Bundled and no argument docs \\ +\end{tabulary}\par +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +pattern\ Bo +\end{tabular}]\haddockbegindoc +\haddockbeginargs +\haddockdecltt{::} & \haddockdecltt{Int} & an \haddockid{Int} \\ +\haddockdecltt{->} & \haddockdecltt{String} & a \haddockid{String} \\ +\haddockdecltt{->} & \haddockdecltt{Boo} & a \haddockid{Boo} pattern \\ +\end{tabulary}\par +Info about not-bundled \haddockid{Bo}\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +pattern\ Bo'\ ::\ Int\ ->\ String\ ->\ Boo +\end{tabular}]\haddockbegindoc +Not bunded and no argument docs\par + +\end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/ref/ConstructorArgs/haddock.sty b/latex-test/ref/ConstructorArgs/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/ConstructorArgs/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/ConstructorArgs/main.tex b/latex-test/ref/ConstructorArgs/main.tex new file mode 100644 index 00000000..80f639c5 --- /dev/null +++ b/latex-test/ref/ConstructorArgs/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{ConstructorArgs} +\end{document}
\ No newline at end of file diff --git a/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex new file mode 100644 index 00000000..7aaf5512 --- /dev/null +++ b/latex-test/ref/GadtConstructorArgs/GadtConstructorArgs.tex @@ -0,0 +1,25 @@ +\haddockmoduleheading{GadtConstructorArgs} +\label{module:GadtConstructorArgs} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module GadtConstructorArgs ( + Boo(Fot, Fob, x, y, w, z) + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Boo\ where +\end{tabular}]\haddockbegindoc +\enspace \emph{Constructors}\par +\haddockbeginconstrs +& \haddockdecltt{Fot} & \\ + & \qquad \haddockdecltt{:: \{} \enspace \haddockdecltt{x :: Int} & an \haddockid{x} \\ + & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{y :: Int} & a \haddockid{y} \\ + & \qquad \haddockdecltt{\ \ \ \ \} ->} \enspace \haddockdecltt{Boo} & \\ +& \haddockdecltt{Fob} & Record GADT with docs \\ + & \qquad \haddockdecltt{:: \{} \enspace \haddockdecltt{w :: Int} & a \haddockid{w} \\ + & \qquad \haddockdecltt{\ \ \ \ ,} \enspace \haddockdecltt{z :: Int} & a \haddockid{z} \\ + & \qquad \haddockdecltt{\ \ \ \ \} ->} \enspace \haddockdecltt{Boo} & a \haddockid{Boo} \\ +\end{tabulary}\par +\end{haddockdesc}
\ No newline at end of file diff --git a/latex-test/ref/GadtConstructorArgs/haddock.sty b/latex-test/ref/GadtConstructorArgs/haddock.sty new file mode 100644 index 00000000..6e031a98 --- /dev/null +++ b/latex-test/ref/GadtConstructorArgs/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/GadtConstructorArgs/main.tex b/latex-test/ref/GadtConstructorArgs/main.tex new file mode 100644 index 00000000..dc1a1aa3 --- /dev/null +++ b/latex-test/ref/GadtConstructorArgs/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{GadtConstructorArgs} +\end{document}
\ No newline at end of file diff --git a/latex-test/src/ConstructorArgs/ConstructorArgs.hs b/latex-test/src/ConstructorArgs/ConstructorArgs.hs new file mode 100644 index 00000000..6b0da711 --- /dev/null +++ b/latex-test/src/ConstructorArgs/ConstructorArgs.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module ConstructorArgs (Foo(..), Boo(Foo, Foa, Fo, Fo'), pattern Bo, pattern Bo') where + +data Foo + = Rec -- ^ doc on a record + { x :: String -- ^ doc on the `String` field of `Rec` + , y :: String -- ^ doc on the `String` field of `Rec` + } + | Baz Int String -- ^ old prefix doc style + | Boa -- ^ doc on the `Boa` constrictor + !Int -- ^ doc on the `Int` field of `Boa` + !String -- ^ doc on the `String` field of `Boa` + | Int :| String -- ^ old infix doc style + | Int -- ^ doc on the `Int` field of the `:*` constructor + :* -- ^ doc on the `:*` constructor + String -- ^ doc on the `String` field of the `:*` constructor + +infixr 1 `Foo` +infixr 2 `Boa` +infixr 3 :* + +data Boo where + -- | Info about a 'Foo' + Foo :: Int -- ^ `Int` field of `Foo` + -> String -- ^ `String` field of `Foo` + -> Boo -- ^ Make a `Boo` + + -- | no argument docs GADT + Foa :: Int -> Boo + +infixr 4 `Boo` + +-- | Info about bundled 'Fo' +pattern Fo :: Int -- ^ an 'Int' + -> String -- ^ a 'String' + -> Boo -- ^ a 'Boo' +pattern Fo x y = Foo x y + +-- | Bundled and no argument docs +pattern Fo' :: Boo +pattern Fo' = Foo 1 "hi" + +infixr 5 `Fo` + +-- | Info about not-bundled 'Bo' +pattern Bo :: Int -- ^ an 'Int' + -> String -- ^ a 'String' + -> Boo -- ^ a 'Boo' pattern +pattern Bo x y = Foo x y + +-- | Not bunded and no argument docs +pattern Bo' :: Int -> String -> Boo +pattern Bo' x y = Foo x y + +infixr 6 `Bo` diff --git a/latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs b/latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs new file mode 100644 index 00000000..79ffb4d3 --- /dev/null +++ b/latex-test/src/GadtConstructorArgs/GadtConstructorArgs.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module GadtConstructorArgs (Boo(..)) where + +data Boo where + Fot :: { x :: Int -- ^ an 'x' + , y :: Int -- ^ a 'y' + } -> Boo + + -- | Record GADT with docs + Fob :: { w :: Int -- ^ a 'w' + , z :: Int -- ^ a 'z' + } -> Boo -- ^ a 'Boo' |